1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE NamedFieldPuns #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 module Hcompta.Calc.Balance where
7 import qualified Data.Foldable
8 import qualified Data.List
9 import qualified Data.Map.Strict as Data.Map
10 import Data.Map.Strict (Map)
11 import Data.Typeable ()
12 import Data.Maybe (fromMaybe)
13 import qualified GHC.Num
15 import qualified Hcompta.Model as Model ()
16 import qualified Hcompta.Model.Account as Account
17 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
18 import Hcompta.Model.Account (Account)
19 import qualified Hcompta.Model.Amount as Amount
20 import Hcompta.Model.Amount (Amount, Unit)
21 import qualified Hcompta.Model.Transaction as Transaction
22 import Hcompta.Model.Transaction (Transaction, Posting)
23 import qualified Hcompta.Model.Transaction.Posting as Posting
24 import qualified Hcompta.Model.Journal as Journal
25 import Hcompta.Model.Journal (Journal)
27 -- * The 'Balance' type
29 -- | Sum by 'Account' and sum by 'Unit' of some 'Posting's.
32 { by_account :: By_Account
34 } deriving (Data, Eq, Read, Show, Typeable)
37 = Lib.TreeMap.TreeMap Account.Name Account_Sum
38 -- | A sum of 'Amount's,
39 -- concerning a single 'Account'.
44 = Map Amount.Unit Unit_Sum
45 -- | A sum of 'Amount's with their 'Account's involved,
46 -- concerning a single 'Unit'.
49 { amount :: Amount -- ^ The sum of 'Amount's for a single 'Unit'.
50 , accounts :: Map Account () -- ^ The 'Account's involved to build 'amount'.
51 } deriving (Data, Eq, Read, Show, Typeable)
58 { by_account = Lib.TreeMap.empty
59 , by_unit = Data.Map.empty
62 nil_By_Account :: By_Account
66 nil_By_Unit :: By_Unit
70 nil_Sum_by_Account :: Account_Sum
74 nil_Sum_by_Unit :: Unit_Sum
77 { accounts = Data.Map.empty
81 -- | Return a tuple associating the given 'Unit_Sum' with its 'Unit'.
82 assoc_unit_sum :: Unit_Sum -> (Unit, Unit_Sum)
83 assoc_unit_sum s = (Amount.unit $ amount s, s)
85 -- | Return a 'Map' associating the given 'Unit_Sum' with their respective 'Unit'.
86 by_Unit_from_List :: [Unit_Sum] -> By_Unit
87 by_Unit_from_List balances =
90 { amount=(GHC.Num.+) (amount x) (amount y)
91 , accounts=Data.Map.union (accounts x) (accounts y)
93 Data.List.map assoc_unit_sum balances
95 -- ** Incremental constructors
97 -- | Return the given 'Balance'
98 -- updated by the given 'Posting'.
99 posting :: Posting -> Balance -> Balance
100 posting post balance =
104 (Data.Map.unionWith (GHC.Num.+))
105 (Posting.account post)
106 (Posting.amounts post)
111 { amount = (GHC.Num.+) (amount x) (amount y)
112 , accounts = Data.Map.union (accounts x) (accounts y)
118 , accounts = Data.Map.singleton (Posting.account post) ()
120 (Posting.amounts post)
123 -- | Return the given 'Balance'
124 -- updated by the 'Transaction.postings'
125 -- of the given 'Transaction'.
126 transaction :: Transaction -> Balance -> Balance
127 transaction tran balance =
129 (flip (Data.List.foldl (flip posting)))
131 (Transaction.postings tran)
133 -- | Return the given 'Balance'
134 -- updated by the 'Transaction.postings'
135 -- and 'Transaction.virtual_postings'
136 -- and 'Transaction.balanced_virtual_postings'
137 -- of the given 'Transaction'.
138 transaction_with_virtual :: Transaction -> Balance -> Balance
139 transaction_with_virtual tran balance =
141 (flip (Data.List.foldl (flip posting)))
143 (Transaction.postings tran)
145 -- | Return the given 'Balance'
146 -- updated by the 'Transaction.balanced_virtual_postings' of the given 'Transaction'.
147 transaction_balanced_virtual :: Transaction -> Balance -> Balance
148 transaction_balanced_virtual tran balance =
150 (flip (Data.List.foldl (flip posting)))
152 (Transaction.balanced_virtual_postings tran)
154 -- | Return the given 'Balance'
155 -- updated by the 'Journal.transactions'
156 -- of the given 'Journal',
157 -- through 'transaction'.
158 journal :: Journal -> Balance -> Balance
159 journal jour balance =
161 (Data.List.foldl (flip transaction))
163 (Journal.transactions jour)
165 -- | Return the given 'Balance'
166 -- updated by the 'Journal.transactions'
167 -- of the given 'Journal',
168 -- through 'transaction'.
169 journal_with_virtual :: Journal -> Balance -> Balance
170 journal_with_virtual jour balance =
172 (Data.List.foldl (flip transaction_with_virtual))
174 (Journal.transactions jour)
176 -- | Return the first given 'Balance'
177 -- updated by the second given 'Balance'.
178 union :: Balance -> Balance -> Balance
183 (Data.Map.unionWith (GHC.Num.+))
189 { amount = (GHC.Num.+) (amount x) (amount y)
190 , accounts = Data.Map.union (accounts x) (accounts y)
196 -- * The 'Equilibre' type
198 -- | See 'equilibre'.
201 deriving (Data, Eq, Read, Show, Typeable)
203 -- | Return the 'by_unit' of the given 'Balance' with:
205 -- * 'Unit's whose 'Unit_Sum' 'amount' verifying 'Amount.is_zero' removed,
207 -- * and remaining 'Unit's having their 'Unit_Sum' 'accounts'
208 -- complemented with the 'by_account' of the given 'Balance'
209 -- (i.e. now mapping to accounts __not__ involved to build the 'Unit_Sum').
210 equilibre :: Balance -> Equilibre
211 equilibre balance = do
212 let all_accounts = Lib.TreeMap.flatten (const ()) (by_account balance)
213 let max_accounts = Data.Map.size all_accounts
215 Data.Map.foldlWithKey
216 (\m unit Unit_Sum{amount, accounts} ->
217 if Amount.is_zero amount
220 case Data.Map.size accounts of
221 n | n == max_accounts ->
222 Data.Map.insert unit Unit_Sum{amount, accounts=Data.Map.empty} m
224 let diff = Data.Map.difference all_accounts accounts
225 Data.Map.insert unit Unit_Sum{amount, accounts=diff} m
232 -- | Return 'True' if and only if the given 'Equilibre' satisfies:
234 -- * 'is_equilibrated',
235 -- * or 'is_inferrable'.
236 is_equilibrable :: Equilibre -> Bool
237 is_equilibrable e@(Equilibre eq) =
238 Data.Map.null eq || is_inferrable e
240 -- | Return 'True' if and only if the given 'Equilibre' maps no 'Unit'.
241 is_equilibrated :: Equilibre -> Bool
242 is_equilibrated (Equilibre eq) = Data.Map.null eq
244 -- | Return 'True' if and only if the given 'Equilibre'
245 -- maps only to 'Unit_Sum's whose 'accounts'
246 -- maps exactly one 'Account'.
247 is_inferrable :: Equilibre -> Bool
248 is_inferrable (Equilibre eq) =
250 (\Unit_Sum{accounts} -> Data.Map.size accounts == 1)
253 -- | Return 'True' if and only if the given 'Equilibre'
254 -- maps to at least one 'Unit_Sum's whose 'accounts'
255 -- maps more than one 'Account'.
256 is_non_inferrable :: Equilibre -> Bool
257 is_non_inferrable (Equilibre eq) =
259 (\Unit_Sum{accounts} -> Data.Map.size accounts > 1)
262 -- * The 'Expanded' type
265 type Expanded = Lib.TreeMap.TreeMap Account.Name Account_Sum_Expanded
266 data Account_Sum_Expanded
267 = Account_Sum_Expanded
268 { inclusive :: Amount.By_Unit
269 , exclusive :: Amount.By_Unit
271 deriving (Data, Eq, Read, Show, Typeable)
273 -- | Return the given 'By_Account' with:
275 -- * all missing 'Account.ascending' 'Account's inserted,
277 -- * and every mapped Amount.'Amount.By_Unit'
278 -- added with any Amount.'Amount.By_Unit'
279 -- of the 'Account'sā for which it is 'Account.ascending'.
280 expand :: By_Account -> Expanded
282 Lib.TreeMap.depth_first_map
283 (\descendants content ->
284 let exc = fromMaybe Data.Map.empty content in
289 ( Data.Map.unionWith (GHC.Num.+)
291 . fromMaybe (error "Oops, should not happen")
292 . Lib.TreeMap.node_content) )