lcc/Hcompta/LCC/Sym/Amount.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 {-# OPTIONS_GHC -fconstraint-solver-iterations=7 #-}
   4 -- | Symantic for 'Amount'.
   5 module Hcompta.LCC.Sym.Amount where
   6
   7 -- import Data.Decimal (Decimal)
   8 -- import qualified Data.Text as Text
   9 -- import qualified Data.Text.Lazy as TL
  10 import Control.Monad (liftM2)
  11 import Data.Eq (Eq(..))
  12 import Data.Function (($))
  13 import Data.Maybe (Maybe(..))
  14 import Data.Monoid (Monoid(..), (<>))
  15 import Data.Proxy
  16 import Data.Type.Equality ((:~:)(Refl))
  17 import Text.Show (Show(..))
  18 import qualified Data.Map.Strict as Map
  19 import qualified Data.Strict as S
  20 import qualified Language.Symantic.Typing as Sym
  21
  22 import Hcompta (Addable, Negable, Subable)
  23 import qualified Hcompta as H
  24 import Hcompta.LCC.Amount as H
  25 -- import qualified Text.WalderLeijen.ANSI.Text as W
  26 import Hcompta.LCC.Sym.Unit
  27
  28 import Language.Symantic.Parsing
  29 import Language.Symantic.Typing
  30 import Language.Symantic.Compiling
  31 import Language.Symantic.Interpreting
  32 import Language.Symantic.Transforming.Trans
  33 import Language.Symantic.Lib (Sym_Lambda(..), (~>))
  34 import qualified Language.Symantic.Lib as Sym
  35
  36 -- * Class 'Sym_Amounts'
  37 class Sym_Unit term => Sym_Amounts term where
  38         amounts :: term Unit -> term Quantity -> term Amounts
  39         default amounts :: Trans t term => t term Unit -> t term Quantity -> t term Amounts
  40         amounts = trans_map2 amounts
  41
  42 type instance Sym_of_Iface (Proxy Amounts) = Sym_Amounts
  43 type instance TyConsts_of_Iface (Proxy Amounts) = Proxy Amounts ': TyConsts_imported_by (Proxy Amounts)
  44 type instance TyConsts_imported_by (Proxy Amounts) =
  45  [ Proxy Eq
  46  , Proxy Addable
  47  , Proxy Subable
  48  , Proxy Negable
  49  , Proxy Quantity
  50  , Proxy Show
  51  , Proxy Unit
  52  ]
  53
  54 instance Sym_Amounts HostI where
  55         amounts = liftM2 (\u q -> Amounts $ Map.singleton u q)
  56 instance Sym_Amounts TextI where
  57         amounts (TextI u) (TextI q) = TextI $ \p v ->
  58                 q p v <> u p v
  59                 {-
  60                 TL.toStrict $
  61                 W.displayT $
  62                 W.renderCompact False $
  63                 H.write_amount (amount_style, amounts u q)
  64                 -}
  65 instance (Sym_Amounts r1, Sym_Amounts r2) => Sym_Amounts (DupI r1 r2) where
  66         amounts = dupI2 @Sym_Amounts amounts
  67
  68 instance
  69  ( Read_TyNameR TyName cs rs
  70  , Inj_TyConst cs Amounts
  71  ) => Read_TyNameR TyName cs (Proxy Amounts ': rs) where
  72         read_TyNameR _cs (TyName "Amounts") k = k (ty @Amounts)
  73         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  74 instance Show_TyConst cs => Show_TyConst (Proxy Amounts ': cs) where
  75         show_TyConst TyConstZ{} = "Amounts"
  76         show_TyConst (TyConstS c) = show_TyConst c
  77
  78 instance Proj_TyFamC cs Sym.TyFam_MonoElement Amounts
  79
  80 instance -- Proj_TyConC
  81  ( Proj_TyConst cs Amounts
  82  , Proj_TyConsts cs (TyConsts_imported_by (Proxy Amounts))
  83  ) => Proj_TyConC cs (Proxy Amounts) where
  84         proj_TyConC _ (TyConst q :$ TyConst c)
  85          | Just Refl <- eq_skind (kind_of_TyConst c) SKiType
  86          , Just Refl <- proj_TyConst c (Proxy @Amounts)
  87          = case () of
  88                  _ | Just Refl <- proj_TyConst q (Proxy @Addable) -> Just TyCon
  89                    | Just Refl <- proj_TyConst q (Proxy @Eq)      -> Just TyCon
  90                    | Just Refl <- proj_TyConst q (Proxy @Negable) -> Just TyCon
  91                    | Just Refl <- proj_TyConst q (Proxy @Show)    -> Just TyCon
  92                    | Just Refl <- proj_TyConst q (Proxy @Subable) -> Just TyCon
  93                  _ -> Nothing
  94         proj_TyConC _c _q = Nothing
  95 data instance TokenT meta (ts::[*]) (Proxy Amounts)
  96  = Token_Term_Amounts (Maybe Unit)
  97 deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Amounts))
  98 deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Amounts))
  99
 100 instance -- CompileI
 101  ( Inj_TyConst cs Amounts
 102  , Inj_TyConst cs (->)
 103  , Inj_TyConst cs Unit
 104  , Inj_TyConst cs Quantity
 105  ) => CompileI cs is (Proxy Amounts) where
 106         compileI tok _ctx k =
 107                 case tok of
 108                  Token_Term_Amounts mu ->
 109                         case mu of
 110                          Nothing ->
 111                                 k (ty @Unit ~> ty @Quantity ~> ty @Amounts) $ TermO $
 112                                  \_c -> lam $ \u -> lam $ \q -> amounts u q
 113                          Just u ->
 114                                 k (ty @Quantity ~> ty @Amounts) $ TermO $
 115                                  \_c -> lam $ \q -> amounts (unit u) q
 116 instance -- TokenizeT
 117  Inj_Token meta ts Amounts =>
 118  TokenizeT meta ts (Proxy Amounts) where
 119         tokenizeT _t = mempty
 120          { tokenizers_infix = tokenizeTMod []
 121                  [ tokenize0 "amounts" infixN5 $ Token_Term_Amounts Nothing
 122                  ]
 123          , tokenizers_prefix = tokenizeTMod []
 124                  [ tokenize0 (H.unit_text u) (Prefix 10) $ Token_Term_Amounts (Just u)
 125                  | u <- Map.keys $ Map.filter
 126                          (\sty -> style_amount_unit_side sty == S.Just H.L)
 127                          (H.unStyle_Amounts H.style_amounts)
 128                  ]
 129          , tokenizers_postfix = tokenizeTMod []
 130                  [ tokenize0 (H.unit_text u) (Postfix 10) $ Token_Term_Amounts (Just u)
 131                  | u <- Map.keys $ Map.filter
 132                          (\sty -> style_amount_unit_side sty == S.Just H.R)
 133                          (H.unStyle_Amounts H.style_amounts)
 134                  ]
 135          }
 136 instance Gram_Term_AtomsT meta ts (Proxy Amounts) g