lcc/Hcompta/LCC/Sym/Posting.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'Posting'.
   4 module Hcompta.LCC.Sym.Posting where
   5
   6 import Data.Eq (Eq)
   7 import Data.Function (($))
   8 import Data.Maybe (Maybe(..))
   9 import Text.Show (Show(..))
  10 import Data.Typeable (Typeable)
  11
  12 import Hcompta.LCC.Account
  13 import Hcompta.LCC.Amount
  14 import Hcompta.LCC.Posting (Posting)
  15 import qualified Hcompta.LCC.Posting as LCC
  16
  17 import Hcompta.LCC.Sym.Account (tyAccount)
  18 import Hcompta.LCC.Sym.Amount (tyAmounts)
  19
  20 import Language.Symantic
  21
  22 -- * Class 'Sym_Posting'
  23 type instance Sym (Posting sou) = Sym_Posting
  24 class Sym_Posting term where
  25         posting_account :: term (Posting sou) -> term Account
  26         posting_amounts :: term (Posting sou) -> term Amounts
  27         default posting_account :: Sym_Posting (UnT term) => Trans term => term (Posting sou) -> term Account
  28         default posting_amounts :: Sym_Posting (UnT term) => Trans term => term (Posting sou) -> term Amounts
  29         posting_account = trans1 posting_account
  30         posting_amounts = trans1 posting_amounts
  31
  32 instance Sym_Posting Eval where
  33         posting_account = eval1 LCC.posting_account
  34         posting_amounts = eval1 LCC.posting_amounts
  35 instance Sym_Posting View where
  36         posting_account = view1 "Posting.account"
  37         posting_amounts = view1 "Posting.amounts"
  38 instance (Sym_Posting r1, Sym_Posting r2) => Sym_Posting (Dup r1 r2) where
  39         posting_account = dup1 @Sym_Posting posting_account
  40         posting_amounts = dup1 @Sym_Posting posting_amounts
  41 instance (Sym_Posting term, Sym_Lambda term) => Sym_Posting (BetaT term)
  42
  43 instance Typeable sou => NameTyOf (Posting sou) where
  44         nameTyOf _c = ["Posting"] `Mod` "Posting"
  45 instance (Typeable sou, Eq sou, Show sou) => ClassInstancesFor (Posting sou) where
  46         proveConstraintFor _ (TyConst _ _ q :$ c)
  47          | Just HRefl <- proj_ConstKiTy @(K (Posting sou)) @(Posting sou) c
  48          = case () of
  49                  _ | Just Refl <- proj_Const @Eq q   -> Just Dict
  50                    | Just Refl <- proj_Const @Show q -> Just Dict
  51                  _ -> Nothing
  52         proveConstraintFor _c _q = Nothing
  53 instance TypeInstancesFor (Posting sou) where
  54
  55 instance Gram_Term_AtomsFor src ss g (Posting sou)
  56 instance
  57  ( Typeable sou
  58  , Eq sou
  59  , Show sou
  60  , Source src
  61  , SymInj ss (Posting sou)
  62  ) => ModuleFor src ss (Posting sou) where
  63         moduleFor = ["Posting"] `moduleWhere`
  64          [ "account" := tePosting_account @sou
  65          , "amounts" := tePosting_amounts @sou
  66          ]
  67
  68 tyPosting :: forall sou src vs. Eq sou => Show sou => Typeable sou => Source src => LenInj vs => Type src vs (Posting sou)
  69 tyPosting = tyConst @(K (Posting sou)) @(Posting sou)
  70
  71 tePosting_account :: forall sou src ss ts. Eq sou => Show sou => Typeable sou => Source src => SymInj ss (Posting sou) =>
  72                      Term src ss ts '[] (() #> (Posting sou -> Account))
  73 tePosting_account = Term noConstraint (tyPosting ~> tyAccount) $ teSym @(Posting sou) $ lam1 posting_account
  74
  75 tePosting_amounts :: forall sou src ss ts. Eq sou => Show sou => Typeable sou => Source src => SymInj ss (Posting sou) =>
  76                      Term src ss ts '[] (() #> (Posting sou -> Amounts))
  77 tePosting_amounts = Term noConstraint (tyPosting ~> tyAmounts) $ teSym @(Posting sou) $ lam1 posting_amounts