1 --{-# LANGUAGE ApplicativeDo #-}
2 {-# LANGUAGE AllowAmbiguousTypes #-}
3 {-# LANGUAGE BlockArguments #-}
4 {-# LANGUAGE ConstraintKinds #-}
5 {-# LANGUAGE DataKinds #-}
6 {-# LANGUAGE DefaultSignatures #-}
7 {-# LANGUAGE FlexibleContexts #-}
9 {-# LANGUAGE KindSignatures #-}
10 {-# LANGUAGE LambdaCase #-}
11 {-# LANGUAGE MultiParamTypeClasses #-}
12 {-# LANGUAGE NoImplicitPrelude #-}
13 {-# LANGUAGE OverloadedLabels #-}
14 {-# LANGUAGE OverloadedLists #-}
15 {-# LANGUAGE OverloadedStrings #-}
16 {-# LANGUAGE PatternSynonyms #-}
17 {-# LANGUAGE PolyKinds #-}
18 {-# LANGUAGE PostfixOperators #-}
19 {-# LANGUAGE RebindableSyntax #-}
20 {-# LANGUAGE StandaloneDeriving #-}
21 {-# LANGUAGE TupleSections #-}
22 {-# LANGUAGE TypeFamilies #-}
23 {-# LANGUAGE UndecidableInstances #-}
24 {-# LANGUAGE UnicodeSyntax #-}
25 {-# LANGUAGE ViewPatterns #-}
26 {-# OPTIONS_GHC -Wno-missing-signatures #-}
27 {-# OPTIONS_GHC -Wno-unused-do-bind #-}
28 {-# OPTIONS_GHC -Wno-orphans #-}
29 {-# OPTIONS_GHC -Wno-unused-imports #-}
30 module Symantic.Compta.Lang
31 ( module Symantic.Compta.Lang
32 , module Symantic.Compta.Lang.Math
33 , module Symantic.Compta.Lang.Rebindable
35 import Control.Applicative (Applicative(..))
36 import Control.DeepSeq (NFData(..))
37 import Control.Monad (Monad(..))
38 import Data.Decimal (Decimal)
40 import Data.Function (($), (.), id)
41 import Data.Functor (Functor, (<$>))
44 import Data.List.NonEmpty (NonEmpty)
45 import Data.Map.Strict (Map)
46 import Data.Maybe (Maybe)
48 import Data.Semigroup (Semigroup(..))
49 import Data.Monoid (Monoid)
50 import Data.String (String)
51 import Data.Typeable (Typeable)
52 import GHC.Generics (Generic)
53 import GHC.Stack (HasCallStack)
54 import GHC.TypeLits (Symbol, ErrorMessage(..))
55 import Numeric.Natural (Natural)
56 import Prelude (Integer, Enum(..))
57 import Text.Show (Show(..))
58 import Type.Reflection
59 import qualified Data.Char as Char
60 import qualified Data.List as List
61 import qualified Data.Maybe as Maybe
62 import qualified Data.String as String
63 import qualified Data.Time.Calendar as Time
64 import qualified GHC.Exts as GHC
65 import qualified Prelude
67 import Symantic.Compta.Lang.Math
68 import Symantic.Compta.Lang.Rebindable
69 import Symantic.Compta.Utils.Error
73 data TyAmount = TyAmount
74 data TyAccount = TyAccount
76 data TyPost = TyPost deriving (Show)
77 data TyPosts = TyPosts deriving (Show)
78 data TyMove = TyMove deriving (Show)
79 data TyMoves = TyMoves deriving (Show, Semigroup, Monoid)
80 type family Tr (repr::Type -> Type) (ty::Type) :: Type
83 type Repr = Type -> Type
85 --type ErrorNumAmount (unit::Symbol) = 'Text "err unit:" ':$$: 'ShowType unit
86 --instance TypeError (ErrorNumAmount unit) => Num (AmountOf unit repr)
88 -- | Usual syntax for type-preserving term-abstraction.
89 class Abstractable repr where
90 -- | Lambda term (abstract).
91 lam :: (repr a -> repr b) -> repr (a -> b)
92 -- | Term application (unabstract).
93 (.@) :: repr (a -> b) -> repr a -> repr b; infixl 9 .@
95 type DataRepr = Type -> Type
96 data family Data (able :: DataRepr -> Constraint) :: DataRepr -> DataRepr
97 data SomeData repr a = forall able. (Unliftable (Data able) repr, Typeable able) => SomeData (Data able repr a)
98 -- | @(unSomeData c :: 'Maybe' ('Data' able repr a))@
99 -- extract the data-constructor from the given 'SomeData'
100 -- iif. it belongs to the @('Data' able repr a)@ data-instance.
104 SomeData repr a -> Maybe (Data able repr a)
105 unSomeData (SomeData (c::Data c repr a)) =
106 case typeRep @able `eqTypeRep` typeRep @c of
107 Maybe.Just HRefl -> Maybe.Just c
108 Maybe.Nothing -> Maybe.Nothing
109 -- | Convenient utility to pattern-match a 'SomeData'.
110 pattern Data :: Typeable able => Data able repr a -> SomeData repr a
111 pattern Data x <- (unSomeData -> Maybe.Just x)
113 class Unliftable r repr where
114 unlift :: r repr a -> repr a
115 class Liftable r repr where
116 lift :: repr a -> r repr a
117 class Trans from to where
118 trans :: from a -> to a
120 type family Ty (repr::Type -> Type) (a::Type) :: Type
122 class Accountable repr where
123 account :: Ty repr TyAccount -> repr TyAccount
124 class Amountable repr where
125 amount :: Ty repr TyAmount -> repr TyAmount
127 class Inject a repr ty where
128 inject :: a -> repr ty
131 type family AccountOf (t::k) :: Type
132 type family AccountSectionOf (t::k) :: Type
133 type family AmountOf (t::k) :: Type
134 type family QuantityOf (t::k) :: Type
135 type family UnitOf (t::k) :: Type
136 type family PostOf (t::k) :: Type
137 type family MoveOf (t::k) :: Type
138 type family TransactionsOf (t::k) :: Type
139 type family ChartSectionOf (t::k) :: Type
140 type family ChartOf (t::k) :: Type
141 type instance UnitOf (Maybe amt) = UnitOf amt
142 type instance QuantityOf (Maybe amt) = QuantityOf amt
143 type instance UnitOf (Map unit qty) = unit
144 type instance QuantityOf (Map unit qty) = qty
147 type family AccountOf (repr::Repr) :: Type
148 type family AccountSectionOf (repr::Repr) :: Type
149 type family AmountOf (repr::Repr) :: Type
150 type family QuantityOf (repr::Repr) :: Type
151 type family UnitOf (repr::Repr) :: Type
152 type family PostOf (repr::Repr) :: Type
153 type family MoveOf (repr::Repr) :: Type
154 type family TransactionsOf (repr::Repr) :: Type
155 type family ChartSectionOf (repr::Repr) :: Type
156 type family ChartOf (repr::Repr) :: Type
158 -- * Class 'Accountable'
159 class Accountable repr where
160 account :: AccountOf repr -> repr (AccountOf repr)
161 class Amountable repr where
162 amount :: AmountOf repr -> repr (AmountOf repr)
164 --account :: acct -> repr a -> repr a
165 --accountFromStrings :: [String] -> repr (AccountOf repr)
166 --accountFromNatural :: Natural -> repr (AccountOf repr)
167 --class Literable repr where
168 -- lit :: a -> repr a
170 -- * Class 'Postable'
171 class Postable repr where
172 post :: HasCallStack => repr TyAccount -> repr TyAmount -> repr TyPost
176 Postable repr => Negable (repr TyAmount) =>
177 repr TyAccount -> repr TyAmount -> repr TyPost
179 HasCallStack => Postable repr =>
180 repr TyAccount -> repr TyAmount -> repr TyPost
181 (-=) acct = post acct . negate
186 -- * Class 'Moveable'
187 class Moveable repr where
188 move :: HasCallStack => repr [TyPost] -> repr TyMove
191 class Postingable repr where
192 (+=) :: repr (AccountOf repr) -> repr (AmountOf repr) -> repr (PostingsOf repr); infix 5 +=
193 (-=) :: repr (AccountOf repr) -> repr (AmountOf repr) -> repr (PostingsOf repr); infix 5 -=
196 -- * Class 'Transactionable'
198 class Transactionable repr where
199 txn :: String -> repr (PostingsOf repr) -> repr (TransactionsOf repr)
204 data Month = January | February | March | April | May | June | July | September | October | November | December
205 deriving (Enum, Show)
207 class Datable a repr where
208 year :: Year -> repr a -> repr a
209 month :: Month -> repr a -> repr a
210 day :: Int -> repr a -> repr a
211 date :: Year -> Month -> Int -> repr a -> repr a
213 -- * Class 'Chartable'
214 class Chartable chart section repr where
215 section :: HasCallStack => section -> repr chart -> repr chart
216 class ChartableLeaf chart repr where
217 anySection :: HasCallStack => repr chart
219 -- * Class 'Descriptionable'
220 class Descriptionable repr where
221 description :: HasCallStack => String -> repr ()
224 class Namable repr where
225 name :: HasCallStack => String -> repr ()
228 -- * Class 'Journalable'
236 , Datable (PostingsOf repr) repr
237 , Datable (TransactionsOf repr) repr
238 , FromInteger (repr (AccountOf repr))
239 , IsString (repr (AccountOf repr))
241 , Transactionable repr
242 ) => Journalable repr
250 , Datable (PostingsOf repr) repr
251 , Datable (TransactionsOf repr) repr
252 , FromInteger (repr (AccountOf repr))
253 , IsString (repr (AccountOf repr))
255 , Transactionable repr
256 ) => Journalable repr
259 t0 :: Journalable repr => repr (TransactionsOf repr)
265 accountFromStrings ["A"] -= eur 10
266 accountFromStrings ["B"] += usd 5
267 accountFromStrings ["C"] += (5€)
272 accountFromNatural 511 -= eur 10
275 "Capital/Tiers" -= eur 10
276 --["Capital","Tiers"] -= eur 10