lcc/Hcompta/LCC/Sym/Transaction.hs

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