{-# LANGUAGE NoOverloadedLists #-}
module Symantic.Compta.Calc.Unit where

import Control.DeepSeq (NFData)
--import Data.Word (Word8)
import Data.Bool (Bool(..))
import Data.Char (Char)
import Data.Int (Int)
import Data.Eq (Eq)
import Data.Ord (Ord)
import GHC.Stack (HasCallStack)
import GHC.Generics (Generic)
import Data.String (String)
import Data.Functor ((<$>))
import Data.Monoid (Monoid(..))
import Data.Function (flip)
import Data.Semigroup (Semigroup(..))
import Text.Show (Show)
import qualified Data.Map.Strict as Map
import qualified Data.Char as Char

import Symantic.Compta.Lang
import Symantic.Compta.Utils.Error

data EUR

-- * Class 'Unitable'
class Unitable repr where
  unit :: HasCallStack => Ty repr TyUnit -> repr a -> repr a
  --withUnit :: repr U -> repr a -> repr a

--withEuro :: repr a -> repr a
--withEuro = withUnit euro

-- ** Class 'EURable'
class EURable repr where
  eur :: repr TyQuantity -> repr TyAmount
(€) :: EURable repr => repr TyQuantity -> repr TyAmount
(€) = eur
-- ** Class 'USDable'
class USDable repr where
  usd :: repr TyQuantity -> repr TyAmount
--($) = usd

-- * Type 'Unit'
newtype Unit = Unit String
  deriving newtype (Eq, Ord, Show, NFData)
  deriving anyclass (Generic)
instance IsString Unit where
  fromString = \case
    s@[c] | Char.CurrencySymbol <- Char.generalCategory c -> Unit s
    [] -> Unit ""
    _ -> errorWithStack "Unit"

-- * Type 'Quantity'
newtype Quantity qty = Quantity qty
  deriving newtype (Eq, Show, NFData, Zeroable, Nullable, Addable, Negable, FromInteger, FromRational)
instance Addable a => Semigroup (Quantity a) where
  Quantity x <> Quantity y = Quantity (x + y)
instance (Zeroable a, Addable a) => Monoid (Quantity a) where
  mempty = Quantity zero

-- * Type 'Amounts'
newtype Amounts unit qty = Amounts (Map.Map unit qty)
  deriving newtype (Eq, Show, NFData)
{-
instance Zeroable (Amounts a) where
  zero = Amounts Map.empty
instance Nullable (Amounts a) where
  null (Amounts x) = Foldable.all null x
-}
instance (Ord unit, Semigroup qty) => Semigroup (Amounts unit qty) where
  Amounts x <> Amounts y = Amounts (Map.unionWith (flip (<>)) x y)
instance (Ord unit, Semigroup qty) => Monoid (Amounts unit qty) where
  mempty = Amounts Map.empty
instance Negable qty => Negable (Amounts unit qty) where
  negate (Amounts x) = Amounts (negate <$> x)

-- * Type 'AmountStyle'
data AmountStyle = AmountStyle
  {  amountStyleFractioning :: Char
  ,  amountStyleGroupingIntegral :: (Char, [Int])
  ,  amountStyleGroupingFractional :: (Char, [Int])
  ,  amountStyleUnitSideLeft :: Bool
  ,  amountStyleUnitSpaced :: Bool
  -- TODO: , amountStyleSignPlus :: Bool
  } deriving (Eq, Show, Generic, NFData)

-- ** Type 'AmountStylePrecision'
--type AmountStylePrecision = Natural
{-
amountStyles :: Map.Map Unit AmountStyle
amountStyles = Map.fromList
  [ (scalarUnit, AmountStyle
     { amountStyleFractioning = '.'
     , amountStyleGroupingFractional = (',', [3])
     , amountStyleGroupingIntegral = (',', [3])
     , amountStyleUnitSideLeft = False
     , amountStyleUnitSpaced = False
     })
  , (chfUnit, AmountStyle
     { amountStyleFractioning = ','
     , amountStyleGroupingFractional = ('.', [3])
     , amountStyleGroupingIntegral = ('.', [3])
     , amountStyleUnitSideLeft = False
     , amountStyleUnitSpaced = False
     })
  , (cnyUnit, AmountStyle
     { amountStyleFractioning = ','
     , amountStyleGroupingFractional = ('.', [3])
     , amountStyleGroupingIntegral = ('.', [3])
     , amountStyleUnitSideLeft = False
     , amountStyleUnitSpaced = False
     })
  , (eurUnit, AmountStyle
     { amountStyleFractioning = ','
     , amountStyleGroupingFractional = ('.', [3])
     , amountStyleGroupingIntegral = ('.', [3])
     , amountStyleUnitSideLeft = False
     , amountStyleUnitSpaced = False
     })
  , (gbpUnit, AmountStyle
     { amountStyleFractioning = '.'
     , amountStyleGroupingFractional = (',', [3])
     , amountStyleGroupingIntegral = (',', [3])
     , amountStyleUnitSideLeft = True
     , amountStyleUnitSpaced = False
     })
  , (inrUnit, AmountStyle
     { amountStyleFractioning = ','
     , amountStyleGroupingFractional = ('.', [3])
     , amountStyleGroupingIntegral = ('.', [3])
     , amountStyleUnitSideLeft = False
     , amountStyleUnitSpaced = False
     })
  , (jpyUnit, AmountStyle
     { amountStyleFractioning = '.'
     , amountStyleGroupingFractional = (',', [3])
     , amountStyleGroupingIntegral = (',', [3])
     , amountStyleUnitSideLeft = True
     , amountStyleUnitSpaced = False
     })
  , (rubUnit, AmountStyle
     { amountStyleFractioning = '.'
     , amountStyleGroupingFractional = (',', [3])
     , amountStyleGroupingIntegral = (',', [3])
     , amountStyleUnitSideLeft = True
     , amountStyleUnitSpaced = False
     })
  , (usdUnit, AmountStyle
     { amountStyleFractioning = '.'
     , amountStyleGroupingFractional = (',', [3])
     , amountStyleGroupingIntegral = (',', [3])
     , amountStyleUnitSideLeft = True
     , amountStyleUnitSpaced = False
     })
  ]
-}

scalarUnit :: Unit
scalarUnit = Unit ""

-- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
chfUnit :: Unit
chfUnit = Unit "CHF"

-- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
cnyUnit :: Unit
cnyUnit = Unit "Ұ"

-- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
eurUnit :: Unit
eurUnit = Unit "€"

-- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
gbpUnit :: Unit
gbpUnit = Unit "£"

-- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
inrUnit :: Unit
inrUnit = Unit "₹"

-- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
jpyUnit :: Unit
jpyUnit = Unit "¥"

-- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
rubUnit :: Unit
rubUnit = Unit "₽"

-- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
usdUnit :: Unit
usdUnit = Unit "$"



{-
import Control.DeepSeq
import Data.Bool
import Data.Char (Char)
import Data.Data
import Data.Decimal (Decimal, roundTo)
import Data.Eq (Eq(..))
import Data.Function (($), (.), const, flip)
import Data.Map.Strict (Map)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Strict.Maybe
import Data.String (IsString)
import Data.Text (Text)
import Data.Typeable ()
import Data.Word (Word8)
import Prelude (Int, seq)
import Text.Show (Show(..))
import qualified Data.Map.Strict as Map
import qualified Data.MonoTraversable as MT
import qualified Data.Strict as S
import qualified Data.Text as T

import qualified Hcompta as H

-- * Type 'Amount'
data Amount
 =   Amount
 {   amount_unit     :: !Unit
 ,   amount_quantity :: !Quantity
 } deriving (Data, Eq, Ord, Show, Typeable)

-- type instance H.UnitFor     Amount = Unit
-- type instance H.QuantityFor Amount = H.Polarized Quantity

instance NFData Amount where
  rnf (Amount q u) = rnf q `seq` rnf u
-- instance H.Amount Amount

{-
type instance H.Unit H.:@ Amount = Unit
instance H.GetI H.Unit Amount where
  getI = amount_unit
instance H.SetI H.Unit Amount where
  setI amount_unit a = a{amount_unit}

type instance H.Quantity H.:@ Amount = Quantity
instance H.GetI H.Quantity Amount where
  getI = amount_quantity
instance H.SetI H.Quantity Amount where
  setI amount_quantity a = a{amount_quantity}
-}

instance H.Zeroable Amount where
  zero = Amount "" H.zero
instance H.Nullable Amount where
  null = H.null . amount_quantity
   -- NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
   --       at 'Amount'’s 'amount_style'’s 'style_amount_precision'.
instance H.Signable Amount where
  sign = H.sign . amount_quantity

amount :: Amount
amount =
  Amount
   { amount_unit     = ""
   , amount_quantity = H.zero
   }

amount_style :: Style_Amounts -> Amount -> Style_Amount
amount_style styles = style_amount_find styles . amount_unit

-- * Type 'Quantity'
type Quantity = Decimal

quantity_round :: Word8 -> Quantity -> Quantity
quantity_round = Data.Decimal.roundTo

-- * Type 'Unit'
newtype Unit
 = Unit Text
 deriving (Data, Eq, IsString, Ord, Show, Typeable)
instance H.Zeroable Unit where
  zero = Unit ""
instance H.Nullable Unit where
  null (Unit x) = T.null x
{-
instance H.Unit Unit where
  noUnit = Unit ""
  textUnit (Unit t) = t
-}
instance NFData Unit where
  rnf (Unit t) = rnf t

-- ** Example 'Unit's


-- * Type 'Style_Amount'
data Style_Amount
 =   Style_Amount
 {   amountStyleFractioning         :: !(S.Maybe Style_Amount_Fractioning)
 ,   amountStyleGroupingIntegral   :: !(S.Maybe AmountStyleGrouping)
 ,   amountStyleGroupingFractional :: !(S.Maybe AmountStyleGrouping)
 ,   amountStyleUnitSideLeft           :: !(S.Maybe LR)
 ,   amountStyleUnitSpaced         :: !(S.Maybe Style_Amount_Spacing)
 -- TODO: , style_amount_sign_plus     :: S.Maybe Bool
 } deriving (Data, Eq, Ord, Show, Typeable)
instance NFData Style_Amount where
  rnf (Style_Amount f gi gf ui up) =
    rnf f  `seq`
    rnf gi `seq`
    rnf gf `seq`
    rnf ui `seq`
    rnf up
instance Semigroup Style_Amount where
  (<>) = style_amount_union
instance Monoid Style_Amount where
  mempty  = style_amount
  mappend = (<>)

style_amount :: Style_Amount
style_amount =
  Style_Amount
   { amountStyleFractioning         = Nothing
   , amountStyleGroupingIntegral   = Nothing
   , amountStyleGroupingFractional = Nothing
   , amountStyleUnitSideLeft           = Nothing
   , amountStyleUnitSpaced         = Nothing
   }

style_amount_union
 :: Style_Amount
 -> Style_Amount
 -> Style_Amount
style_amount_union
 sty@Style_Amount
 { amountStyleFractioning=f
 , amountStyleGroupingIntegral=gi
 , amountStyleGroupingFractional=gf
 , amountStyleUnitSideLeft=side
 , amountStyleUnitSpaced=spaced
 }
 sty'@Style_Amount
 { amountStyleFractioning=f'
 , amountStyleGroupingIntegral=gi'
 , amountStyleGroupingFractional=gf'
 , amountStyleUnitSideLeft=side'
 , amountStyleUnitSpaced=spaced'
 } =
  if sty == sty'
  then sty'
  else
    Style_Amount
     { amountStyleFractioning        = S.maybe f'      (const f)      f
     , amountStyleGroupingIntegral   = S.maybe gi'     (const gi)     gi
     , amountStyleGroupingFractional = S.maybe gf'     (const gf)     gf
     , amountStyleUnitSideLeft       = S.maybe side'   (const side)   side
     , amountStyleUnitSpaced         = S.maybe spaced' (const spaced) spaced
     }

-- ** Type 'Style_Amount_Fractioning'
type Style_Amount_Fractioning
 = Char

-- ** Type 'AmountStyleGrouping'
data AmountStyleGrouping
 =   AmountStyleGrouping Char [Int]
 deriving (Data, Eq, Ord, Show, Typeable)
instance NFData AmountStyleGrouping where
  rnf (AmountStyleGrouping s d) = rnf s `seq` rnf d

-- ** Type 'Style_Amount_Precision'
type Style_Amount_Precision
 = Word8

-- ** Type 'Style_Amount_Spacing'
type Style_Amount_Spacing
 = Bool

-- ** Type 'LR'
data LR = L | R
 deriving (Data, Eq, Ord, Show, Typeable)
instance NFData LR where
  rnf L = ()
  rnf R = ()

-- ** Type 'Style_Amounts'
newtype Style_Amounts
 =      Style_Amounts (Map Unit Style_Amount)
 deriving (Data, Eq, NFData, Ord, Show, Typeable)

-- type instance H.UnitFor     Amounts = Unit
-- type instance H.QuantityFor Amounts = Quantity

instance Semigroup Style_Amounts where
  Style_Amounts x <> Style_Amounts y =
    Style_Amounts (Map.unionWith (flip (<>)) x y)
instance Monoid Style_Amounts where
  mempty  = Style_Amounts mempty
  mappend = (<>)
instance H.Zeroable Style_Amounts where
  zero = Style_Amounts mempty
instance H.Sumable Style_Amounts (Unit, Style_Amount) where
  Style_Amounts ss += (u, s) = Style_Amounts $ Map.insertWith (flip (<>)) u s ss

unStyle_Amounts :: Style_Amounts -> Map Unit Style_Amount
unStyle_Amounts (Style_Amounts fp) = fp

style_amount_find :: Style_Amounts -> Unit -> Style_Amount
style_amount_find (Style_Amounts s) u = Map.findWithDefault mempty u s

-- *** Example 'Style_Amounts'
amountStyles :: Style_Amounts

-- ** Type 'Styled_Amount'
type Styled_Amount t = (Style_Amount, t)

styled_amount :: Style_Amounts -> Amount -> Styled_Amount Amount
styled_amount styles amt = (amount_style styles amt, amt)

-- * Type 'Amounts'
newtype Amounts = Amounts (Map Unit Quantity)
 deriving (Data, Eq, NFData, Ord, Show, Typeable
 , H.Addable, H.Negable, H.Subable)
unAmounts :: Amounts -> Map Unit Quantity
unAmounts (Amounts a) = a

type instance MT.Element Amounts = Amount
-- instance H.Amounts Amounts

-- instance H.Get (H.Balance_Amounts Unit Quantity) Amounts where
--   get (Amounts a) = a
-}