lcc/Hcompta/LCC/Sym/Posting.hs

   1 {-# LANGUAGE InstanceSigs #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 -- | Symantic for 'Posting'.
   5 module Hcompta.LCC.Sym.Posting where
   6
   7 import Control.Monad (liftM)
   8 import Data.Eq (Eq)
   9 import Data.Either (Either)
  10 import Data.Function (($))
  11 import Data.Maybe (Maybe(..))
  12 import Data.Monoid (Monoid(..))
  13 import Data.Proxy
  14 import Data.Type.Equality ((:~:)(Refl))
  15 import Text.Show (Show(..))
  16 import qualified Prelude ()
  17
  18 import Hcompta.LCC.Account
  19 import Hcompta.LCC.Amount
  20 import Hcompta.LCC.Posting (Posting)
  21 import qualified Hcompta.LCC.Posting as LCC
  22 import Language.Symantic
  23 import qualified Language.Symantic.Lib as Sym
  24 import Language.Symantic.Lib ((~>))
  25
  26 -- * Class 'Sym_Posting'
  27 class Sym_Posting term where
  28         posting_account :: term Posting -> term Account
  29         posting_amounts :: term Posting -> term Amounts
  30         default posting_account :: Trans t term => t term Posting -> t term Account
  31         default posting_amounts :: Trans t term => t term Posting -> t term Amounts
  32         posting_account = trans_map1 posting_account
  33         posting_amounts = trans_map1 posting_amounts
  34
  35 type instance Sym_of_Iface (Proxy Posting) = Sym_Posting
  36 type instance TyConsts_of_Iface (Proxy Posting) = Proxy Posting ': TyConsts_imported_by (Proxy Posting)
  37 type instance TyConsts_imported_by (Proxy Posting) =
  38  [ Proxy Eq
  39  , Proxy Show
  40  ]
  41
  42 instance Sym_Posting HostI where
  43         posting_account = liftM LCC.posting_account
  44         posting_amounts = liftM LCC.posting_amounts
  45 instance Sym_Posting TextI where
  46         posting_account = textI1 "posting_account"
  47         posting_amounts = textI1 "posting_amounts"
  48 instance (Sym_Posting r1, Sym_Posting r2) => Sym_Posting (DupI r1 r2) where
  49         posting_account = dupI1 @Sym_Posting posting_account
  50         posting_amounts = dupI1 @Sym_Posting posting_amounts
  51
  52 instance
  53  ( Read_TyNameR TyName cs rs
  54  , Inj_TyConst cs Posting
  55  ) => Read_TyNameR TyName cs (Proxy Posting ': rs) where
  56         read_TyNameR _cs (TyName "Posting") k = k (ty @Posting)
  57         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  58 instance Show_TyConst cs => Show_TyConst (Proxy Posting ': cs) where
  59         show_TyConst TyConstZ{} = "Posting"
  60         show_TyConst (TyConstS c) = show_TyConst c
  61
  62 instance Proj_TyFamC cs Sym.TyFam_MonoElement Posting
  63
  64 instance -- Proj_TyConC
  65  ( Proj_TyConst cs Posting
  66  , Proj_TyConsts cs (TyConsts_imported_by (Proxy Posting))
  67  ) => Proj_TyConC cs (Proxy Posting) where
  68         proj_TyConC _ (TyConst q :$ TyConst c)
  69          | Just Refl <- eq_skind (kind_of_TyConst c) SKiType
  70          , Just Refl <- proj_TyConst c (Proxy @Posting)
  71          = case () of
  72                  _ | Just Refl <- proj_TyConst q (Proxy @Eq)   -> Just TyCon
  73                    | Just Refl <- proj_TyConst q (Proxy @Show) -> Just TyCon
  74                  _ -> Nothing
  75         proj_TyConC _c _q = Nothing
  76 data instance TokenT meta (ts::[*]) (Proxy Posting)
  77  = Token_Term_Posting_account
  78  | Token_Term_Posting_amounts
  79 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Posting))
  80 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Posting))
  81
  82 instance -- CompileI
  83  ( Inj_TyConst cs Posting
  84  , Inj_TyConst cs (->)
  85  , Inj_TyConst cs Account
  86  , Inj_TyConst cs Amounts
  87  , Proj_TyCon  cs
  88  , Compile cs is
  89  ) => CompileI cs is (Proxy Posting) where
  90         compileI
  91          :: forall meta ctx ret ls rs.
  92          TokenT meta is (Proxy Posting)
  93          -> CompileT meta ctx ret cs is ls (Proxy Posting ': rs)
  94         compileI tok _ctx k =
  95                 case tok of
  96                  Token_Term_Posting_account -> get (ty @Account) posting_account
  97                  Token_Term_Posting_amounts -> get (ty @Amounts) posting_amounts
  98                 where
  99                 get
 100                  :: forall a. Type cs a
 101                  -> (forall term. Sym_Posting term => term Posting -> term a)
 102                  -> Either (Error_Term meta cs is) ret
 103                 get ty_a op =
 104                         k (ty @Posting ~> ty_a) $ TermO $
 105                          \_c -> Sym.lam op
 106 instance -- TokenizeT
 107  Inj_Token meta ts Posting =>
 108  TokenizeT meta ts (Proxy Posting) where
 109         tokenizeT _t = mempty
 110          { tokenizers_infix = tokenizeTMod []
 111                  [ tokenize0 "posting_account" infixN5 Token_Term_Posting_account
 112                  , tokenize0 "posting_amounts" infixN5 Token_Term_Posting_amounts
 113                  ]
 114          }
 115 instance -- Gram_Term_AtomsT
 116  ( Alt g
 117  , Gram_Rule g
 118  , Gram_Lexer g
 119  , Gram_Meta meta g
 120  , Inj_Token meta ts Posting
 121  ) => Gram_Term_AtomsT meta ts (Proxy Posting) g where