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         Data.Map.foldr
 141          (flip (Data.List.foldl (flip posting)))
 142          balance
 143          (Transaction.postings tran)
 144
 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 =
 149         Data.Map.foldr
 150          (flip (Data.List.foldl (flip posting)))
 151          balance
 152          (Transaction.balanced_virtual_postings tran)
 153
 154 -- | Return the given 'Balance'
 155 --   updated by the 'Journal.transactions'
 156 --   of the given 'Journal',
 157 --   through 'transactions'.
 158 journal :: Journal -> Balance -> Balance
 159 journal jour balance =
 160         Data.Map.foldl
 161          (Data.List.foldl (flip transaction))
 162          balance
 163          (Journal.transactions jour)
 164
 165 -- | Return the given 'Balance'
 166 --   updated by the 'Journal.transactions'
 167 --   of the given 'Journal',
 168 --   through 'transactions'.
 169 journal_with_virtual :: Journal -> Balance -> Balance
 170 journal_with_virtual jour balance =
 171         Data.Map.foldl
 172          (Data.List.foldl (flip transaction_with_virtual))
 173          balance
 174          (Journal.transactions jour)
 175
 176 -- | Return the first given 'Balance'
 177 --   updated by the second given 'Balance'.
 178 union :: Balance -> Balance -> Balance
 179 union b0 b1 =
 180         b0
 181          { by_account =
 182                 Lib.TreeMap.union
 183                  (Data.Map.unionWith (GHC.Num.+))
 184                  (by_account b0)
 185                  (by_account b1)
 186          , by_unit =
 187                 Data.Map.unionWith
 188                  (\x y -> Unit_Sum
 189                          { amount = (GHC.Num.+) (amount x) (amount y)
 190                          , accounts = Data.Map.union (accounts x) (accounts y)
 191                          })
 192                  (by_unit b0)
 193                  (by_unit b1)
 194          }
 195
 196 -- * The 'Equilibre' type
 197
 198 -- | See 'equilibre'.
 199 newtype Equilibre
 200  =      Equilibre By_Unit
 201  deriving (Data, Eq, Read, Show, Typeable)
 202
 203 -- | Return the 'by_unit' of the given 'Balance' with:
 204 --
 205 -- * 'Unit's whose 'Unit_Sum' 'amount' verifying 'Amount.is_zero' removed,
 206 --
 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
 214         Equilibre $
 215                 Data.Map.foldlWithKey
 216                  (\m unit Unit_Sum{amount, accounts} ->
 217                         if Amount.is_zero amount
 218                         then m
 219                         else
 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
 223                                  _ -> do
 224                                         let diff = Data.Map.difference all_accounts accounts
 225                                         Data.Map.insert unit Unit_Sum{amount, accounts=diff} m
 226                  )
 227                  Data.Map.empty
 228                  (by_unit balance)
 229
 230 -- ** Tests
 231
 232 -- | Return 'True' if and only if the given 'Equilibre' satisfies:
 233 --
 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
 239
 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
 243
 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) =
 249         Data.Foldable.all
 250          (\Unit_Sum{accounts} -> Data.Map.size accounts == 1)
 251          eq
 252
 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) =
 258         Data.Foldable.any
 259          (\Unit_Sum{accounts} -> Data.Map.size accounts > 1)
 260          eq
 261
 262 -- * The 'Expanded' type
 263
 264 -- | See 'expand'.
 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
 270  }
 271  deriving (Data, Eq, Read, Show, Typeable)
 272
 273 -- | Return the given 'By_Account' with:
 274 --
 275 -- * all missing 'Account.ascending' 'Account's inserted,
 276 --
 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
 281 expand =
 282         Lib.TreeMap.depth_first_map
 283          (\descendants content ->
 284                 let exc = fromMaybe Data.Map.empty content in
 285                 Account_Sum_Expanded
 286                  { exclusive = exc
 287                  , inclusive =
 288                         Data.Map.foldr
 289                          ( Data.Map.unionWith (GHC.Num.+)
 290                          . ( inclusive
 291                                  . fromMaybe (error "Oops, should not happen")
 292                                  . Lib.TreeMap.node_content) )
 293                          exc descendants
 294                  })