lcc/Hcompta/LCC/Sym/Account.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'Account'.
   4 module Hcompta.LCC.Sym.Account where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Data.Eq (Eq)
   8 import Data.Function (($), (.), id)
   9 import Data.Functor (Functor(..), (<$>))
  10 import Data.Maybe (Maybe(..))
  11 import Data.Monoid (Monoid(..))
  12 import Data.Proxy
  13 import Data.Type.Equality ((:~:)(Refl))
  14 import Text.Show (Show(..))
  15 import qualified Data.NonNull as NonNull
  16 import qualified Data.Text as Text
  17 import qualified Prelude ()
  18
  19 import Hcompta.LCC.Account
  20 import Hcompta.LCC.Name
  21 import Language.Symantic
  22 import qualified Language.Symantic.Lib as Sym
  23
  24 -- * Class 'Sym_Account'
  25 class Sym_Account term where
  26         account :: Account -> term Account
  27         default account :: Trans t term => Account -> t term Account
  28         account = trans_lift . account
  29
  30 type instance Sym_of_Iface (Proxy Account) = Sym_Account
  31 type instance TyConsts_of_Iface (Proxy Account) = Proxy Account ': TyConsts_imported_by (Proxy Account)
  32 type instance TyConsts_imported_by (Proxy Account) =
  33  [ Proxy Eq
  34  , Proxy Show
  35  ]
  36
  37 instance Sym_Account HostI where
  38         account = HostI
  39 instance Sym_Account TextI where
  40         account a = TextI $ \_p _v ->
  41                 Text.pack (show a)
  42 instance (Sym_Account r1, Sym_Account r2) => Sym_Account (DupI r1 r2) where
  43         account x = account x `DupI` account x
  44
  45 instance
  46  ( Read_TyNameR TyName cs rs
  47  , Inj_TyConst cs Account
  48  ) => Read_TyNameR TyName cs (Proxy Account ': rs) where
  49         read_TyNameR _cs (TyName "Account") k = k (ty @Account)
  50         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  51 instance Show_TyConst cs => Show_TyConst (Proxy Account ': cs) where
  52         show_TyConst TyConstZ{} = "Account"
  53         show_TyConst (TyConstS c) = show_TyConst c
  54
  55 instance Proj_TyFamC cs Sym.TyFam_MonoElement Account
  56
  57 instance -- Proj_TyConC
  58  ( Proj_TyConst cs Account
  59  , Proj_TyConsts cs (TyConsts_imported_by (Proxy Account))
  60  ) => Proj_TyConC cs (Proxy Account) where
  61         proj_TyConC _ (TyConst q :$ TyConst c)
  62          | Just Refl <- eq_skind (kind_of_TyConst c) SKiType
  63          , Just Refl <- proj_TyConst c (Proxy @Account)
  64          = case () of
  65                  _ | Just Refl <- proj_TyConst q (Proxy @Eq)   -> Just TyCon
  66                    | Just Refl <- proj_TyConst q (Proxy @Show) -> Just TyCon
  67                  _ -> Nothing
  68         proj_TyConC _c _q = Nothing
  69 data instance TokenT meta (ts::[*]) (Proxy Account)
  70  = Token_Term_Account Account
  71 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Account))
  72 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Account))
  73
  74 instance -- CompileI
  75  ( Inj_TyConst cs Account
  76  -- , Inj_TyConst (TyConsts_of_Ifaces is) (->)
  77  , Proj_TyCon  cs
  78  , Compile cs is
  79  ) => CompileI cs is (Proxy Account) where
  80         compileI tok _ctx k =
  81                 case tok of
  82                  Token_Term_Account a -> k (ty @Account) $ TermO $ \_c -> account a
  83 instance -- TokenizeT
  84  Inj_Token meta ts Account =>
  85  TokenizeT meta ts (Proxy Account) where
  86         tokenizeT _t = mempty
  87 instance -- Gram_Term_AtomsT
  88  ( Alt g
  89  , Gram_Rule g
  90  , Gram_Lexer g
  91  , Gram_Meta meta g
  92  , Inj_Token meta ts Account
  93  ) => Gram_Term_AtomsT meta ts (Proxy Account) g where
  94         gs_term_atomsT _t =
  95          [ rule "term_account" $
  96                 lexeme $ metaG $
  97                 (\a meta -> ProTok $ inj_EToken meta $ Token_Term_Account a)
  98                  <$> g_account
  99          ]
 100                 where
 101                 g_account :: CF g Account
 102                 g_account =
 103                         Account . NonNull.impureNonNull
 104                          <$> some (id <$ char '/' <*> g_account_section)
 105                 g_account_section :: CF g Account_Section
 106                 g_account_section =
 107                         Name . Text.pack
 108                          <$> some (choice $ unicat <$> [Unicat_Letter])