lib/Hcompta/Calc/Balance.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 module Hcompta.Calc.Balance where
   5
   6 import           Data.Data
   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
  14
  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)
  26
  27 -- * The 'Balance' type
  28
  29 -- | Sum by 'Account' and sum by 'Unit' of some 'Posting's.
  30 data Balance
  31  =   Balance
  32  { by_account :: By_Account
  33  , by_unit    :: By_Unit
  34  } deriving (Data, Eq, Read, Show, Typeable)
  35
  36 type By_Account
  37  = Lib.TreeMap.TreeMap Account.Name Account_Sum
  38 -- | A sum of 'Amount's,
  39 -- concerning a single 'Account'.
  40 type Account_Sum
  41  = Amount.By_Unit
  42
  43 type By_Unit
  44  = Map Amount.Unit Unit_Sum
  45 -- | A sum of 'Amount's with their 'Account's involved,
  46 -- concerning a single 'Unit'.
  47 data Unit_Sum
  48  =   Unit_Sum
  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)
  52
  53 -- ** Constructors
  54
  55 nil :: Balance
  56 nil =
  57         Balance
  58          { by_account = Lib.TreeMap.empty
  59          , by_unit    = Data.Map.empty
  60          }
  61
  62 nil_By_Account :: By_Account
  63 nil_By_Account =
  64         Lib.TreeMap.empty
  65
  66 nil_By_Unit :: By_Unit
  67 nil_By_Unit =
  68         Data.Map.empty
  69
  70 nil_Sum_by_Account :: Account_Sum
  71 nil_Sum_by_Account =
  72         Data.Map.empty
  73
  74 nil_Sum_by_Unit :: Unit_Sum
  75 nil_Sum_by_Unit =
  76         Unit_Sum
  77          { accounts = Data.Map.empty
  78          , amount = Amount.nil
  79          }
  80
  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)
  84
  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 =
  88         Data.Map.fromListWith
  89          (\x y -> Unit_Sum
  90                  { amount=(GHC.Num.+) (amount x) (amount y)
  91                  , accounts=Data.Map.union (accounts x) (accounts y)
  92                  }) $
  93         Data.List.map assoc_unit_sum balances
  94
  95 -- ** Incremental constructors
  96
  97 -- | Return the given 'Balance'
  98 --   updated by the given 'Posting'.
  99 posting :: Posting -> Balance -> Balance
 100 posting post balance =
 101         balance
 102          { by_account =
 103                 Lib.TreeMap.insert
 104                  (Data.Map.unionWith (GHC.Num.+))
 105                  (Posting.account post)
 106                  (Posting.amounts post)
 107                  (by_account balance)
 108          , by_unit =
 109                 Data.Map.unionWith
 110                  (\x y -> Unit_Sum
 111                          { amount   = (GHC.Num.+) (amount x) (amount y)
 112                          , accounts = Data.Map.union (accounts x) (accounts y)
 113                          })
 114                  (by_unit balance) $
 115                 Data.Map.map
 116                  (\amount -> Unit_Sum
 117                          { amount
 118                          , accounts = Data.Map.singleton (Posting.account post) ()
 119                          })
 120                  (Posting.amounts post)
 121          }
 122
 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 =
 128         Data.Map.foldr
 129          (flip (Data.List.foldl (flip posting)))
 130          balance
 131          (Transaction.postings tran)
 132
 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 =
 140         flip (Data.Map.foldr
 141          (flip (Data.List.foldl (flip posting))))
 142          (Transaction.virtual_postings tran) $
 143         flip (Data.Map.foldr
 144          (flip (Data.List.foldl (flip posting))))
 145          (Transaction.balanced_virtual_postings tran) $
 146         Data.Map.foldr
 147          (flip (Data.List.foldl (flip posting)))
 148          balance
 149          (Transaction.postings tran)
 150
 151 -- | Return the given 'Balance'
 152 --   updated by the 'Transaction.balanced_virtual_postings' of the given 'Transaction'.
 153 transaction_balanced_virtual :: Transaction -> Balance -> Balance
 154 transaction_balanced_virtual tran balance =
 155         Data.Map.foldr
 156          (flip (Data.List.foldl (flip posting)))
 157          balance
 158          (Transaction.balanced_virtual_postings tran)
 159
 160 -- | Return the given 'Balance'
 161 --   updated by the 'Journal.transactions'
 162 --   of the given 'Journal',
 163 --   through 'transaction'.
 164 journal :: Journal -> Balance -> Balance
 165 journal jour balance =
 166         Data.Map.foldl
 167          (Data.List.foldl (flip transaction))
 168          balance
 169          (Journal.transactions jour)
 170
 171 -- | Return the given 'Balance'
 172 --   updated by the 'Journal.transactions'
 173 --   of the given 'Journal',
 174 --   through 'transaction'.
 175 journal_with_virtual :: Journal -> Balance -> Balance
 176 journal_with_virtual jour balance =
 177         Data.Map.foldl
 178          (Data.List.foldl (flip transaction_with_virtual))
 179          balance
 180          (Journal.transactions jour)
 181
 182 -- | Return the first given 'Balance'
 183 --   updated by the second given 'Balance'.
 184 union :: Balance -> Balance -> Balance
 185 union b0 b1 =
 186         b0
 187          { by_account =
 188                 Lib.TreeMap.union
 189                  (Data.Map.unionWith (GHC.Num.+))
 190                  (by_account b0)
 191                  (by_account b1)
 192          , by_unit =
 193                 Data.Map.unionWith
 194                  (\x y -> Unit_Sum
 195                          { amount = (GHC.Num.+) (amount x) (amount y)
 196                          , accounts = Data.Map.union (accounts x) (accounts y)
 197                          })
 198                  (by_unit b0)
 199                  (by_unit b1)
 200          }
 201
 202 -- * The 'Equilibre' type
 203
 204 -- | See 'equilibre'.
 205 newtype Equilibre
 206  =      Equilibre By_Unit
 207  deriving (Data, Eq, Read, Show, Typeable)
 208
 209 -- | Return the 'by_unit' of the given 'Balance' with:
 210 --
 211 -- * 'Unit's whose 'Unit_Sum' 'amount' verifying 'Amount.is_zero' removed,
 212 --
 213 -- * and remaining 'Unit's having their 'Unit_Sum' 'accounts'
 214 -- complemented with the 'by_account' of the given 'Balance'
 215 -- (i.e. now mapping to accounts __not__ involved to build the 'Unit_Sum').
 216 equilibre :: Balance -> Equilibre
 217 equilibre balance = do
 218         let all_accounts = Lib.TreeMap.flatten (const ()) (by_account balance)
 219         let max_accounts = Data.Map.size all_accounts
 220         Equilibre $
 221                 Data.Map.foldlWithKey
 222                  (\m unit Unit_Sum{amount, accounts} ->
 223                         if Amount.is_zero amount
 224                         then m
 225                         else
 226                                 case Data.Map.size accounts of
 227                                  n | n == max_accounts ->
 228                                         Data.Map.insert unit Unit_Sum{amount, accounts=Data.Map.empty} m
 229                                  _ -> do
 230                                         let diff = Data.Map.difference all_accounts accounts
 231                                         Data.Map.insert unit Unit_Sum{amount, accounts=diff} m
 232                  )
 233                  Data.Map.empty
 234                  (by_unit balance)
 235
 236 -- ** Tests
 237
 238 -- | Return 'True' if and only if the given 'Equilibre' satisfies:
 239 --
 240 -- * 'is_equilibrated',
 241 -- * or 'is_inferrable'.
 242 is_equilibrable :: Equilibre -> Bool
 243 is_equilibrable e@(Equilibre eq) =
 244         Data.Map.null eq || is_inferrable e
 245
 246 -- | Return 'True' if and only if the given 'Equilibre' maps no 'Unit'.
 247 is_equilibrated :: Equilibre -> Bool
 248 is_equilibrated (Equilibre eq) = Data.Map.null eq
 249
 250 -- | Return 'True' if and only if the given 'Equilibre'
 251 -- maps only to 'Unit_Sum's whose 'accounts'
 252 -- maps exactly one 'Account'.
 253 is_inferrable :: Equilibre -> Bool
 254 is_inferrable (Equilibre eq) =
 255         Data.Foldable.all
 256          (\Unit_Sum{accounts} -> Data.Map.size accounts == 1)
 257          eq
 258
 259 -- | Return 'True' if and only if the given 'Equilibre'
 260 -- maps to at least one 'Unit_Sum's whose 'accounts'
 261 -- maps more than one 'Account'.
 262 is_non_inferrable :: Equilibre -> Bool
 263 is_non_inferrable (Equilibre eq) =
 264         Data.Foldable.any
 265          (\Unit_Sum{accounts} -> Data.Map.size accounts > 1)
 266          eq
 267
 268 -- * The 'Expanded' type
 269
 270 -- | See 'expand'.
 271 type Expanded = Lib.TreeMap.TreeMap Account.Name Account_Sum_Expanded
 272 data Account_Sum_Expanded
 273  =   Account_Sum_Expanded
 274  { inclusive :: Amount.By_Unit
 275  , exclusive :: Amount.By_Unit
 276  }
 277  deriving (Data, Eq, Read, Show, Typeable)
 278
 279 -- | Return the given 'By_Account' with:
 280 --
 281 -- * all missing 'Account.ascending' 'Account's inserted,
 282 --
 283 -- * and every mapped Amount.'Amount.By_Unit'
 284 -- added with any Amount.'Amount.By_Unit'
 285 -- of the 'Account's’ for which it is 'Account.ascending'.
 286 expand :: By_Account -> Expanded
 287 expand =
 288         Lib.TreeMap.depth_first_map
 289          (\descendants content ->
 290                 let exc = fromMaybe Data.Map.empty content in
 291                 Account_Sum_Expanded
 292                  { exclusive = exc
 293                  , inclusive =
 294                         Data.Map.foldr
 295                          ( Data.Map.unionWith (GHC.Num.+)
 296                          . ( inclusive
 297                                  . fromMaybe (error "Oops, should not happen")
 298                                  . Lib.TreeMap.node_content) )
 299                          exc descendants
 300                  })