lcc/Hcompta/LCC/Sym/Journal.hs

   1 {-# LANGUAGE InstanceSigs #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 -- | Symantic for 'Journal'.
   5 module Hcompta.LCC.Sym.Journal 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.Posting (Date)
  20 import Hcompta.LCC.Journal (Journal, PathFile(..))
  21 import Language.Symantic
  22 import qualified Hcompta.LCC.Journal as LCC
  23 import qualified Language.Symantic.Lib as Sym
  24
  25 -- * Class 'Sym_Journal'
  26 class Sym_Journal term where
  27         journal                :: Journal j -> term (Journal j)
  28         journal_file           :: term (Journal j) -> term PathFile
  29         journal_last_read_time :: term (Journal j) -> term Date
  30         journal_content        :: term (Journal j) -> term j
  31         default journal                :: Trans t term => Journal j -> t term (Journal j)
  32         default journal_file           :: Trans t term => t term (Journal j) -> t term PathFile
  33         default journal_last_read_time :: Trans t term => t term (Journal j) -> t term Date
  34         default journal_content        :: Trans t term => t term (Journal j) -> t term j
  35         journal                = trans_lift . journal
  36         journal_file           = trans_map1 journal_file
  37         journal_last_read_time = trans_map1 journal_last_read_time
  38         journal_content        = trans_map1 journal_content
  39
  40 type instance Sym_of_Iface (Proxy Journal) = Sym_Journal
  41 type instance TyConsts_of_Iface (Proxy Journal) = Proxy Journal ': TyConsts_imported_by (Proxy Journal)
  42 type instance TyConsts_imported_by (Proxy Journal) =
  43  [ Proxy Eq
  44  , Proxy Show
  45  ]
  46
  47 instance Sym_Journal HostI where
  48         journal                = HostI
  49         journal_file           = liftM LCC.journal_file
  50         journal_last_read_time = liftM LCC.journal_last_read_time
  51         journal_content        = liftM LCC.journal_content
  52 instance Sym_Journal TextI where
  53         journal _              = TextI $ \_v _p -> "journal"
  54         journal_file           = textI1 "journal_file"
  55         journal_last_read_time = textI1 "journal_last_read_time"
  56         journal_content        = textI1 "journal_content"
  57 instance (Sym_Journal r1, Sym_Journal r2) => Sym_Journal (DupI r1 r2) where
  58         journal j              = journal j `DupI` journal j
  59         journal_file           = dupI1 @Sym_Journal journal_file
  60         journal_last_read_time = dupI1 @Sym_Journal journal_last_read_time
  61         journal_content        = dupI1 @Sym_Journal journal_content
  62
  63 instance
  64  ( Read_TyNameR TyName cs rs
  65  , Inj_TyConst cs Journal
  66  ) => Read_TyNameR TyName cs (Proxy Journal ': rs) where
  67         read_TyNameR _cs (TyName "Journal") k = k (ty @Journal)
  68         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  69 instance Show_TyConst cs => Show_TyConst (Proxy Journal ': cs) where
  70         show_TyConst TyConstZ{} = "Journal"
  71         show_TyConst (TyConstS c) = show_TyConst c
  72
  73 instance Proj_TyFamC cs Sym.TyFam_MonoElement Journal
  74
  75 instance -- Proj_TyConC
  76  ( Proj_TyConst cs Journal
  77  , Proj_TyConsts cs (TyConsts_imported_by (Proxy Journal))
  78  , Proj_TyCon cs
  79  ) => Proj_TyConC cs (Proxy Journal) where
  80         proj_TyConC _ (t@(TyConst q) :$ (TyConst c :$ j))
  81          | Just Refl <- eq_skind (kind_of_TyConst c) (SKiType `SKiArrow` SKiType)
  82          , Just Refl <- proj_TyConst c (Proxy @Journal)
  83          = case () of
  84                  _ | Just Refl  <- proj_TyConst q (Proxy @Eq)
  85                    , Just TyCon <- proj_TyCon (t :$ j)
  86                    -> Just TyCon
  87                    | Just Refl  <- proj_TyConst q (Proxy @Show)
  88                    , Just TyCon <- proj_TyCon (t :$ j)
  89                    -> Just TyCon
  90                  _ -> Nothing
  91         proj_TyConC _c _q = Nothing
  92 data instance TokenT meta (ts::[*]) (Proxy Journal)
  93  = Token_Term_Journal_date     (EToken meta ts)
  94  | Token_Term_Journal_postings (EToken meta ts)
  95  | Token_Term_Journal_content  (EToken meta ts)
  96 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Journal))
  97 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Journal))
  98
  99 instance -- CompileI
 100  ( Inj_TyConst cs Journal
 101  , Inj_TyConst cs (->)
 102  , Inj_TyConst cs PathFile
 103  , Inj_TyConst cs Date
 104  , Proj_TyCon  cs
 105  , Compile cs is
 106  ) => CompileI cs is (Proxy Journal) where
 107         compileI
 108          :: forall meta ctx ret ls rs.
 109          TokenT meta is (Proxy Journal)
 110          -> CompileT meta ctx ret cs is ls (Proxy Journal ': rs)
 111         compileI tok ctx k =
 112                 case tok of
 113                  Token_Term_Journal_date     tok_j -> get (ty @PathFile) tok_j journal_file
 114                  Token_Term_Journal_postings tok_j -> get (ty @Date)     tok_j journal_last_read_time
 115                  Token_Term_Journal_content  tok_jnl ->
 116                         compileO tok_jnl ctx $ \ty_jnl (TermO jnl) ->
 117                         check_TyEq1 (ty @Journal) (At (Just tok_jnl) ty_jnl) $ \Refl ty_j ->
 118                         k ty_j $ TermO $
 119                          \c -> journal_content (jnl c)
 120                 where
 121                 get
 122                  :: forall a. Type cs a
 123                  -> EToken meta is
 124                  -> (forall term j. Sym_Journal term => term (Journal j) -> term a)
 125                  -> Either (Error_Term meta cs is) ret
 126                 get ty_a tok_jnl op =
 127                         compileO tok_jnl ctx $ \ty_jnl (TermO jnl) ->
 128                         check_TyEq1 (ty @Journal) (At (Just tok_jnl) ty_jnl) $ \Refl _ty_j ->
 129                         k ty_a $ TermO $
 130                          \c -> op (jnl c)
 131 instance -- TokenizeT
 132  Inj_Token meta ts Journal =>
 133  TokenizeT meta ts (Proxy Journal) where
 134         tokenizeT _t = mempty
 135          { tokenizers_infix = tokenizeTMod []
 136                  [ tokenize1 "journal_file"           infixN5 Token_Term_Journal_date
 137                  , tokenize1 "journal_last_read_time" infixN5 Token_Term_Journal_postings
 138                  , tokenize1 "journal_content"        infixN5 Token_Term_Journal_content
 139                  ]
 140          }
 141 instance -- Gram_Term_AtomsT
 142  ( Alt g
 143  , Gram_Rule g
 144  , Gram_Lexer g
 145  , Gram_Meta meta g
 146  , Inj_Token meta ts Journal
 147  ) => Gram_Term_AtomsT meta ts (Proxy Journal) g where