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 (Proxy 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 ClassInstancesFor Account where
  40         proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
  41          | Just HRefl <- proj_ConstKiTy @(K Account) @Account c
  42          = case () of
  43                  _ | Just Refl <- proj_Const @Eq   q -> Just Dict
  44                    | Just Refl <- proj_Const @Show q -> Just Dict
  45                  _ -> Nothing
  46         proveConstraintFor _c _q = Nothing
  47 instance TypeInstancesFor Account where
  48         expandFamFor _c len f (c `TypesS` TypesZ)
  49          | Just HRefl <- proj_ConstKi @_ @Element f
  50          , Just HRefl <- proj_ConstKiTy @_ @Account c
  51          = Just $ tyConstLen @(K (MT.Element Account)) @(MT.Element Account) len
  52         expandFamFor _c _len _fam _as = Nothing
  53 instance -- Gram_Term_AtomsFor
  54  ( Gram_Alt g
  55  , Gram_Rule g
  56  , Gram_Comment g
  57  , Gram_Source src g
  58  , Inj_Sym ss Account
  59  ) => Gram_Term_AtomsFor src ss g Account where
  60         g_term_atomsFor _s =
  61          [ rule "term_account" $
  62                 lexeme $ g_source $
  63                 (\a src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ teAccount a)
  64                  <$> g_account
  65          ]
  66                 where
  67                 g_account :: CF g Account
  68                 g_account =
  69                         Account . NonNull.impureNonNull
  70                          <$> some (id <$ char '/' <*> g_account_section)
  71                 g_account_section :: CF g Account_Section
  72                 g_account_section =
  73                         Name . Text.pack
  74                          <$> some (choice $ unicat <$> [Unicat_Letter])
  75 instance (Source src, Inj_Sym ss Account) => ModuleFor src ss Account where
  76         moduleFor _s = ["Account"] `moduleWhere`
  77          [
  78          ]
  79
  80 tyAccount :: Source src => Inj_Len vs => Type src vs Account
  81 tyAccount = tyConst @(K Account) @Account
  82
  83 teAccount :: Source src => Inj_Sym ss Account => Account -> Term src ss ts '[] Account
  84 teAccount a = Term noConstraint tyAccount $ teSym @Account $ account a
  85
  86 -- * Class 'Sym_Name'
  87 type instance Sym (Proxy Name) = Sym_Name
  88 class Sym_Name (term:: * -> *) where
  89
  90 instance Sym_Name Eval where
  91 instance Sym_Name View where
  92 instance (Sym_Name r1, Sym_Name r2) => Sym_Name (Dup r1 r2) where
  93
  94 instance ClassInstancesFor Name where
  95         proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
  96          | Just HRefl <- proj_ConstKiTy @(K Name) @Name c
  97          = case () of
  98                  _ | Just Refl <- proj_Const @Eq   q -> Just Dict
  99                    | Just Refl <- proj_Const @Show q -> Just Dict
 100                  _ -> Nothing
 101         proveConstraintFor _c _q = Nothing
 102 instance TypeInstancesFor Name where
 103         expandFamFor _c len f (c `TypesS` TypesZ)
 104          | Just HRefl <- proj_ConstKi @_ @Element f
 105          , Just HRefl <- proj_ConstKiTy @_ @Name c
 106          = Just $ tyConstLen @(K (MT.Element Name)) @(MT.Element Name) len
 107         expandFamFor _c _len _fam _as = Nothing
 108 instance Gram_Term_AtomsFor src ss g Name
 109 instance (Source src, Inj_Sym ss Name) => ModuleFor src ss Name where
 110         moduleFor _s = ["Name"] `moduleWhere`
 111          [
 112          ]