{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Symantic for 'Amount'.
module Hcompta.LCC.Sym.Amount where

import Data.Bool (Bool(..), not)
import Data.Eq (Eq(..))
import Data.Function (($))
import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import Text.Show (Show(..))
import qualified Data.Char as Char
import qualified Data.Map.Strict as Map
import qualified Data.Strict as S
import qualified Data.Text as Text
import qualified Language.Symantic.Typing as Sym

import Language.Symantic
import Language.Symantic.Lib ()

import Hcompta (Addable, Negable, Subable)
import Hcompta.LCC.Amount as LCC
import Hcompta.LCC.Sym.Quantity
import Hcompta.LCC.Sym.Unit
import Hcompta.LCC.Sym.Negable
import Hcompta.LCC.Write as Write
import qualified Language.Symantic.Document.Term as Doc
import qualified Language.Symantic.Document.Term.IO as DocIO

-- * Class 'Sym_Amounts'
type instance Sym Amounts = Sym_Amounts
class (Sym_Unit term, Sym_Negable term) => Sym_Amounts term where
	amounts :: term Unit -> term Quantity -> term Amounts
	default amounts :: Sym_Amounts (UnT term) => Trans term => term Unit -> term Quantity -> term Amounts
	amounts = trans2 amounts

instance Sym_Amounts Eval where
	amounts = eval2 (\u q -> Amounts $ Map.singleton u q)
instance Sym_Amounts View where
	amounts (View u) (View q) = View $ \p v ->
		q p v <> u p v
		{-
		TL.toStrict $
		W.displayT $
		W.renderCompact False $
		LCC.write_amount (amount_style, amounts u q)
		-}
instance (Sym_Amounts r1, Sym_Amounts r2) => Sym_Amounts (Dup r1 r2) where
	amounts = dup2 @Sym_Amounts amounts
instance (Sym_Amounts term, Sym_Lambda term) => Sym_Amounts (BetaT term)

instance NameTyOf Amounts where
	nameTyOf _c = ["Amount"] `Mod` "Amounts"
instance ClassInstancesFor Amounts where
	proveConstraintFor _ (w:@(f:@cw:@d):@a)
	 | Just HRefl <- proj_ConstKiTy @(K Amounts) @Amounts a
	 = case () of
		 _ | Just HRefl <- proj_ConstKiTy @(K Writeable) @Writeable w
		   , Just HRefl <- proj_ConstKiTy @(K (->)) @(->) f
		   , Just HRefl <- proj_ConstKiTy @(K Write.Reader) @Write.Reader cw
		   -> case () of
			 _ | Just HRefl <- proj_ConstKiTy @(K DocIO.TermIO) @DocIO.TermIO d -> Just Dict
			   | Just HRefl <- proj_ConstKiTy @(K Doc.Term)     @Doc.Term     d -> Just Dict
			 _ -> Nothing
		 _ -> Nothing
	proveConstraintFor _ (TyConst _ _ q :$ c)
	 | Just HRefl <- proj_ConstKiTy @(K Amounts) @Amounts c
	 = case () of
		 _ | Just Refl <- proj_Const @Addable q -> Just Dict
		   | Just Refl <- proj_Const @Eq      q -> Just Dict
		   | Just Refl <- proj_Const @Negable q -> Just Dict
		   | Just Refl <- proj_Const @Show    q -> Just Dict
		   | Just Refl <- proj_Const @Subable q -> Just Dict
		 _ -> Nothing
	proveConstraintFor _c _q = Nothing
instance TypeInstancesFor Amounts

instance Gram_Term_AtomsFor meta ss g Amounts
instance (Source src, SymInj ss Amounts, SymInj ss Unit) => ModuleFor src ss Amounts where
	moduleFor = ["Amount"] `moduleWhere`
	 [ NameTe n  `WithFixity` Fixity1 (mkFixy side 10) := mkAmount nega u
	 | (u, style_amount_unit_side -> S.Just side) <-
		Map.toList $
		LCC.unStyle_Amounts LCC.style_amounts
	 , let Unit tu = u
	 , not (Text.null tu)
	 , (n, nega) <-
		if isOp tu
		then [(tu, False)]
		else case side of
		 LCC.L -> [("-"<>tu, True), (tu, False), (tu<>"-", True)]
		 LCC.R -> [(tu, False)]
	 ]
		where
		isOp = Text.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
		mkFixy LCC.L = Prefix
		mkFixy LCC.R = Postfix
		mkAmount :: Source src => SymInj ss Amounts => Bool -> Unit -> Term src ss ts '[] (() #> (Quantity -> Amounts))
		mkAmount True  u = Term noConstraint (tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam1 $ \q -> amounts (unit u) (neg q)
		mkAmount False u = Term noConstraint (tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam1 $ \q -> amounts (unit u) q

tyAmounts :: Source src => LenInj vs => Type src vs Amounts
tyAmounts = tyConst @(K Amounts) @Amounts

teAmount :: TermDef Amounts '[] (() #> (Unit -> Quantity -> Amounts))
teAmount = Term noConstraint (tyUnit ~> tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam2 amounts