1 {-# OPTIONS_GHC -Wno-missing-signatures #-}
2 {-# OPTIONS_GHC -Wno-unused-do-bind #-}
3 {-# OPTIONS_GHC -Wno-orphans #-}
4 {-# OPTIONS_GHC -Wno-unused-imports #-}
5 {-# OPTIONS_GHC -Wno-name-shadowing #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 --{-# LANGUAGE QualifiedDo #-}
8 module Symantic.Compta.Norm.PCG.Journal where
10 import Control.Applicative (Applicative(..), liftA2)
11 import Control.DeepSeq (NFData)
12 import Control.Monad (Monad(..), forM)
14 import Data.Decimal (Decimal)
15 import Data.Either (Either(..))
16 import Data.Eq (Eq(..))
17 import Data.Function (($), (.), id)
18 import Data.Functor (Functor, (<$>), (<$))
19 import Data.Hashable (Hashable)
20 import Data.Kind (Type)
21 import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
22 import Data.Map.Strict (Map)
23 import Data.Maybe (Maybe(..), maybeToList)
24 import Data.Monoid (Monoid(..), Endo(..))
25 import Data.Ord (Ord(..))
26 import Data.Semigroup (Semigroup(..))
27 import Data.String (String)
28 import Data.Tuple (uncurry)
29 import GHC.Generics (Generic)
30 import GHC.Stack (HasCallStack)
31 import GHC.TypeLits (Symbol)
32 import Numeric.Natural (Natural)
33 import Prelude (error)
34 import Text.Show (Show(..), showString)
35 import qualified Control.Monad as Monad (Monad(..), forM)
36 import qualified Control.Monad.Trans.Class as MT
37 import qualified Control.Monad.Trans.Reader as MT
38 import qualified Control.Monad.Trans.State as MT
39 import qualified Control.Monad.Trans.Writer as MT
40 import qualified Data.Char as Char
41 import qualified Data.Foldable as Foldable
42 import qualified Data.HashMap.Strict as HashMap
43 import qualified Data.List as List
44 import qualified Data.List.NonEmpty as NonEmpty
45 import qualified Data.Map.Strict as Map
46 import qualified Data.Tree as Tree
47 import qualified Prelude
49 import Symantic.Compta.Input.Journal
50 import Symantic.Compta.Calc.Balance
51 import Symantic.Compta.Calc.Flow
52 import Symantic.Compta.Calc.Unit
53 import Symantic.Compta.Lang
54 import Symantic.Compta.Norm.PCG.Chart
55 import Symantic.Compta.Utils.Error
56 import qualified Symantic.Compta.Calc.Chart as Chart
58 -- * Type 'JournalPCG'
59 newtype JournalPCG repr a = JournalPCG { unJournalPCG ::
60 MT.Reader (JournalEnv repr) (repr {-Ty (JournalPCG repr)-} a)
61 } deriving anyclass (Functor, Applicative, Monad)
62 type instance Ty (JournalPCG repr) TyAccountSection = Ty repr TyAccountSection
63 type instance Ty (JournalPCG repr) TyAccount = Ty repr TyAccount
64 type instance Ty (JournalPCG repr) TyAmount = Ty repr TyAmount
65 type instance Ty (JournalPCG repr) TyUnit = Ty repr TyUnit
66 type instance Ty (JournalPCG repr) TyQuantity = Ty repr TyQuantity
68 --instance Trans (JournalPCG repr) repr where
69 --trans (JournalPCG m) = _e m
72 IsString (Ty repr TyUnit) =>
73 Chart -> JournalRepr (JournalPCG repr) TyMove -> repr [TyMove]
74 journal ch jnl = MT.runReader (unJournalPCG (runJournalRepr jnl)) (journalEnv ch)
76 -- ** Type 'JournalEnv'
77 data JournalEnv (repr::Type -> Type) = JournalEnv
78 { journalChart :: Chart
79 --, accountByCode :: HashMap.HashMap AccountCode ChartNode
80 --, accountByName :: HashMap.HashMap AccountPath (AccountCode, ChartNode)
81 , defaultUnit :: Ty repr TyUnit
84 IsString (Ty repr TyUnit) =>
85 Chart -> JournalEnv repr
86 journalEnv ch = JournalEnv
88 --, accountByCode = HashMap.fromList byCode
89 --, accountByName = HashMap.fromList byName
90 , defaultUnit = fromString ""
93 -- (byCode{-, byName-}) = goChart (AccountCode 0{-, []-}) ch
94 -- goChart p = Map.foldMapWithKey (goNode p) . Chart.unChart
95 -- goNode (AccountCode kc{-, kn-}) n (node, children) =
96 -- let keyCode = AccountCode (kc Prelude.* 10 Prelude.^ digitNumber n Prelude.+ n) in
97 -- --let keyName = kn <> maybeToList (sectionName node) in
98 -- let (bc{-, bn-}) = goChart (keyCode{-, keyName-}) children in
99 -- ( (keyCode, ({-nonEmpty keyName,-} node)) : bc
101 -- , case nonEmpty keyName of
102 -- Just k -> (k, (keyCode, node)) : bn
107 -- | @('digitNumber' n)@ retourne le nombre de digits nécessaires pour encoder 'n'.
108 digitNumber :: Natural -> Natural
109 digitNumber = go where
111 | otherwise = 1 Prelude.+ go (n`Prelude.div`10)
116 ) => IsString (JournalPCG repr TyAccount) where
117 fromString = error ""
121 , Zeroable (repr TyAmount)
122 ) => IsString (JournalPCG repr TyPost) where
123 fromString s = JournalPCG do
124 acct <- unJournalPCG $ fromString s
125 return $ post acct zero
129 , Zeroable (repr TyAmount)
130 , Inject (Chart.ChartPath AccountCode) repr TyAccount
131 --, FromInteger (JournalPCG repr TyPost)
132 ) => FromInteger (JournalPCG repr TyPost) where
133 fromInteger i = JournalPCG do
134 acct <- unJournalPCG $ fromInteger i
135 return $ post acct zero
137 Zeroable (repr TyAmount) =>
138 Zeroable (JournalPCG repr TyAmount) where
139 zero = JournalPCG (return zero)
140 instance Addable a => Addable (JournalPCG repr a) where
141 x + y = (+) <$> x <*> y
142 instance Listable repr => Listable (JournalPCG repr) where
143 nil = JournalPCG (return nil)
144 cons (JournalPCG x) (JournalPCG xs) = JournalPCG (liftA2 cons x xs)
145 concat (JournalPCG xs) (JournalPCG ys) = JournalPCG (concat <$> xs <*> ys)
146 instance Postable repr => Postable (JournalPCG repr) where
147 post (JournalPCG acct) (JournalPCG amt) = JournalPCG do
148 post <$> acct <*> amt
150 ( Addable (Ty repr TyQuantity)
152 , Negable (Ty repr TyQuantity)
153 , Nullable (Ty repr TyQuantity)
154 , Ord (Ty repr TyAccountSection)
155 , Ord (Ty repr TyUnit)
157 , Show (Ty repr TyAccountSection)
158 , Show (Ty repr TyQuantity)
159 , Show (Ty repr TyUnit)
160 , Trans repr (BalanceRepr Maybe repr)
161 , Trans repr (InferPost repr)
162 ) => Moveable (JournalPCG repr) where
163 move (JournalPCG ps) = JournalPCG $ go <$> ps
166 case equilibrium ps of
167 Right eps -> move eps
168 Left errs -> error ("equilibrium: "<>show errs)
169 instance Accountable repr => Accountable (JournalPCG repr) where
170 account = JournalPCG . return . account
171 instance Amountable repr => Amountable (JournalPCG repr) where
172 amount = JournalPCG . return . amount
173 instance Negable (repr qty) => Negable (JournalPCG repr qty) where
174 negate = JournalPCG . (negate <$>) . unJournalPCG
179 ) => Postable acct amt (JournalPCG repr) where
180 post acct amt = JournalPCG $ MT.ReaderT $ \_env -> post acct amt
182 ( Postable acct (Map unit qty) repr
183 , FromInteger (JournalPCG acct (Map unit qty) repr acct)
185 ) => FromInteger (JournalPCG acct (Map unit qty) repr [TyPost]) where
186 fromInteger i = cons (fromInteger i) nil
188 ( Postable acct (Map unit qty) repr
189 , IsString (JournalPCG acct (Map unit qty) repr acct)
191 ) => IsString (JournalPCG acct (Map unit qty) repr [TyPost]) where
193 acct :: acct <- fromString s
194 cons (post acct (Map.empty :: Map unit qty)) nil
200 ) => FromRational (JournalPCG repr qty) where
201 fromRational i = JournalPCG $ MT.ReaderT $ \_env ->
203 instance FromInteger (JournalPCG repr AccountCode) where
204 fromInteger i = JournalPCG do
206 let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
207 case HashMap.lookup ac (accountByCode env) of
209 _ -> error ("Chart does not allow AccountCode: "<>show ac<>" "<>show (accountByCode env))
214 IsString (JournalPCG repr (Chart.ChartPath AccountSegment)) where
215 fromString s = JournalM $ do
216 env <- MT.lift MT.ask
217 case nonEmpty (fromString s) of
218 Just acct | HashMap.member acct (accountByName env) -> return acct
219 Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
220 Nothing -> error "Invalid empty AccountPath"
223 FromInteger (JournalPCG repr (Chart.ChartPath AccountSegment)) where
224 fromInteger i = JournalM $ do
225 env <- MT.lift MT.ask
226 let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
227 case HashMap.lookup ac (accountByCode env) of
228 Just (Just acct, _) -> return acct
229 _ -> error ("Chart does not allow AccountCode: "<>show ac)
233 --, Ty repr TyAccount ~ Chart.ChartPath Natural --AccountCodeSegment
234 , Inject (Chart.ChartPath AccountCode) repr TyAccount
235 ) => FromInteger (JournalPCG repr TyAccount) where
236 fromInteger i = JournalPCG $ do
238 let code = if 0 <= i then fromInteger i else error ("Invalid AccountCode: "<>show code)
239 let path = {-chartSection <$>-} NonEmpty.fromList (AccountCode <$> digitsOfNatural code)
240 case Chart.lookup path (journalChart env) of
241 Just{} -> return $ inject path
242 _ -> error ("Chart does not allow AccountCode: "<>show code)
243 --instance FromInteger qty => FromInteger (JournalPCG repr qty) where
244 -- fromInteger = JournalPCG . return . fromInteger
245 --type instance QuantityOf (Map unit qty) = qty
248 , Inject (Map (Ty repr TyUnit) (Ty repr TyQuantity)) repr TyAmount
249 , FromInteger (Ty repr TyQuantity)
250 ) => FromInteger (JournalPCG repr TyAmount) where
251 fromInteger i = JournalPCG $ do
253 --qty <- unJournalM (fromInteger i :: JournalPCG acct (Map unit qty) repr qty)
254 --q <- unJournalPCG $ fromInteger i
255 return $ inject $ Map.singleton (defaultUnit env) (fromInteger i::Ty repr TyQuantity)
256 instance Unitable (JournalPCG repr) where
257 unit u = JournalPCG . MT.local (\env -> env{defaultUnit=u}) . unJournalPCG
258 instance EURable repr => EURable (JournalPCG repr) where
259 eur qty = JournalPCG $ eur <$> unJournalPCG qty
260 instance USDable repr => USDable (JournalPCG repr) where
261 usd qty = JournalPCG $ usd <$> unJournalPCG qty
265 IsString (JournalPCG repr AccountCode) where
266 fromString s = JournalM $ do
267 env <- MT.lift MT.ask
268 case nonEmpty (fromString s) of
269 Just acct | Just (ac, _) <- HashMap.lookup acct (accountByName env) -> return ac
270 Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
271 Nothing -> error "Invalid empty AccountPath"
275 balance :: forall repr a.
276 Balanceable a ~ 'True =>
277 Addable (Ty repr TyQuantity) =>
278 Ord (Ty repr TyAccountSection) =>
279 Ord (Ty repr TyUnit) =>
280 Trans repr (BalanceRepr Maybe repr) =>
282 Balance (Ty repr TyAccountSection)
285 (Trickle (Ty (BalanceRepr Trickle repr) TyAmount))
287 runBalanceRepr @Trickle .
289 trans @_ @(BalanceRepr Maybe repr)
292 instance Listable repr => Listable (JournalPCG repr) where
293 nil = Monad.return []
298 --type instance AccountSectionOf (Chart.ChartPath section) = section
299 --type instance UnitOf (Map unit qty) = unit
300 --type instance AmountOf () = Map Unit Q
301 --type instance AccountOf () = NonEmpty AccountCode
303 --type Account = AccountCode
304 --type AccountCodeSegment = AccountCode
305 --type AccountPath = Chart.ChartPath AccountSegment
306 --type Amount = Map Unit Q
307 --type Q = (Flow Decimal)