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