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 ClassInstancesFor Amounts where
  52         proveConstraintFor _ (TyApp _ (TyConst _ _ q) c)
  53          | Just HRefl <- proj_ConstKiTy @(K Amounts) @Amounts c
  54          = case () of
  55                  _ | Just Refl <- proj_Const @Addable q -> Just Dict
  56                    | Just Refl <- proj_Const @Eq      q -> Just Dict
  57                    | Just Refl <- proj_Const @Negable q -> Just Dict
  58                    | Just Refl <- proj_Const @Show    q -> Just Dict
  59                    | Just Refl <- proj_Const @Subable q -> Just Dict
  60                  _ -> Nothing
  61         proveConstraintFor _c _q = Nothing
  62 instance TypeInstancesFor Amounts
  63
  64 instance Gram_Term_AtomsFor meta ss g Amounts
  65 instance (Source src, SymInj ss Amounts, SymInj ss Unit) => ModuleFor src ss Amounts where
  66         moduleFor = ["Amount"] `moduleWhere`
  67          [ NameTe n  `WithFixity` Fixity1 (mkFixy side 10) := mkAmount nega u
  68          | (u, style_amount_unit_side -> S.Just side) <-
  69                 Map.toList $
  70                 LCC.unStyle_Amounts LCC.style_amounts
  71          , let tu = H.unit_text u
  72          , (n, nega) <- if isOp tu
  73                 then [(tu, False)]
  74                 else case side of
  75                  LCC.L -> [("-"<>tu, True), (tu, False), (tu<>"-", True)]
  76                  LCC.R -> [(tu, False)]
  77          ]
  78                 where
  79                 isOp = Text.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
  80                 mkFixy LCC.L = Prefix
  81                 mkFixy LCC.R = Postfix
  82                 mkAmount :: Source src => SymInj ss Amounts => Bool -> Unit -> Term src ss ts '[] (() #> (Quantity -> Amounts))
  83                 mkAmount True  u = Term noConstraint (tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam1 $ \q -> amounts (unit u) (neg q)
  84                 mkAmount False u = Term noConstraint (tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam1 $ \q -> amounts (unit u) q
  85
  86 tyAmounts :: Source src => LenInj vs => Type src vs Amounts
  87 tyAmounts = tyConst @(K Amounts) @Amounts
  88
  89 teAmount :: TermDef Amounts '[] (() #> (Unit -> Quantity -> Amounts))
  90 teAmount = Term noConstraint (tyUnit ~> tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam2 amounts