{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fconstraint-solver-iterations=7 #-}
-- | Symantic for 'Amount'.
module Hcompta.LCC.Sym.Amount where

-- import Data.Decimal (Decimal)
-- import qualified Data.Text as Text
-- import qualified Data.Text.Lazy as TL
import Control.Monad (liftM2)
import Data.Eq (Eq(..))
import Data.Function (($))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..), (<>))
import Data.Proxy
import Data.Type.Equality ((:~:)(Refl))
import Text.Show (Show(..))
import qualified Data.Map.Strict as Map
import qualified Data.Strict as S
import qualified Language.Symantic.Typing as Sym

import Hcompta (Addable, Negable, Subable)
import qualified Hcompta as H
import Hcompta.LCC.Amount as H
-- import qualified Text.WalderLeijen.ANSI.Text as W
import Hcompta.LCC.Sym.Unit

import Language.Symantic.Parsing
import Language.Symantic.Typing
import Language.Symantic.Compiling
import Language.Symantic.Interpreting
import Language.Symantic.Transforming.Trans
import Language.Symantic.Lib (Sym_Lambda(..), (~>))
import qualified Language.Symantic.Lib as Sym

-- * Class 'Sym_Amounts'
class Sym_Unit term => Sym_Amounts term where
	amounts :: term Unit -> term Quantity -> term Amounts
	default amounts :: Trans t term => t term Unit -> t term Quantity -> t term Amounts
	amounts = trans_map2 amounts

type instance Sym_of_Iface (Proxy Amounts) = Sym_Amounts
type instance TyConsts_of_Iface (Proxy Amounts) = Proxy Amounts ': TyConsts_imported_by (Proxy Amounts)
type instance TyConsts_imported_by (Proxy Amounts) =
 [ Proxy Eq
 , Proxy Addable
 , Proxy Subable
 , Proxy Negable
 , Proxy Quantity
 , Proxy Show
 , Proxy Unit
 ]

instance Sym_Amounts HostI where
	amounts = liftM2 (\u q -> Amounts $ Map.singleton u q)
instance Sym_Amounts TextI where
	amounts (TextI u) (TextI q) = TextI $ \p v ->
		q p v <> u p v
		{-
		TL.toStrict $
		W.displayT $
		W.renderCompact False $
		H.write_amount (amount_style, amounts u q)
		-}
instance (Sym_Amounts r1, Sym_Amounts r2) => Sym_Amounts (DupI r1 r2) where
	amounts = dupI2 @Sym_Amounts amounts

instance
 ( Read_TyNameR TyName cs rs
 , Inj_TyConst cs Amounts
 ) => Read_TyNameR TyName cs (Proxy Amounts ': rs) where
	read_TyNameR _cs (TyName "Amounts") k = k (ty @Amounts)
	read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
instance Show_TyConst cs => Show_TyConst (Proxy Amounts ': cs) where
	show_TyConst TyConstZ{} = "Amounts"
	show_TyConst (TyConstS c) = show_TyConst c

instance Proj_TyFamC cs Sym.TyFam_MonoElement Amounts

instance -- Proj_TyConC
 ( Proj_TyConst cs Amounts
 , Proj_TyConsts cs (TyConsts_imported_by (Proxy Amounts))
 ) => Proj_TyConC cs (Proxy Amounts) where
	proj_TyConC _ (TyConst q :$ TyConst c)
	 | Just Refl <- eq_skind (kind_of_TyConst c) SKiType
	 , Just Refl <- proj_TyConst c (Proxy @Amounts)
	 = case () of
		 _ | Just Refl <- proj_TyConst q (Proxy @Addable) -> Just TyCon
		   | Just Refl <- proj_TyConst q (Proxy @Eq)      -> Just TyCon
		   | Just Refl <- proj_TyConst q (Proxy @Negable) -> Just TyCon
		   | Just Refl <- proj_TyConst q (Proxy @Show)    -> Just TyCon
		   | Just Refl <- proj_TyConst q (Proxy @Subable) -> Just TyCon
		 _ -> Nothing
	proj_TyConC _c _q = Nothing
data instance TokenT meta (ts::[*]) (Proxy Amounts)
 = Token_Term_Amounts (Maybe Unit)
deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Amounts))
deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Amounts))

instance -- CompileI
 ( Inj_TyConst cs Amounts
 , Inj_TyConst cs (->)
 , Inj_TyConst cs Unit
 , Inj_TyConst cs Quantity
 ) => CompileI cs is (Proxy Amounts) where
	compileI tok _ctx k =
		case tok of
		 Token_Term_Amounts mu ->
			case mu of
			 Nothing ->
				k (ty @Unit ~> ty @Quantity ~> ty @Amounts) $ TermO $
				 \_c -> lam $ \u -> lam $ \q -> amounts u q
			 Just u ->
				k (ty @Quantity ~> ty @Amounts) $ TermO $
				 \_c -> lam $ \q -> amounts (unit u) q
instance -- TokenizeT
 Inj_Token meta ts Amounts =>
 TokenizeT meta ts (Proxy Amounts) where
	tokenizeT _t = mempty
	 { tokenizers_infix = tokenizeTMod []
		 [ tokenize0 "amounts" infixN5 $ Token_Term_Amounts Nothing
		 ]
	 , tokenizers_prefix = tokenizeTMod []
		 [ tokenize0 (H.unit_text u) (Prefix 10) $ Token_Term_Amounts (Just u)
		 | u <- Map.keys $ Map.filter
			 (\sty -> style_amount_unit_side sty == S.Just H.L)
			 (H.unStyle_Amounts H.style_amounts)
		 ]
	 , tokenizers_postfix = tokenizeTMod []
		 [ tokenize0 (H.unit_text u) (Postfix 10) $ Token_Term_Amounts (Just u)
		 | u <- Map.keys $ Map.filter
			 (\sty -> style_amount_unit_side sty == S.Just H.R)
			 (H.unStyle_Amounts H.style_amounts)
		 ]
	 }
instance Gram_Term_AtomsT meta ts (Proxy Amounts) g