]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Sym/Amount.hs
Remove old Yesod scaffolding.
[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(..))
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 qualified Hcompta as H
23 import Hcompta (Addable, Negable, Subable)
24 import Hcompta.LCC.Amount as LCC
25 import Hcompta.LCC.Sym.Quantity
26 import Hcompta.LCC.Sym.Unit
27 import Hcompta.LCC.Sym.Negable
28
29 -- * Class 'Sym_Amounts'
30 type instance Sym (Proxy Amounts) = Sym_Amounts
31 class (Sym_Unit term, Sym_Negable term) => Sym_Amounts term where
32 amounts :: term Unit -> term Quantity -> term Amounts
33 default amounts :: Sym_Amounts (UnT term) => Trans term => term Unit -> term Quantity -> term Amounts
34 amounts = trans2 amounts
35
36 instance Sym_Amounts Eval where
37 amounts = eval2 (\u q -> Amounts $ Map.singleton u q)
38 instance Sym_Amounts View where
39 amounts (View u) (View q) = View $ \p v ->
40 q p v <> u p v
41 {-
42 TL.toStrict $
43 W.displayT $
44 W.renderCompact False $
45 LCC.write_amount (amount_style, amounts u q)
46 -}
47 instance (Sym_Amounts r1, Sym_Amounts r2) => Sym_Amounts (Dup r1 r2) where
48 amounts = dup2 @Sym_Amounts amounts
49 instance (Sym_Amounts term, Sym_Lambda term) => Sym_Amounts (BetaT term)
50
51 instance ClassInstancesFor Amounts where
52 proveConstraintFor _ (TyApp _ (TyConst _ _ q) c)
53 | Just HRefl <- proj_ConstKiTy @(K Amounts) @Amounts c
54 = case () of
55 _ | Just Refl <- proj_Const @Addable q -> Just Dict
56 | Just Refl <- proj_Const @Eq q -> Just Dict
57 | Just Refl <- proj_Const @Negable q -> Just Dict
58 | Just Refl <- proj_Const @Show q -> Just Dict
59 | Just Refl <- proj_Const @Subable q -> Just Dict
60 _ -> Nothing
61 proveConstraintFor _c _q = Nothing
62 instance TypeInstancesFor Amounts
63
64 instance Gram_Term_AtomsFor meta ss g Amounts
65 instance (Source src, Inj_Sym ss Amounts, Inj_Sym ss Unit) => ModuleFor src ss Amounts where
66 moduleFor = ["Amount"] `moduleWhere`
67 [ NameTe n `WithFixity` Fixity1 (mkFixy side 10) := mkAmount nega u
68 | (u, style_amount_unit_side -> S.Just side) <-
69 Map.toList $
70 LCC.unStyle_Amounts LCC.style_amounts
71 , let tu = H.unit_text u
72 , (n, nega) <- if isOp tu
73 then [(tu, False)]
74 else case side of
75 LCC.L -> [("-"<>tu, True), (tu, False), (tu<>"-", True)]
76 LCC.R -> [(tu, False)]
77 ]
78 where
79 isOp = Text.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
80 mkFixy LCC.L = Prefix
81 mkFixy LCC.R = Postfix
82 mkAmount :: Source src => Inj_Sym ss Amounts => Bool -> Unit -> Term src ss ts '[] (() #> (Quantity -> Amounts))
83 mkAmount True u = Term noConstraint (tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam1 $ \q -> amounts (unit u) (neg q)
84 mkAmount False u = Term noConstraint (tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam1 $ \q -> amounts (unit u) q
85
86 tyAmounts :: Source src => Inj_Len vs => Type src vs Amounts
87 tyAmounts = tyConst @(K Amounts) @Amounts
88
89 teAmount :: TermDef Amounts '[] (() #> (Unit -> Quantity -> Amounts))
90 teAmount = Term noConstraint (tyUnit ~> tyQuantity ~> tyAmounts) $ teSym @Amounts $ lam2 amounts