]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Balance.hs
Refactor hcompta-lib.
[comptalang.git] / lib / Hcompta / Balance.hs
1 module Hcompta.Balance where
2
3 import Control.DeepSeq (NFData(..))
4 import Control.Exception (assert)
5 import Data.Bool
6 import Data.Data
7 import Data.Either (Either(..))
8 import Data.Eq (Eq(..))
9 import Data.Function (($), (.), const, flip)
10 import Data.Map.Strict (Map)
11 import Data.Ord (Ord(..))
12 import Data.TreeMap.Strict (TreeMap(..))
13 import Data.Tuple (fst)
14 import Data.Typeable ()
15 import Prelude (seq, undefined)
16 import Text.Show (Show(..))
17 import qualified Data.Foldable as Fold
18 import qualified Data.Map.Strict as Map
19 import qualified Data.MonoTraversable as MT
20 import qualified Data.Sequences as Seqs
21 import qualified Data.Strict.Maybe as Strict
22 import qualified Data.TreeMap.Strict as TM
23
24 import Hcompta.Data
25 import Hcompta.Quantity
26 import qualified Hcompta.Lib.Foldable as Fold
27 import qualified Hcompta.Lib.Strict as Strict
28
29 -- * Type 'Balance'
30
31 -- | 'BalByAccount' and 'BalByUnit' of some @post@s.
32 --
33 -- NOTE: to reduce memory consumption
34 -- when applying ('+=') incrementally,
35 -- the fields are explicitely stricts.
36 data Balance name unit qty
37 = Balance
38 { balByAccount :: !(BalByAccount name unit qty)
39 , balByUnit :: !(BalByUnit name unit qty)
40 } deriving (Data, Eq, Show, Typeable)
41
42 instance (NFData name, NFData unit, NFData qty, Ord name) => NFData (Balance name unit qty) where
43 rnf (Balance a u) = rnf a `seq` rnf u
44 instance Zeroable (Balance name unit qty) where
45 zero = Balance TM.empty Map.empty
46 instance Nullable qty => Nullable (Balance name unit qty) where
47 null (Balance a u) = TM.null a && null u
48 instance (Ord name, Ord unit, Addable qty) =>
49 Addable (Balance name unit qty) where
50 Balance xa xu + Balance ya yu = Balance (xa + ya) (xu + yu)
51 instance (Ord name, Ord unit, Addable qty) =>
52 Sumable (Balance name unit qty)
53 (TM.Path name, SumByAccount unit qty) where
54 Balance a u += x = Balance (a += x) (u += x)
55
56 -- * Type 'BalByAccount'
57 type BalByAccount name unit qty
58 = TreeMap name (SumByAccount unit qty)
59
60 -- ** Type 'SumByAccount'
61 -- | A sum of quantities, concerning a single account.
62 type SumByAccount = Map
63
64 -- * Type 'BalByUnit'
65 type BalByUnit name unit qty
66 = Map unit (SumByUnit (TM.Path name) qty)
67
68 -- ** Type 'SumByUnit'
69 -- | A sum of quantities with their accounts involved,
70 -- concerning a single @unit@.
71 data SumByUnit acct qty
72 = SumByUnit
73 { sumByUnit_quantity :: !qty
74 -- ^ The sum of quantities for a single @unit@.
75 , sumByUnit_accounts :: !(Map acct ())
76 -- ^ The accounts involved to build 'sumByUnit_quantity'.
77 } deriving (Data, Eq, Ord, Show, Typeable)
78 instance (NFData acct, NFData qty) => NFData (SumByUnit acct qty) where
79 rnf (SumByUnit q a) = rnf q `seq` rnf a
80 instance Zeroable qty => Zeroable (SumByUnit acct qty) where
81 zero = SumByUnit zero zero
82 instance Nullable qty => Nullable (SumByUnit acct qty) where
83 null (SumByUnit q a) = null q && Map.null a
84 instance (Ord acct, Addable qty) => Addable (SumByUnit acct qty) where
85 x + y = SumByUnit
86 (sumByUnit_quantity x + sumByUnit_quantity y)
87 (sumByUnit_accounts x + sumByUnit_accounts y)
88 instance (Ord name, Ord unit, Addable qty) =>
89 Sumable (BalByUnit name unit qty)
90 (TM.Path name, Map unit qty) where
91 bal += (acct, amts) =
92 (+) ((`Map.map` amts) $ \qty ->
93 SumByUnit
94 { sumByUnit_quantity = qty
95 , sumByUnit_accounts = Map.singleton acct ()
96 }) bal
97
98 -- * Type 'DeviationByUnit'
99 -- | The 'BalByUnit' whose 'sumByUnit_quantity'
100 -- is not zero and possible account to 'equilibrium'.
101 newtype DeviationByUnit name unit qty
102 = DeviationByUnit (BalByUnit name unit qty)
103 deriving (Data, Eq, NFData, Show, Typeable)
104
105 -- | Return the 'balByUnit' of the given 'Balance' with:
106 --
107 -- * @unit@s whose 'sumByUnit_quantity' verifying 'zero' are removed,
108 --
109 -- * and remaining @unit@s have their 'sumByUnit_accounts'
110 -- complemented with the 'balByAccount' of the given 'Balance'
111 -- (i.e. now mapping to the accounts __not__ involved to build the 'SumByUnit').
112 deviationByUnit ::
113 (Ord name, Ord unit, Addable qty, Nullable qty) =>
114 Balance name unit qty ->
115 DeviationByUnit name unit qty
116 deviationByUnit Balance{balByAccount, balByUnit} =
117 let all_accounts = TM.flatten (const ()) balByAccount in
118 let max_accounts = Map.size all_accounts in
119 DeviationByUnit $
120 Map.foldlWithKey
121 (\m unit SumByUnit{..} ->
122 if null sumByUnit_quantity
123 then m
124 else
125 case Map.size sumByUnit_accounts of
126 n | n == max_accounts ->
127 Map.insert unit SumByUnit
128 { sumByUnit_quantity
129 , sumByUnit_accounts = Map.empty
130 } m
131 _ ->
132 let diff = all_accounts `Map.difference` sumByUnit_accounts in
133 Map.insert unit SumByUnit
134 { sumByUnit_quantity
135 , sumByUnit_accounts = diff
136 } m
137 )
138 zero
139 balByUnit
140
141 -- ** Balance 'equilibrium'
142 -- | Return the 'Balance' (adjusted by inferred quantities)
143 -- of the given @post@s and either:
144 --
145 -- * 'Left': the @unit@s which have a non null 'SumByUnit'
146 -- and for which no equibrating account can be inferred.
147 -- * 'Right': the given @post@s with inferred quantities inserted.
148 equilibrium ::
149 ( post ~ MT.Element posts
150
151 , Seqs.IsSequence posts
152 , Sumable (Balance name unit qty) post
153
154 , Get acct post
155 , Has (Map unit qty) post
156 , To acct (TM.Path name)
157
158 , Ord acct
159 , Ord name, Ord unit, Addable qty
160 , Nullable qty, Negable qty
161 ) =>
162 Map acct posts ->
163 ( Balance name unit qty
164 , Either [(unit, SumByUnit (TM.Path name) qty)]
165 (Map acct posts)
166 )
167 equilibrium postsByAcct =
168 let bal_initial = Fold.foldr (flip $ MT.ofoldr (flip (+=))) zero postsByAcct in
169 let DeviationByUnit dev = deviationByUnit bal_initial in
170 let (bal_adjusted, eithers) =
171 Map.foldrWithKey
172 (\unit sbu@SumByUnit{..} (bal, lr) ->
173 case Map.size $ sumByUnit_accounts of
174 1 ->
175 let acct = fst $ Map.elemAt 0 sumByUnit_accounts in
176 let qty = neg sumByUnit_quantity in
177 let amts = Map.singleton unit qty in
178 ( bal += (acct, amts)
179 , Right (acct, unit, qty) : lr
180 )
181 _ -> (bal, Left [(unit, sbu)] : lr))
182 (bal_initial, [])
183 dev in
184 let (l, r) = Fold.accumLeftsAndFoldrRights
185 (\(acct, unit, qty) ->
186 Map.adjust (Seqs.fromList . insAmount (unit, qty) . MT.otoList) (to acct))
187 -- NOTE: acct is within bal_initial,
188 -- hence postsByAcct already has a mapping for acct.
189 postsByAcct eithers in
190 case l of
191 [] -> (bal_adjusted, Right r)
192 _ -> (bal_adjusted, Left l)
193 where
194 insAmount ::
195 forall post unit qty.
196 (Ord unit, Has (Map unit qty) post) =>
197 (unit, qty) -> [post] -> [post]
198 insAmount amt@(unit, qty) l =
199 case l of
200 [] -> assert False []
201 -- NOTE: the acct being in bal_initial,
202 -- hence there was at least one post for this acct.
203 p:ps ->
204 let amts :: Map unit qty = get p in
205 if unit `Map.notMember` amts
206 then set (Map.insert unit qty amts) p:ps
207 else p:insAmount amt ps
208
209 -- | Return 'True' if and only if the given 'DeviationByUnit' maps no @unit@.
210 isEquilibrium :: DeviationByUnit name unit qty -> Bool
211 isEquilibrium (DeviationByUnit dev) = Map.null dev
212
213 -- | Return 'True' if and only if the given 'DeviationByUnit'
214 -- maps only to 'SumByUnit's whose 'sumByUnit_accounts'
215 -- maps exactly one account.
216 isEquilibriumInferrable :: DeviationByUnit name unit qty -> Bool
217 isEquilibriumInferrable (DeviationByUnit dev) =
218 Fold.all ((== 1) . Map.size . sumByUnit_accounts) dev
219
220 -- * Type 'ClusiveBalByAccount'
221
222 -- | {Ex,In}clusive 'BalByAccount':
223 -- descending propagation of quantities accross accounts.
224 type ClusiveBalByAccount name unit qty
225 = TreeMap name (ClusiveSumByAccount unit qty)
226
227 -- ** Type 'ClusiveSumByAccount'
228 -- |
229 -- * 'Strict.exclusive': contains the original 'SumByAccount'.
230 -- * 'Strict.inclusive': contains '(+)' folded
231 -- over 'Strict.exclusive' and 'Strict.inclusive'
232 -- of 'TM.node_descendants'
233 type ClusiveSumByAccount unit qty
234 = Strict.Clusive (SumByAccount unit qty)
235
236 -- | Return the given 'BalByAccount' with:
237 --
238 -- * all missing parent accounts inserted;
239 -- * and every mapped @qty@ added with any @qty@
240 -- of the account for which it is a parent.
241 clusiveBalByAccount ::
242 (Addable qty, Ord name, Ord unit) =>
243 BalByAccount name unit qty ->
244 ClusiveBalByAccount name unit qty
245 clusiveBalByAccount =
246 TM.map_by_depth_first
247 (\descendants value ->
248 let exclusive = Strict.fromMaybe Map.empty value in
249 Strict.Clusive
250 { Strict.exclusive
251 , Strict.inclusive =
252 Map.foldl'
253 ( flip $ (+) . Strict.inclusive
254 . Strict.fromMaybe (assert False undefined)
255 . TM.node_value )
256 exclusive $
257 TM.nodes descendants
258 })
259
260 -- | NOTE: also correct if the 'ClusiveBalByAccount' has been filtered.
261 instance (Ord name, Ord unit, Addable qty) =>
262 Sumable (BalByUnit name unit qty)
263 (ClusiveBalByAccount name unit qty) where
264 (+=) = go []
265 where
266 go p bal (TreeMap nodes) =
267 Map.foldrWithKey
268 (\k TM.Node{TM.node_value, TM.node_descendants} acc ->
269 case node_value of
270 Strict.Nothing -> go (k:p) acc node_descendants
271 Strict.Just Strict.Clusive{Strict.inclusive=amts} ->
272 let acct = Seqs.reverse $ TM.path k p in
273 acc += (acct, amts))
274 bal nodes