lcc/Hcompta/LCC/Sym/Amount.hs

   1 {-# LANGUAGE ViewPatterns #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 -- | Symantic for 'Amount'.
   5 module Hcompta.LCC.Sym.Amount where
   6
   7 import Data.Bool (Bool(..), not)
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($))
  10 import Data.Maybe (Maybe(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import Text.Show (Show(..))
  13 import qualified Data.Char as Char
  14 import qualified Data.Map.Strict as Map
  15 import qualified Data.Strict as S
  16 import qualified Data.Text as Text
  17 import qualified Language.Symantic.Typing as Sym
  18
  19 import Language.Symantic
  20 import Language.Symantic.Lib ()
  21
  22 import Hcompta (Addable, Negable, Subable)
  23 import Hcompta.LCC.Amount as LCC
  24 import Hcompta.LCC.Sym.Quantity
  25 import Hcompta.LCC.Sym.Unit
  26 import Hcompta.LCC.Sym.Negable
  27
  28 -- * Class 'Sym_Amounts'
  29 type instance Sym Amounts = Sym_Amounts
  30 class (Sym_Unit term, Sym_Negable term) => Sym_Amounts term where
  31         amounts :: term Unit -> term Quantity -> term Amounts
  32         default amounts :: Sym_Amounts (UnT term) => Trans term => term Unit -> term Quantity -> term Amounts
  33         amounts = trans2 amounts
  34
  35 instance Sym_Amounts Eval where
  36         amounts = eval2 (\u q -> Amounts $ Map.singleton u q)
  37 instance Sym_Amounts View where
  38         amounts (View u) (View q) = View $ \p v ->
  39                 q p v <> u p v
  40                 {-
  41                 TL.toStrict $
  42                 W.displayT $
  43                 W.renderCompact False $
  44                 LCC.write_amount (amount_style, amounts u q)
  45                 -}
  46 instance (Sym_Amounts r1, Sym_Amounts r2) => Sym_Amounts (Dup r1 r2) where
  47         amounts = dup2 @Sym_Amounts amounts
  48 instance (Sym_Amounts term, Sym_Lambda term) => Sym_Amounts (BetaT term)
  49
  50 instance NameTyOf Amounts where
  51         nameTyOf _c = ["Amount"] `Mod` "Amounts"
  52 instance ClassInstancesFor Amounts where
  53         proveConstraintFor _ (TyApp _ (TyConst _ _ q) c)
  54          | Just HRefl <- proj_ConstKiTy @(K Amounts) @Amounts c
  55          = case () of
  56                  _ | Just Refl <- proj_Const @Addable q -> Just Dict
  57                    | Just Refl <- proj_Const @Eq      q -> Just Dict
  58                    | Just Refl <- proj_Const @Negable q -> Just Dict
  59                    | Just Refl <- proj_Const @Show    q -> Just Dict
  60                    | Just Refl <- proj_Const @Subable q -> Just Dict
  61                  _ -> Nothing
  62         proveConstraintFor _c _q = Nothing
  63 instance TypeInstancesFor Amounts
  64
  65 instance Gram_Term_AtomsFor meta ss g Amounts
  66 instance (Source src, SymInj ss Amounts, SymInj ss Unit) => ModuleFor src ss Amounts where
  67         moduleFor = ["Amount"] `moduleWhere`
  68          [ NameTe n  `WithFixity` Fixity1 (mkFixy side 10) := mkAmount nega u
  69          | (u, style_amount_unit_side -> S.Just side) <-
  70                 Map.toList $
  71                 LCC.unStyle_Amounts LCC.style_amounts
  72          , let Unit tu = u
  73          , not (Text.null tu)
  74          , (n, nega) <-
  75                 if isOp tu
  76                 then [(tu, False)]
  77                 else case side of
  78                  LCC.L -> [("-"<>tu, True), (tu, False), (tu<>"-", True)]
  79                  LCC.R -> [(tu, False)]
  80          ]
  81                 where
  82                 isOp = Text.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
  83                 mkFixy LCC.L = Prefix
  84                 mkFixy LCC.R = Postfix
  85                 mkAmount :: Source src => SymInj ss Amounts => Bool -> Unit -> Term src ss ts '[] (() #> (Quantity -> Amounts))
  86                 mkAmount True  u = Term noConstraint (tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam1 $ \q -> amounts (unit u) (neg q)
  87                 mkAmount False u = Term noConstraint (tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam1 $ \q -> amounts (unit u) q
  88
  89 tyAmounts :: Source src => LenInj vs => Type src vs Amounts
  90 tyAmounts = tyConst @(K Amounts) @Amounts
  91
  92 teAmount :: TermDef Amounts '[] (() #> (Unit -> Quantity -> Amounts))
  93 teAmount = Term noConstraint (tyUnit ~> tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam2 amounts