{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Account'. module Hcompta.LCC.Sym.Account where import Control.Applicative (Applicative(..)) import Data.Eq (Eq) import Data.Function (($), (.), id) import Data.Functor (Functor(..), (<$>)) import Data.Maybe (Maybe(..)) import Text.Show (Show(..)) import qualified Data.MonoTraversable as MT import qualified Data.NonNull as NonNull import qualified Data.Text as Text import qualified Prelude () import Language.Symantic.Grammar import Language.Symantic hiding (Name) import Language.Symantic.Lib (Element) import Hcompta.LCC.Account import Hcompta.LCC.Name -- * Class 'Sym_Account' type instance Sym Account = Sym_Account class Sym_Account term where account :: Account -> term Account default account :: Sym_Account (UnT term) => Trans term => Account -> term Account account = trans . account instance Sym_Account Eval where account = Eval instance Sym_Account View where account a = View $ \_p _v -> Text.pack $ show a instance (Sym_Account r1, Sym_Account r2) => Sym_Account (Dup r1 r2) where account x = account x `Dup` account x instance (Sym_Account term, Sym_Lambda term) => Sym_Account (BetaT term) instance NameTyOf Account where nameTyOf _c = ["LCC"] `Mod` "Account" instance ClassInstancesFor Account where proveConstraintFor _c (TyApp _ (TyConst _ _ q) c) | Just HRefl <- proj_ConstKiTy @(K Account) @Account c = case () of _ | Just Refl <- proj_Const @Eq q -> Just Dict | Just Refl <- proj_Const @Show q -> Just Dict _ -> Nothing proveConstraintFor _c _q = Nothing instance TypeInstancesFor Account where expandFamFor _c len f (c `TypesS` TypesZ) | Just HRefl <- proj_ConstKi @_ @Element f , Just HRefl <- proj_ConstKiTy @_ @Account c = Just $ tyConstLen @(K (MT.Element Account)) @(MT.Element Account) len expandFamFor _c _len _fam _as = Nothing instance -- Gram_Term_AtomsFor ( Gram_Alt g , Gram_Rule g , Gram_Comment g , Gram_Source src g , SymInj ss Account ) => Gram_Term_AtomsFor src ss g Account where g_term_atomsFor = [ rule "teAccount" $ lexeme $ source $ (\a src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ teAccount a) <$> g_account ] where g_account :: CF g Account g_account = Account . NonNull.impureNonNull <$> some (id <$ char '/' <*> g_account_section) g_account_section :: CF g NameAccount g_account_section = Name . Text.pack <$> some (choice $ unicat <$> [Unicat_Letter]) instance (Source src, SymInj ss Account) => ModuleFor src ss Account where moduleFor = ["LCC"] `moduleWhere` [ ] tyAccount :: Source src => LenInj vs => Type src vs Account tyAccount = tyConst @(K Account) @Account teAccount :: Source src => SymInj ss Account => Account -> Term src ss ts '[] (() #> Account) teAccount a = Term noConstraint tyAccount $ teSym @Account $ account a -- * Class 'Sym_Name' type instance Sym Name = Sym_Name class Sym_Name (term:: * -> *) where instance Sym_Name Eval where instance Sym_Name View where instance (Sym_Name r1, Sym_Name r2) => Sym_Name (Dup r1 r2) where instance NameTyOf Name where nameTyOf _c = ["LCC"] `Mod` "Name" instance ClassInstancesFor Name where proveConstraintFor _c (TyApp _ (TyConst _ _ q) c) | Just HRefl <- proj_ConstKiTy @(K Name) @Name c = case () of _ | Just Refl <- proj_Const @Eq q -> Just Dict | Just Refl <- proj_Const @Show q -> Just Dict _ -> Nothing proveConstraintFor _c _q = Nothing instance TypeInstancesFor Name where expandFamFor _c len f (c `TypesS` TypesZ) | Just HRefl <- proj_ConstKi @_ @Element f , Just HRefl <- proj_ConstKiTy @_ @Name c = Just $ tyConstLen @(K (MT.Element Name)) @(MT.Element Name) len expandFamFor _c _len _fam _as = Nothing instance Gram_Term_AtomsFor src ss g Name instance (Source src, SymInj ss Name) => ModuleFor src ss Name where moduleFor = ["LCC"] `moduleWhere` [ ]