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 Text.Show (Show(..))
  12 import qualified Data.MonoTraversable as MT
  13 import qualified Data.NonNull as NonNull
  14 import qualified Data.Text as Text
  15 import qualified Prelude ()
  16
  17 import Language.Symantic.Grammar
  18 import Language.Symantic hiding (Name)
  19 import Language.Symantic.Lib (Element)
  20
  21 import Hcompta.LCC.Account
  22 import Hcompta.LCC.Name
  23
  24 -- * Class 'Sym_Account'
  25 type instance Sym Account = Sym_Account
  26 class Sym_Account term where
  27         account :: Account -> term Account
  28         default account :: Sym_Account (UnT term) => Trans term => Account -> term Account
  29         account = trans . account
  30
  31 instance Sym_Account Eval where
  32         account = Eval
  33 instance Sym_Account View where
  34         account a = View $ \_p _v -> Text.pack $ show a
  35 instance (Sym_Account r1, Sym_Account r2) => Sym_Account (Dup r1 r2) where
  36         account x = account x `Dup` account x
  37 instance (Sym_Account term, Sym_Lambda term) => Sym_Account (BetaT term)
  38
  39 instance NameTyOf Account where
  40         nameTyOf _c = ["LCC"] `Mod` "Account"
  41 instance ClassInstancesFor Account where
  42         proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
  43          | Just HRefl <- proj_ConstKiTy @(K Account) @Account c
  44          = case () of
  45                  _ | Just Refl <- proj_Const @Eq   q -> Just Dict
  46                    | Just Refl <- proj_Const @Show q -> Just Dict
  47                  _ -> Nothing
  48         proveConstraintFor _c _q = Nothing
  49 instance TypeInstancesFor Account where
  50         expandFamFor _c len f (c `TypesS` TypesZ)
  51          | Just HRefl <- proj_ConstKi @_ @Element f
  52          , Just HRefl <- proj_ConstKiTy @_ @Account c
  53          = Just $ tyConstLen @(K (MT.Element Account)) @(MT.Element Account) len
  54         expandFamFor _c _len _fam _as = Nothing
  55 instance -- Gram_Term_AtomsFor
  56  ( Gram_Alt g
  57  , Gram_Rule g
  58  , Gram_Comment g
  59  , Gram_Source src g
  60  , SymInj ss Account
  61  ) => Gram_Term_AtomsFor src ss g Account where
  62         g_term_atomsFor =
  63          [ rule "teAccount" $
  64                 lexeme $ source $
  65                 (\a src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ teAccount a)
  66                  <$> g_account
  67          ]
  68                 where
  69                 g_account :: CF g Account
  70                 g_account =
  71                         Account . NonNull.impureNonNull
  72                          <$> some (id <$ char '/' <*> g_account_section)
  73                 g_account_section :: CF g NameAccount
  74                 g_account_section =
  75                         Name . Text.pack
  76                          <$> some (choice $ unicat <$> [Unicat_Letter])
  77 instance (Source src, SymInj ss Account) => ModuleFor src ss Account where
  78         moduleFor = ["LCC"] `moduleWhere`
  79          [
  80          ]
  81
  82 tyAccount :: Source src => LenInj vs => Type src vs Account
  83 tyAccount = tyConst @(K Account) @Account
  84
  85 teAccount :: Source src => SymInj ss Account => Account -> Term src ss ts '[] (() #> Account)
  86 teAccount a = Term noConstraint tyAccount $ teSym @Account $ account a
  87
  88 -- * Class 'Sym_Name'
  89 type instance Sym Name = Sym_Name
  90 class Sym_Name (term:: * -> *) where
  91
  92 instance Sym_Name Eval where
  93 instance Sym_Name View where
  94 instance (Sym_Name r1, Sym_Name r2) => Sym_Name (Dup r1 r2) where
  95
  96 instance NameTyOf Name where
  97         nameTyOf _c = ["LCC"] `Mod` "Name"
  98 instance ClassInstancesFor Name where
  99         proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
 100          | Just HRefl <- proj_ConstKiTy @(K Name) @Name c
 101          = case () of
 102                  _ | Just Refl <- proj_Const @Eq   q -> Just Dict
 103                    | Just Refl <- proj_Const @Show q -> Just Dict
 104                  _ -> Nothing
 105         proveConstraintFor _c _q = Nothing
 106 instance TypeInstancesFor Name where
 107         expandFamFor _c len f (c `TypesS` TypesZ)
 108          | Just HRefl <- proj_ConstKi @_ @Element f
 109          , Just HRefl <- proj_ConstKiTy @_ @Name c
 110          = Just $ tyConstLen @(K (MT.Element Name)) @(MT.Element Name) len
 111         expandFamFor _c _len _fam _as = Nothing
 112 instance Gram_Term_AtomsFor src ss g Name
 113 instance (Source src, SymInj ss Name) => ModuleFor src ss Name where
 114         moduleFor = ["LCC"] `moduleWhere`
 115          [
 116          ]