1 {-# LANGUAGE PartialTypeSignatures #-}
2 {-# LANGUAGE NoOverloadedLists #-}
3 {-# LANGUAGE DataKinds #-}
4 --{-# LANGUAGE ConstraintKinds #-}
5 {-# LANGUAGE UndecidableInstances #-}
6 module Haccounting.Balance where
8 import Control.DeepSeq (NFData)
9 import Data.Kind (Type)
11 import Data.Coerce (coerce)
12 import Data.Either (Either(..), rights, lefts)
13 import Data.Eq (Eq(..))
14 import Data.Function (($), (.), id, const)
15 import Data.Functor ((<$), (<$>))
16 import Data.Map.Strict (Map)
17 import Data.Maybe (Maybe(..), maybe, isJust, fromMaybe, catMaybes)
18 import Data.Monoid (Monoid(..))
19 import Data.Ord (Ord(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.String (String)
22 import Data.Typeable ()
23 import GHC.Generics (Generic)
24 import Text.Show (Show(..))
25 import qualified Data.List as List
26 import qualified Data.List.NonEmpty as NonEmpty
27 import qualified Data.Map.Strict as Map
29 import Symantic.Compta.Lang
30 import Symantic.Compta.Calc.Flow
31 import qualified Symantic.Compta.Calc.Chart as Chart
33 -- * Type 'BalanceRepr'
34 data Balance section unit qty amt = Balance
35 { balanceByAccount :: !(Chart.Chart section amt)
36 , balanceByUnit :: !(Map unit (SumForUnit (Chart.ChartPath section) qty))
37 } deriving (Eq, Show, Generic, NFData)
39 -- | 'BalanceReprByAccount' and 'BalanceReprByUnit' of some 'TyPost'.
40 data BalanceRepr f (repr::Type->Type) a where
42 Balanceable a ~ 'False =>
43 Ty (BalanceRepr f repr) a -> BalanceRepr f repr a
45 Balanceable a ~ 'True =>
46 { unBal :: Balance (Ty repr TyAccountSection)
49 (f (Ty (BalanceRepr f repr) TyAmount))
50 } -> BalanceRepr f repr a
51 --type instance Tr (BalanceRepr f repr) TyAmount = Map (Tr repr TyUnit) (Tr repr TyQuantity)
52 --type instance Tr (BalanceRepr f repr) TyAccount = Chart.ChartPath (Tr repr TyAccountSection)
54 ( unit ~ Ty repr TyUnit
55 , qty ~ Ty repr TyQuantity
56 ) => Inject (Map unit qty) (BalanceRepr f repr) TyAmount where
57 inject = BalanceReprAny
59 ( section ~ Ty repr TyAccountSection
60 ) => Inject (Chart.ChartPath section) (BalanceRepr f repr) TyAccount where
61 inject = BalanceReprAny
63 runBalanceRepr :: forall f repr a.
64 Balanceable a ~ 'True =>
65 BalanceRepr f repr a ->
66 Balance (Ty repr TyAccountSection)
69 (f (Ty (BalanceRepr f repr) TyAmount))
70 runBalanceRepr = unBal
72 type instance Ty (BalanceRepr f repr) TyAmount = Map (Ty repr TyUnit) (Ty repr TyQuantity)
73 type instance Ty (BalanceRepr f repr) TyAccount = Chart.ChartPath (Ty repr TyAccountSection)
74 type instance Ty (BalanceRepr f repr) TyAccountSection = Ty repr TyAccountSection
76 instance Amountable (BalanceRepr f repr) where
77 amount = BalanceReprAny
78 instance Accountable (BalanceRepr f repr) where
79 account = BalanceReprAny
81 type family Balanceable a :: Bool
82 type instance Balanceable TyQuantity = 'False
83 type instance Balanceable TyAccount = 'False
84 type instance Balanceable TyAmount = 'False
85 type instance Balanceable (Map k a) = 'False -- Balanceable a
86 type instance Balanceable TyMove = 'True
87 type instance Balanceable TyPost = 'True
88 type instance Balanceable [a] = 'True -- Balanceable a
93 , Eq (Ty repr TyQuantity)
94 , Eq (Ty repr TyAccountSection)
95 , Eq (f (AmountOf (BalanceRepr f repr)))
96 ) => Eq (BalanceRepr f repr a)
98 ( Show (Ty repr TyUnit)
99 , Show (Ty repr TyQuantity)
100 , Show (Ty repr TyAccountSection)
101 , Show (f (AmountOf (BalanceRepr f repr)))
102 ) => Show (BalanceRepr f repr a)
103 --deriving instance (NFData (Ty repr TyUnit), NFData (Ty repr TyQuantity)) => NFData (BalanceRepr section repr a)
106 instance Zeroable (Balance acct unit aty amt) where
107 zero = Balance (Chart.Chart Map.empty) Map.empty
108 instance (Addable amt, Addable qty, Ord acct, Ord unit) => Addable (Balance acct unit qty amt) where
109 Balance xa xu + Balance ya yu = Balance (xa + ya) (xu + yu)
111 ( Addable (Ty repr TyQuantity)
112 , Addable (f (Map (Ty repr TyUnit) (Ty repr TyQuantity)))
113 , Ord (Ty repr TyAccountSection)
114 , Ord (Ty repr TyUnit)
115 ) => Listable (BalanceRepr f repr) where
116 nil = BalanceRepr zero
117 cons (BalanceRepr x) (BalanceRepr y) = BalanceRepr (x + y)
118 concat (BalanceRepr x) (BalanceRepr y) = BalanceRepr (x + y)
120 ( Ord (Ty repr TyUnit)
121 , Ord (Ty repr TyAccountSection)
122 , Addable (Ty repr TyQuantity)
123 , Addable (f (Ty (BalanceRepr f repr) TyAmount))
124 ) => Addable (BalanceRepr f repr TyPost) where
125 BalanceRepr (Balance xa xu) + BalanceRepr (Balance ya yu) =
126 BalanceRepr (Balance (xa + ya) (xu + yu))
128 ( Ord (Ty repr TyUnit)
129 , Addable (Ty repr TyQuantity)
130 ) => Addable (BalanceRepr f repr [a]) where
132 instance Balanceable a ~ 'True => Zeroable (BalanceRepr f repr a) where
133 zero = BalanceRepr zero
135 ( Ord (Ty repr TyAccountSection)
136 ) => Postable (BalanceRepr Maybe repr) where
137 post (BalanceReprAny acct) (BalanceReprAny amt) = BalanceRepr Balance
138 { balanceByAccount = Chart.singleton Nothing acct (Just amt)
139 , balanceByUnit = Map.map (\qty -> SumForUnit
140 { sumForUnitQuantity = qty
141 , sumForUnitAccounts = Map.singleton acct ()
144 instance Moveable (BalanceRepr f repr) where
145 move (BalanceRepr bal) = BalanceRepr bal
149 instance Nullable qty => Nullable (BalanceRepr section unit qty) where
150 null (BalanceRepr a u) = TM.null a && null u
151 instance (Ord section, Ord unit, Addable qty) =>
152 Sumable (BalanceRepr section unit qty)
153 (TM.Path section, SumByAccount unit qty) where
154 BalanceRepr a u += x = BalanceRepr (a += x) (u += x)
163 Balance section unit qty (Trickle (Map unit (Flow qty))) ->
165 tableBalanceRepr Balance{..} =
167 (\acct Trickle{inclusive=amt} -> (
169 , List.intercalate "+" $ catMaybes $ (\(u,q) -> show . (u,) <$> flowIn q) <$> Map.toList amt
170 , List.intercalate "+" $ catMaybes $ (\(u,q) -> show . (u,) <$> flowOut q) <$> Map.toList amt
171 --, show (unFlow <$> amt)
177 -- * Type 'BalanceReprByAccount'
178 type BalanceReprByAccount f section unit qty =
179 Chart.Chart section (f (SumByAccount unit qty))
181 -- ** Type 'SumByAccount'
182 -- | A sum of quantities, concerning a single account.
183 type SumByAccount = Map
185 -- * Type 'BalanceReprByUnit'
186 type BalanceReprByUnit section unit qty =
187 Map unit (SumForUnit (Chart.ChartPath section) qty)
190 -- ** Type 'SumForUnit'
191 -- | A sum of quantities with their accounts involved,
192 -- concerning a single @unit@.
193 data SumForUnit acct qty
195 { sumForUnitQuantity :: !qty
196 -- ^ The sum of quantities for a single @unit@.
197 , sumForUnitAccounts :: !(Map acct ())
198 -- ^ The accounts either involved to build 'sumForUnitQuantity',
199 -- or *not* involved when inside a 'DeviationByUnit'.
200 } deriving (Eq, Ord, Show, Generic, NFData)
201 instance Zeroable qty => Zeroable (SumForUnit acct qty) where
202 zero = SumForUnit zero Map.empty
203 instance (Ord acct, Addable qty) => Addable (SumForUnit acct qty) where
205 (sumForUnitQuantity x + sumForUnitQuantity y)
206 (sumForUnitAccounts x + sumForUnitAccounts y)
207 instance (Ord acct, Negable qty) => Negable (SumForUnit acct qty) where
208 negate x = SumForUnit
209 { sumForUnitQuantity = negate (sumForUnitQuantity x)
210 , sumForUnitAccounts = negate (sumForUnitAccounts x)
212 instance (Ord acct, Subable qty) => Subable (SumForUnit acct qty) where
214 { sumForUnitQuantity = sumForUnitQuantity x - sumForUnitQuantity y
215 , sumForUnitAccounts = sumForUnitAccounts x - sumForUnitAccounts y
218 -- ** BalanceRepr 'equilibrium'
219 -- | Return the 'BalanceRepr' (adjusted by inferred quantities)
220 -- of the given @post@s and either:
222 -- * 'Left': the @unit@s which have a non null 'SumForUnit'
223 -- and for which no equibrating account can be inferred.
224 -- * 'Right': the given @post@s with inferred quantities inserted.
227 Ord (Ty repr TyUnit) =>
228 Ord (Ty repr TyAccountSection) =>
229 Nullable (Ty repr TyQuantity) =>
230 Addable (Ty repr TyQuantity) =>
231 Negable (Ty repr TyQuantity) =>
232 Show (Ty repr TyUnit) =>
233 Show (Ty repr TyQuantity) =>
234 Trans repr (BalanceRepr Maybe repr) =>
235 Trans repr (InferPost repr) =>
239 [(Ty repr TyUnit, SumForUnit (Chart.ChartPath (Ty repr TyAccountSection))
240 (Ty repr TyQuantity))]
243 let BalanceRepr Balance{..} = move (trans posts) :: BalanceRepr Maybe repr TyMove in
244 let balanceAccounts = Map.filter isJust $ Chart.flatten id balanceByAccount in
245 let eithers = Map.foldrWithKey
246 (\unt sfu@SumForUnit{..} ->
247 let unusedAccounts = balanceAccounts `Map.difference` sumForUnitAccounts in
248 case Map.size unusedAccounts of
249 0 | null sumForUnitQuantity -> id
251 -- The quantity can be inferred since having an equilibrated balance
252 -- means it must be the opposite of the quantity for that unit on other accounts.
253 (:) $ Right $ Map.singleton unt (negate sumForUnitQuantity)
254 <$ Map.elemAt 0 unusedAccounts
256 -- There is more than one account not specifying a quantity for that unit
257 -- hence those cannot be inferred.
258 (:) $ Left (unt, sfu)
259 ) [] balanceByUnit in
260 case lefts eithers of
261 [] -> Right $ (`unInferPost` Map.fromListWith (+) (rights eithers)) $ trans posts
264 -- *** Type 'InferPost'
265 data InferPost repr a where
266 InferPostAccount :: Ty (BalanceRepr Maybe repr) TyAccount -> InferPost repr TyAccount
267 InferPostAmount :: Ty (BalanceRepr Maybe repr) TyAmount -> InferPost repr TyAmount
269 Balanceable a ~ 'True =>
270 { unInferPost :: Map (Ty (BalanceRepr Maybe repr) TyAccount)
271 (Ty (BalanceRepr Maybe repr) TyAmount) -> repr a } ->
277 , Addable (Ty repr TyAmount)
278 , Ord (Ty repr TyAccountSection)
279 , Ty repr TyAccount ~ Chart.ChartPath (Ty repr TyAccountSection)
280 , Ty repr TyAmount ~ Map (Ty repr TyUnit) (Ty repr TyQuantity)
281 ) => Postable (InferPost repr) where
282 post (InferPostAccount acct) (InferPostAmount amt) = InferPost $ \env ->
283 post (account acct) $ amount $ maybe amt (amt +) $ Map.lookup acct env
284 instance Listable repr => Listable (InferPost repr) where
285 nil = InferPost (const nil)
286 cons x xs = InferPost $ \env ->
290 concat xs ys = InferPost $ \env ->
296 ) => Moveable (InferPost repr) where
297 move ps = InferPost $ \env ->
298 move (unInferPost ps env)
300 ( unit ~ Ty repr TyUnit
301 , qty ~ Ty repr TyQuantity
302 ) => Inject (Map unit qty) (InferPost repr) TyAmount where
303 inject = InferPostAmount
305 ( section ~ Ty repr TyAccountSection
306 ) => Inject (Chart.ChartPath section) (InferPost repr) TyAccount where
307 inject = InferPostAccount
310 -- | Return 'True' if and only if the given 'DeviationByUnit' maps no @unit@.
311 isEquilibrium :: DeviationByUnit section unit qty -> Bool
312 isEquilibrium (DeviationByUnit dev) = Map.null dev
314 -- | Return 'True' if and only if the given 'DeviationByUnit'
315 -- maps only to 'SumForUnit's whose 'sumForUnitAccounts'
316 -- maps exactly one account.
317 isEquilibriumInferrable :: DeviationByUnit section unit qty -> Bool
318 isEquilibriumInferrable (DeviationByUnit dev) =
319 Fold.all ((== 1) . Map.size . sumForUnitAccounts) dev
321 -- | {Ex,In}clusive 'BalanceReprByAccount':
322 -- descending propagation of quantities accross accounts.
326 -- A data type to calculate an 'inclusive' value
327 -- (through some propagation mecanism,
328 -- eg. incorporating the values of the children of a tree node),
329 -- while keeping the original 'exclusive' value
330 -- (eg. the original value of a tree node).
332 -- * 'exclusive': contains the original 'SumByAccount'.
333 -- * 'inclusive': contains ('+') folded
334 -- over 'exclusive' and 'inclusive' of children.
335 data Trickle amt = Trickle
338 } deriving (Eq, Show, Generic, NFData)
339 instance Semigroup a => Semigroup (Trickle a) where
340 Trickle e0 i0 <> Trickle e1 i1 =
341 Trickle (e0<>e1) (i0<>i1)
342 instance Monoid a => Monoid (Trickle a) where
343 mempty = Trickle mempty mempty
345 --type instance Ty (Trickle amt) TyUnit = Ty amt TyUnit
346 --type instance Ty (Trickle amt) TyQuantity = Ty amt TyQuantity
347 instance Addable amt => Addable (Trickle amt) where
349 { exclusive = exclusive x + exclusive y
350 , inclusive = inclusive x + inclusive y
353 -- | Return the given 'BalanceReprByAccount' with:
355 -- * all missing parent accounts inserted;
356 -- * and every mapped @qty@ added with any @qty@
357 -- of the account for which it is a parent.
358 trickleBalanceRepr ::
360 Balanceable a ~ 'True =>
361 Addable (Ty repr TyQuantity) =>
362 Ord (Ty repr TyAccountSection) =>
363 Ord (Ty repr TyUnit) =>
364 BalanceRepr Maybe repr a ->
365 BalanceRepr Trickle repr a
366 trickleBalanceRepr (BalanceRepr bal) = BalanceRepr Balance
367 { balanceByAccount = balByAccount
368 , balanceByUnit = balByUnit [] (balanceByUnit bal) balByAccount
373 let acct = NonEmpty.reverse (k NonEmpty.:| ks) in
374 acc + balanceByUnit (unBal (post (account acct) (amount (inclusive amt)) ::
375 BalanceRepr Maybe repr TyPost))
376 ) ini . Chart.unChart
378 Chart.mapByDepthFirst (\ch a ->
379 let exclusive = fromMaybe Map.empty a in
384 (\acc (sba, _ch) -> acc + inclusive sba)
388 ) (balanceByAccount bal)