]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Sym/Amount.hs
Commit old WIP.
[comptalang.git] / lcc / Hcompta / LCC / Sym / Amount.hs
1 {-# LANGUAGE ViewPatterns #-}
2 {-# LANGUAGE UndecidableInstances #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 -- | Symantic for 'Amount'.
5 module Hcompta.LCC.Sym.Amount where
6
7 import Data.Bool (Bool(..), not)
8 import Data.Eq (Eq(..))
9 import Data.Function (($))
10 import Data.Maybe (Maybe(..))
11 import Data.Semigroup (Semigroup(..))
12 import Text.Show (Show(..))
13 import qualified Data.Char as Char
14 import qualified Data.Map.Strict as Map
15 import qualified Data.Strict as S
16 import qualified Data.Text as Text
17 import qualified Language.Symantic.Typing as Sym
18
19 import Language.Symantic
20 import Language.Symantic.Lib ()
21
22 import Hcompta (Addable, Negable, Subable)
23 import Hcompta.LCC.Amount as LCC
24 import Hcompta.LCC.Sym.Quantity
25 import Hcompta.LCC.Sym.Unit
26 import Hcompta.LCC.Sym.Negable
27 import Hcompta.LCC.Write as Write
28 import qualified Language.Symantic.Document.Term as Doc
29 import qualified Language.Symantic.Document.Term.IO as DocIO
30
31 -- * Class 'Sym_Amounts'
32 type instance Sym Amounts = Sym_Amounts
33 class (Sym_Unit term, Sym_Negable term) => Sym_Amounts term where
34 amounts :: term Unit -> term Quantity -> term Amounts
35 default amounts :: Sym_Amounts (UnT term) => Trans term => term Unit -> term Quantity -> term Amounts
36 amounts = trans2 amounts
37
38 instance Sym_Amounts Eval where
39 amounts = eval2 (\u q -> Amounts $ Map.singleton u q)
40 instance Sym_Amounts View where
41 amounts (View u) (View q) = View $ \p v ->
42 q p v <> u p v
43 {-
44 TL.toStrict $
45 W.displayT $
46 W.renderCompact False $
47 LCC.write_amount (amount_style, amounts u q)
48 -}
49 instance (Sym_Amounts r1, Sym_Amounts r2) => Sym_Amounts (Dup r1 r2) where
50 amounts = dup2 @Sym_Amounts amounts
51 instance (Sym_Amounts term, Sym_Lambda term) => Sym_Amounts (BetaT term)
52
53 instance NameTyOf Amounts where
54 nameTyOf _c = ["Amount"] `Mod` "Amounts"
55 instance ClassInstancesFor Amounts where
56 proveConstraintFor _ (w:@(f:@cw:@d):@a)
57 | Just HRefl <- proj_ConstKiTy @(K Amounts) @Amounts a
58 = case () of
59 _ | Just HRefl <- proj_ConstKiTy @(K Writeable) @Writeable w
60 , Just HRefl <- proj_ConstKiTy @(K (->)) @(->) f
61 , Just HRefl <- proj_ConstKiTy @(K Write.Reader) @Write.Reader cw
62 -> case () of
63 _ | Just HRefl <- proj_ConstKiTy @(K DocIO.TermIO) @DocIO.TermIO d -> Just Dict
64 | Just HRefl <- proj_ConstKiTy @(K Doc.Term) @Doc.Term d -> Just Dict
65 _ -> Nothing
66 _ -> Nothing
67 proveConstraintFor _ (TyConst _ _ q :$ c)
68 | Just HRefl <- proj_ConstKiTy @(K Amounts) @Amounts c
69 = case () of
70 _ | Just Refl <- proj_Const @Addable q -> Just Dict
71 | Just Refl <- proj_Const @Eq q -> Just Dict
72 | Just Refl <- proj_Const @Negable q -> Just Dict
73 | Just Refl <- proj_Const @Show q -> Just Dict
74 | Just Refl <- proj_Const @Subable q -> Just Dict
75 _ -> Nothing
76 proveConstraintFor _c _q = Nothing
77 instance TypeInstancesFor Amounts
78
79 instance Gram_Term_AtomsFor meta ss g Amounts
80 instance (Source src, SymInj ss Amounts, SymInj ss Unit) => ModuleFor src ss Amounts where
81 moduleFor = ["Amount"] `moduleWhere`
82 [ NameTe n `WithFixity` Fixity1 (mkFixy side 10) := mkAmount nega u
83 | (u, style_amount_unit_side -> S.Just side) <-
84 Map.toList $
85 LCC.unStyle_Amounts LCC.style_amounts
86 , let Unit tu = u
87 , not (Text.null tu)
88 , (n, nega) <-
89 if isOp tu
90 then [(tu, False)]
91 else case side of
92 LCC.L -> [("-"<>tu, True), (tu, False), (tu<>"-", True)]
93 LCC.R -> [(tu, False)]
94 ]
95 where
96 isOp = Text.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
97 mkFixy LCC.L = Prefix
98 mkFixy LCC.R = Postfix
99 mkAmount :: Source src => SymInj ss Amounts => Bool -> Unit -> Term src ss ts '[] (() #> (Quantity -> Amounts))
100 mkAmount True u = Term noConstraint (tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam1 $ \q -> amounts (unit u) (neg q)
101 mkAmount False u = Term noConstraint (tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam1 $ \q -> amounts (unit u) q
102
103 tyAmounts :: Source src => LenInj vs => Type src vs Amounts
104 tyAmounts = tyConst @(K Amounts) @Amounts
105
106 teAmount :: TermDef Amounts '[] (() #> (Unit -> Quantity -> Amounts))
107 teAmount = Term noConstraint (tyUnit ~> tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam2 amounts