]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Sym/Quantity.hs
Remove old Yesod scaffolding.
[comptalang.git] / lcc / Hcompta / LCC / Sym / Quantity.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 {-# OPTIONS_GHC -fconstraint-solver-iterations=7 #-}
4 -- | Symantic for 'Quantity'.
5 module Hcompta.LCC.Sym.Quantity where
6
7 import Data.Eq (Eq)
8 import Data.Function (($), (.))
9 import Data.Functor ((<$>))
10 import Data.Maybe (Maybe(..))
11 import Data.Ord (Ord)
12 import Data.Type.Equality ((:~:)(Refl))
13 import Prelude (Enum, Num, Real)
14 import Text.Show (Show(..))
15 import qualified Data.Text as Text
16
17 import Hcompta (Addable, Negable, Subable)
18 import Hcompta.LCC.Amount
19 import Hcompta.LCC.Grammar
20
21 import Language.Symantic.Grammar as Sym
22 import Language.Symantic
23 import Language.Symantic.Lib ()
24
25 -- * Class 'Sym_Quantity'
26 type instance Sym (Proxy Quantity) = Sym_Quantity
27 class Sym_Quantity term where
28 quantity :: Quantity -> term Quantity
29 default quantity :: Sym_Quantity (UnT term) => Trans term => Quantity -> term Quantity
30 quantity = trans . quantity
31
32 instance Sym_Quantity Eval where
33 quantity = Eval
34 instance Sym_Quantity View where
35 quantity a = View $ \_p _v -> Text.pack (show a)
36 instance (Sym_Quantity r1, Sym_Quantity r2) => Sym_Quantity (Dup r1 r2) where
37 quantity x = quantity x `Dup` quantity x
38 instance (Sym_Quantity term, Sym_Lambda term) => Sym_Quantity (BetaT term)
39
40 instance ClassInstancesFor Quantity where
41 proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
42 | Just HRefl <- proj_ConstKiTy @(K Quantity) @Quantity c
43 = case () of
44 _ | Just Refl <- proj_Const @Addable q -> Just Dict
45 | Just Refl <- proj_Const @Negable q -> Just Dict
46 | Just Refl <- proj_Const @Subable q -> Just Dict
47 | Just Refl <- proj_Const @Enum q -> Just Dict
48 | Just Refl <- proj_Const @Eq q -> Just Dict
49 -- | Just Refl <- proj_Const @Fractional q -> Just Dict
50 | Just Refl <- proj_Const @Num q -> Just Dict
51 | Just Refl <- proj_Const @Ord q -> Just Dict
52 | Just Refl <- proj_Const @Real q -> Just Dict
53 -- | Just Refl <- proj_Const @RealFrac q -> Just Dict
54 | Just Refl <- proj_Const @Show q -> Just Dict
55 _ -> Nothing
56 proveConstraintFor _c _q = Nothing
57 instance TypeInstancesFor Quantity
58 instance -- Gram_Term_AtomsFor
59 ( Gram_Alt g
60 , Gram_Rule g
61 , Sym.Gram_Comment g
62 , Gram_Amount g
63 , Gram_Source src g
64 , Inj_Sym ss Quantity
65 , Source src
66 ) => Gram_Term_AtomsFor src ss g Quantity where
67 g_term_atomsFor =
68 [ rule "teQuantity" $
69 lexeme $ g_source $
70 (\(qty, _sty) src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ teQuantity qty)
71 <$> g_quantity
72 -- <$> some (choice $ char <$> ['0'..'9'])
73 -- <*> option [] ((:) <$> char '.' <*> some (choice $ char <$> ['0'..'9']))
74 ]
75 instance (Source src, Inj_Sym ss Quantity) => ModuleFor src ss Quantity where
76 moduleFor = ["Quantity"] `moduleWhere`
77 [
78 ]
79
80 tyQuantity :: Source src => Inj_Len vs => Type src vs Quantity
81 tyQuantity = tyConst @(K Quantity) @Quantity
82
83 teQuantity :: Source src => Inj_Sym ss Quantity => Quantity -> Term src ss ts '[] (() #> Quantity)
84 teQuantity a = Term noConstraint tyQuantity $ teSym @Quantity $ quantity a