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