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