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

import Data.Bool (Bool(..))
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 qualified Hcompta as H
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

-- * 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 ClassInstancesFor Amounts where
	proveConstraintFor _ (TyApp _ (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 tu = H.unit_text u
	 , (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