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 qualified GHC.Num
  13
  14 import qualified Hcompta.Model as Model ()
  15 import qualified Hcompta.Model.Account as Account
  16 import           Hcompta.Model.Account (Account)
  17 import qualified Hcompta.Model.Amount as Amount
  18 import           Hcompta.Model.Amount (Amount, Unit)
  19 import qualified Hcompta.Model.Transaction as Transaction
  20 import           Hcompta.Model.Transaction (Transaction, Posting)
  21 import qualified Hcompta.Model.Transaction.Posting as Posting
  22 import qualified Hcompta.Model.Journal as Journal
  23 import           Hcompta.Model.Journal (Journal)
  24
  25 -- * The 'Balance' type
  26
  27 -- | Sum by 'Account' and sum by 'Unit' of some 'Posting's.
  28 data Balance
  29  =   Balance
  30  { by_account :: By_Account
  31  , by_unit    :: By_Unit
  32  } deriving (Data, Eq, Read, Show, Typeable)
  33
  34 type By_Account
  35  = Map Account Account_Sum
  36 -- | A sum of 'Amount's,
  37 -- concerning a single 'Account'.
  38 type Account_Sum
  39  = Amount.By_Unit
  40
  41 type By_Unit
  42  = Map Amount.Unit Unit_Sum
  43 -- | A sum of 'Amount's with their 'Account's involved,
  44 -- concerning a single 'Unit'.
  45 data Unit_Sum
  46  =   Unit_Sum
  47  { amount   :: Amount -- ^ The sum of 'Amount's for a single 'Unit'.
  48  , accounts :: Map Account () -- ^ The 'Account's involved to build 'amount'.
  49  } deriving (Data, Eq, Read, Show, Typeable)
  50
  51 -- ** Constructors
  52
  53 nil :: Balance
  54 nil =
  55         Balance
  56          { by_account = Data.Map.empty
  57          , by_unit    = Data.Map.empty
  58          }
  59
  60 nil_By_Account :: By_Account
  61 nil_By_Account =
  62         Data.Map.empty
  63
  64 nil_By_Unit :: By_Unit
  65 nil_By_Unit =
  66         Data.Map.empty
  67
  68 nil_Sum_by_Account :: Account_Sum
  69 nil_Sum_by_Account =
  70         Data.Map.empty
  71
  72 nil_Sum_by_Unit :: Unit_Sum
  73 nil_Sum_by_Unit =
  74         Unit_Sum
  75          { accounts = Data.Map.empty
  76          , amount = Amount.nil
  77          }
  78
  79 -- | Return a tuple associating the given 'Unit_Sum' with its 'Unit'.
  80 assoc_unit_sum :: Unit_Sum -> (Unit, Unit_Sum)
  81 assoc_unit_sum s = (Amount.unit $ amount s, s)
  82
  83 -- | Return a 'Map' associating the given 'Unit_Sum' with their respective 'Unit'.
  84 by_Unit_from_List :: [Unit_Sum] -> By_Unit
  85 by_Unit_from_List balances =
  86         Data.Map.fromListWith
  87          (\x y -> Unit_Sum
  88                  { amount=(GHC.Num.+) (amount x) (amount y)
  89                  , accounts=Data.Map.union (accounts x) (accounts y)
  90                  }) $
  91         Data.List.map assoc_unit_sum balances
  92
  93 -- ** Incremental constructors
  94
  95 -- | Return the given 'Balance'
  96 --   updated by the given 'Posting'.
  97 posting :: Posting -> Balance -> Balance
  98 posting post balance =
  99         balance
 100          { by_account =
 101                 Data.Map.insertWith
 102                  (Data.Map.unionWith (GHC.Num.+))
 103                  (Posting.account post)
 104                  (Posting.amounts post)
 105                  (by_account balance)
 106          , by_unit =
 107                 Data.Map.unionWith
 108                  (\x y -> Unit_Sum
 109                          { amount   = (GHC.Num.+) (amount x) (amount y)
 110                          , accounts = Data.Map.union (accounts x) (accounts y)
 111                          })
 112                  (by_unit balance) $
 113                 Data.Map.map
 114                  (\amount -> Unit_Sum
 115                          { amount
 116                          , accounts = Data.Map.singleton (Posting.account post) ()
 117                          })
 118                  (Posting.amounts post)
 119          }
 120
 121 -- | Return the given 'Balance'
 122 --   updated by the 'Transaction.postings'
 123 --   of the given 'Transaction'.
 124 transaction :: Transaction -> Balance -> Balance
 125 transaction tran balance =
 126         Data.Map.foldr
 127          (flip (Data.List.foldl (flip posting)))
 128          balance
 129          (Transaction.postings tran)
 130
 131 -- | Return the given 'Balance'
 132 --   updated by the 'Transaction.postings'
 133 --   and 'Transaction.virtual_postings'
 134 --   and 'Transaction.balanced_virtual_postings'
 135 --   of the given 'Transaction'.
 136 transaction_with_virtual :: Transaction -> Balance -> Balance
 137 transaction_with_virtual tran balance =
 138         Data.Map.foldr
 139          (flip (Data.List.foldl (flip posting)))
 140          balance
 141          (Transaction.postings tran)
 142
 143 -- | Return the given 'Balance'
 144 --   updated by the 'Transaction.balanced_virtual_postings' of the given 'Transaction'.
 145 transaction_balanced_virtual :: Transaction -> Balance -> Balance
 146 transaction_balanced_virtual tran balance =
 147         Data.Map.foldr
 148          (flip (Data.List.foldl (flip posting)))
 149          balance
 150          (Transaction.balanced_virtual_postings tran)
 151
 152 -- | Return the given 'Balance'
 153 --   updated by the 'Journal.transactions'
 154 --   of the given 'Journal',
 155 --   through 'transactions'.
 156 journal :: Journal -> Balance -> Balance
 157 journal jour balance =
 158         Data.Map.foldl
 159          (Data.List.foldl (flip transaction))
 160          balance
 161          (Journal.transactions jour)
 162
 163 -- | Return the given 'Balance'
 164 --   updated by the 'Journal.transactions'
 165 --   of the given 'Journal',
 166 --   through 'transactions'.
 167 journal_with_virtual :: Journal -> Balance -> Balance
 168 journal_with_virtual jour balance =
 169         Data.Map.foldl
 170          (Data.List.foldl (flip transaction_with_virtual))
 171          balance
 172          (Journal.transactions jour)
 173
 174 -- | Return the first given 'Balance'
 175 --   updated by the second given 'Balance'.
 176 union :: Balance -> Balance -> Balance
 177 union b0 b1 =
 178         b0
 179          { by_account =
 180                 Data.Map.unionWith
 181                  (Data.Map.unionWith (GHC.Num.+))
 182                  (by_account b0)
 183                  (by_account b1)
 184          , by_unit =
 185                 Data.Map.unionWith
 186                  (\x y -> Unit_Sum
 187                          { amount = (GHC.Num.+) (amount x) (amount y)
 188                          , accounts = Data.Map.union (accounts x) (accounts y)
 189                          })
 190                  (by_unit b0)
 191                  (by_unit b1)
 192          }
 193
 194 -- * The 'Equilibre' type
 195
 196 -- | See 'equilibre'.
 197 newtype Equilibre
 198  =      Equilibre By_Unit
 199  deriving (Data, Eq, Read, Show, Typeable)
 200
 201 -- | Return the 'by_unit' of the given 'Balance' with:
 202 --
 203 -- * 'Unit's whose 'Unit_Sum' 'amount' verifying 'Amount.is_zero' removed,
 204 --
 205 -- * and remaining 'Unit's having their 'Unit_Sum' 'accounts'
 206 -- complemented with the 'by_account' of the given 'Balance'
 207 -- (i.e. now mapping to accounts __not__ involved to build the 'Unit_Sum').
 208 equilibre :: Balance -> Equilibre
 209 equilibre balance = do
 210         let max_accounts = Data.Map.size $ by_account balance
 211         Equilibre $ Data.Map.foldlWithKey
 212          (\m unit Unit_Sum{amount, accounts} ->
 213                 if Amount.is_zero $ amount
 214                 then m
 215                 else
 216                         case Data.Map.size accounts of
 217                          n | n == max_accounts ->
 218                                 Data.Map.insert unit Unit_Sum{amount, accounts=Data.Map.empty} m
 219                          _ -> do
 220                                 let d = Data.Map.map (const ()) $
 221                                         Data.Map.difference (by_account balance) accounts
 222                                 Data.Map.insert unit Unit_Sum{amount, accounts=d} m
 223          )
 224          Data.Map.empty
 225          (by_unit balance)
 226
 227 -- ** Tests
 228
 229 -- | Return 'True' if and only if the given 'Equilibre' maps no 'Unit'.
 230 is_equilibrated :: Equilibre -> Bool
 231 is_equilibrated (Equilibre eq) = Data.Map.null eq
 232
 233 -- | Return 'True' if and only if the given 'Equilibre' satisfies:
 234 --
 235 -- * 'is_equilibrated',
 236 -- * or 'is_inferrable'.
 237 is_equilibrable :: Equilibre -> Bool
 238 is_equilibrable e@(Equilibre eq) =
 239         Data.Map.null eq || is_inferrable e
 240
 241 -- | Return 'True' if and only if the given 'Equilibre'
 242 -- maps only to 'Unit_Sum's whose 'accounts'
 243 -- maps exactly one 'Account'.
 244 is_inferrable :: Equilibre -> Bool
 245 is_inferrable (Equilibre eq) =
 246         Data.Foldable.all
 247          (\Unit_Sum{accounts} -> Data.Map.size accounts == 1)
 248          eq
 249
 250 -- | Return 'True' if and only if the given 'Equilibre'
 251 -- maps to at least one 'Unit_Sum's whose 'accounts'
 252 -- maps more than one 'Account'.
 253 is_non_inferrable :: Equilibre -> Bool
 254 is_non_inferrable (Equilibre eq) =
 255         Data.Foldable.any
 256          (\Unit_Sum{accounts} -> Data.Map.size accounts > 1)
 257          eq
 258
 259 -- * The 'Expanded' type
 260
 261 -- | See 'expand'.
 262 newtype Expanded
 263  =      Expanded By_Account
 264  deriving (Data, Eq, Read, Show, Typeable)
 265
 266 -- | Return the given 'By_Account' with:
 267 --
 268 -- * all missing 'Account.ascending' 'Account's inserted,
 269 --
 270 -- * and every mapped Amount.'Amount.By_Unit'
 271 -- added with any Amount.'Amount.By_Unit'
 272 -- of the 'Account's’ for which it is 'Account.ascending'.
 273 expand :: By_Account -> Expanded
 274 expand balance =
 275         -- TODO: because (+) is associative
 276         --       the complexity could be improved a bit
 277         --       by only adding to the longest 'Account.ascending'
 278         --       and reuse this result thereafter,
 279         --       but coding this requires access
 280         --       to the hidden constructors of 'Data.Map.Map',
 281         --       which could be done through TemplateHaskell and lens:
 282         --       https://stackoverflow.com/questions/24153577/pattern-matching-on-data-map-for-implementing-map
 283         --
 284         -- a0' = a0 + a1 + a2 + a3   <-- current calculus
 285         --     = a0 + a1'            <-- improved calculus todo
 286         -- a1' =      a1 + a2 + a3
 287         --     =      a1 + a2'
 288         -- a2' =           a2 + a3
 289         -- a3' =                a3
 290         Expanded $
 291                 Data.Map.foldrWithKey
 292                  (\account amt ->
 293                         Account.fold (Account.ascending account)
 294                          (\prefix -> Data.Map.insertWith (+) prefix amt))
 295                  balance
 296                  balance