lcc/Hcompta/LCC/Sym/Compta.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'Compta'.
   4 module Hcompta.LCC.Sym.Compta where
   5
   6 import Data.Eq (Eq)
   7 import Data.Function (($), (.))
   8 import Data.Maybe (Maybe(..))
   9 import Text.Show (Show(..))
  10 import qualified Prelude ()
  11 import Data.Typeable (Typeable)
  12 import Data.Map.Strict (Map)
  13 import System.IO (IO)
  14
  15 import Hcompta.LCC.Balance (Balance)
  16 import Hcompta.LCC.Chart (Chart(..))
  17 import Hcompta.LCC.Compta (Compta)
  18 import Hcompta.LCC.IO (PathFile(..), FromFile)
  19 import Hcompta.LCC.Journal (Journal)
  20 import Hcompta.LCC.Posting (Date)
  21 import Hcompta.LCC.Read (ComptaT, Comptable)
  22 import Hcompta.LCC.Transaction (Transaction)
  23 import Hcompta.LCC.Sym.Chart (tyChart)
  24 import Hcompta.LCC.Sym.Date (tyDate)
  25 import Hcompta.LCC.Sym.FileSystem (tyPathFile)
  26 import Hcompta.LCC.Sym.IO (tyFromFile, fromFile, Sym_FromFile)
  27 import Hcompta.LCC.Sym.Transaction (tyTransaction)
  28 import qualified Hcompta as H
  29 import qualified Hcompta.LCC.Journal as LCC
  30 import qualified Hcompta.LCC.Compta  as LCC
  31
  32 import Language.Symantic
  33 import Language.Symantic.Grammar
  34 import Language.Symantic.Lib (a0, tyMap, tyList, tyIO)
  35
  36 -- * Class 'Sym_Compta'
  37 type instance Sym (Compta src ss) = Sym_Compta
  38 class Sym_FromFile term => Sym_Compta term where
  39         compta       :: Compta src ss j -> term (Compta src ss j)
  40         compta_chart :: term (Compta src ss j) -> term Chart
  41         default compta       :: Sym_Compta (UnT term) => Trans term => Compta src ss j -> term (Compta src ss j)
  42         default compta_chart :: Sym_Compta (UnT term) => Trans term => term (Compta src ss j) -> term Chart
  43         compta       = trans . compta
  44         compta_chart = trans1 compta_chart
  45
  46 instance Sym_Compta Eval where
  47         compta       = Eval
  48         compta_chart = eval1 LCC.compta_chart
  49 instance Sym_Compta View where
  50         compta _     = View $ \_v _p -> "Compta.compta"
  51         compta_chart = view1 "Chart.compta_chart"
  52 instance (Sym_Compta r1, Sym_Compta r2) => Sym_Compta (Dup r1 r2) where
  53         compta j     = compta j `Dup` compta j
  54         compta_chart = dup1 @Sym_Compta compta_chart
  55 instance (Sym_Compta term, Sym_Lambda term) => Sym_Compta (BetaT term)
  56
  57 instance (Typeable src, Typeable ss) => NameTyOf (Compta src ss) where
  58         nameTyOf _c = ["LCC"] `Mod` "Compta"
  59 instance FixityOf (Compta src ss)
  60 instance Comptable src ss =>
  61          ClassInstancesFor (Compta src ss) where
  62         proveConstraintFor _ (TyApp _ tq@(TyConst _ _ q) (TyApp _ c j))
  63          | Just HRefl <- proj_ConstKiTy @(K (Compta src ss)) @(Compta src ss) c
  64          = case () of
  65                  _ | Just Refl <- proj_Const @Eq q
  66                    , Just Dict <- proveConstraint (tq `tyApp` j) -> Just Dict
  67                    | Just Refl <- proj_Const @Show q
  68                    , Just Dict <- proveConstraint (tq `tyApp` j) -> Just Dict
  69                  _ -> Nothing
  70         proveConstraintFor _ (TyApp _ (TyApp _ tq@(TyConst _ _ q) b) (TyApp _ c a))
  71          -- Sumable Balance (Compta src ss a)
  72          | Just HRefl <- proj_ConstKi @_ @H.Sumable q
  73          , Just HRefl <- proj_ConstKiTy @_ @Balance b
  74          , Just HRefl <- proj_ConstKiTy @_ @(Compta src ss) c
  75          , Just Dict <- proveConstraint (tq `tyApp` b `tyApp` a)
  76          = Just Dict
  77         proveConstraintFor _ (TyApp _ (TyConst _ _ q) (TyApp _ c a))
  78          -- FromFile (Compta src ss a)
  79          | Just HRefl <- proj_ConstKi @_ @FromFile q
  80          , Just HRefl <- proj_ConstKiTy @_ @(Compta src ss) c
  81          = case a of
  82                  -- Map Date [Transaction]
  83                  TyApp _ (TyApp _ m d) (TyApp _ l t)
  84                   | Just HRefl <- proj_ConstKiTy @_ @Map m
  85                   , Just HRefl <- proj_ConstKiTy @_ @Date d
  86                   , Just HRefl <- proj_ConstKiTy @_ @[] l
  87                   , Just HRefl <- proj_ConstKiTy @_ @Transaction t
  88                   -> Just Dict
  89                  _ -> Nothing
  90         proveConstraintFor _c _q = Nothing
  91 instance TypeInstancesFor (Compta src ss)
  92
  93 instance Gram_Term_AtomsFor src (Proxy (Compta src ss) ': ss) g (Compta src ss)
  94 instance
  95  ( Source src
  96  , Typeable src
  97  , Typeable ss
  98  , Comptable src ss
  99  , SymInj           (Proxy (Compta src ss) ': ss) (Compta src ss)
 100  ) => ModuleFor src (Proxy (Compta src ss) ': ss) (Compta src ss) where
 101         moduleFor = ["LCC"] `moduleWhere`
 102          [ "chart" := teCompta_chart
 103          , "readCompta" := teCompta_readCompta
 104          ]
 105
 106 tyCompta :: forall src ss vs a.
 107  Typeable src =>
 108  Typeable ss =>
 109  Comptable src ss =>
 110  Source src => LenInj vs => Type src vs a ->  Type src vs (Compta src ss a)
 111 tyCompta a = tyConstLen @(K (Compta src ss)) @(Compta src ss) (lenVars a) `tyApp` a
 112
 113 teCompta_chart ::
 114  forall src ss ts a.
 115  Typeable src =>
 116  Typeable ss =>
 117  Comptable src ss =>
 118  Source src =>
 119  Term src (Proxy (Compta src ss) ': ss) ts '[Proxy a] (() #> ((Compta src ss) a -> Chart))
 120 teCompta_chart = Term noConstraint (tyCompta @src @ss a0 ~> tyChart) $ teSym @(Compta src ss) $ lam1 compta_chart
 121
 122 teCompta_readCompta ::
 123  forall src ss ts.
 124  Typeable src =>
 125  Typeable ss =>
 126  Comptable src ss =>
 127  Source src =>
 128  Term src (Proxy (Compta src ss) ': ss) ts '[] (() #> (PathFile -> IO (Compta src ss (Map Date [Transaction]))))
 129 teCompta_readCompta = Term noConstraint (tyPathFile ~> tyIO (tyCompta @src @ss (tyMap tyDate (tyList tyTransaction)))) $ teSym @(Compta src ss) $ lam1 fromFile
 130
 131 {-
 132 tyJournal :: Source src => LenInj vs => Type src vs a ->  Type src vs (Journal a)
 133 tyJournal a = tyConstLen @(K Journal) @Journal (lenVars a) `tyApp` a
 134
 135 teJournal :: Source src => SymInj ss Journal => Journal a -> Term src ss ts '[Proxy a] (() #> Journal a)
 136 teJournal j = Term noConstraint (tyJournal a0) $ teSym @Journal $ journal j
 137
 138 teJournal_file :: Source src => SymInj ss Journal => Term src ss ts '[Proxy a] (() #> (Journal a -> PathFile))
 139 teJournal_file = Term noConstraint (tyJournal a0 ~> tyPathFile) $ teSym @Journal $ lam1 journal_file
 140
 141 teJournal_last_read_time :: Source src => SymInj ss Journal => Term src ss ts '[Proxy a] (() #> (Journal a -> Date))
 142 teJournal_last_read_time = Term noConstraint (tyJournal a0 ~> tyDate) $ teSym @Journal $ lam1 journal_last_read_time
 143
 144 teJournal_content :: Source src => SymInj ss Journal => Term src ss ts '[Proxy a] (() #> (Journal a -> a))
 145 teJournal_content = Term noConstraint (tyJournal a0 ~> a0) $ teSym @Journal $ lam1 journal_content
 146 -}