]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Sym/Account.hs
Remove old Yesod scaffolding.
[comptalang.git] / 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 =
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 = ["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 = ["Name"] `moduleWhere`
111 [
112 ]