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