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_Account_Sum :: Account_Sum
  71 nil_Account_Sum =
  72         Data.Map.empty
  73
  74 nil_Unit_Sum :: Unit_Sum
  75 nil_Unit_Sum =
  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 given 'Posting's.
 125 postings :: (Foldable to, Foldable ti) => to (ti Posting) -> Balance -> Balance
 126 postings = flip $ Data.Foldable.foldr (flip (Data.Foldable.foldr posting))
 127
 128 -- | Return the given 'Balance'
 129 --   updated by the 'Transaction.postings'
 130 --   of the given 'Transaction'.
 131 transaction :: Transaction -> Balance -> Balance
 132 transaction = postings . Transaction.postings
 133
 134 -- | Return the given 'Balance'
 135 --   updated by the 'Transaction.postings'
 136 --   and 'Transaction.virtual_postings'
 137 --   and 'Transaction.balanced_virtual_postings'
 138 --   of the given 'Transaction'.
 139 transaction_with_virtual :: Transaction -> Balance -> Balance
 140 transaction_with_virtual tr =
 141         postings (Transaction.balanced_virtual_postings tr) .
 142         postings (Transaction.virtual_postings tr) .
 143         postings (Transaction.postings tr)
 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 =
 149         postings . Transaction.balanced_virtual_postings
 150
 151 -- | Return the given 'Balance'
 152 --   updated by the 'Journal.transactions'
 153 --   of the given 'Journal',
 154 --   through 'transaction'.
 155 journal :: Journal -> Balance -> Balance
 156 journal jour balance =
 157         Data.Map.foldl
 158          (Data.List.foldl (flip transaction))
 159          balance
 160          (Journal.transactions jour)
 161
 162 -- | Return the given 'Balance'
 163 --   updated by the 'Journal.transactions'
 164 --   of the given 'Journal',
 165 --   through 'transaction'.
 166 journal_with_virtual :: Journal -> Balance -> Balance
 167 journal_with_virtual jour balance =
 168         Data.Map.foldl
 169          (Data.List.foldl (flip transaction_with_virtual))
 170          balance
 171          (Journal.transactions jour)
 172
 173 -- | Return the first given 'Balance'
 174 --   updated by the second given 'Balance'.
 175 union :: Balance -> Balance -> Balance
 176 union b0 b1 =
 177         b0
 178          { by_account =
 179                 Lib.TreeMap.union
 180                  (Data.Map.unionWith (GHC.Num.+))
 181                  (by_account b0)
 182                  (by_account b1)
 183          , by_unit =
 184                 Data.Map.unionWith
 185                  (\x y -> Unit_Sum
 186                          { amount = (GHC.Num.+) (amount x) (amount y)
 187                          , accounts = Data.Map.union (accounts x) (accounts y)
 188                          })
 189                  (by_unit b0)
 190                  (by_unit b1)
 191          }
 192
 193 -- * The 'Equilibre' type
 194
 195 -- | See 'equilibre'.
 196 newtype Equilibre
 197  =      Equilibre By_Unit
 198  deriving (Data, Eq, Read, Show, Typeable)
 199
 200 -- | Return the 'by_unit' of the given 'Balance' with:
 201 --
 202 -- * 'Unit's whose 'Unit_Sum' 'amount' verifying 'Amount.is_zero' removed,
 203 --
 204 -- * and remaining 'Unit's having their 'Unit_Sum' 'accounts'
 205 -- complemented with the 'by_account' of the given 'Balance'
 206 -- (i.e. now mapping to accounts __not__ involved to build the 'Unit_Sum').
 207 equilibre :: Balance -> Equilibre
 208 equilibre balance = do
 209         let all_accounts = Lib.TreeMap.flatten (const ()) (by_account balance)
 210         let max_accounts = Data.Map.size all_accounts
 211         Equilibre $
 212                 Data.Map.foldlWithKey
 213                  (\m unit Unit_Sum{amount, accounts} ->
 214                         if Amount.is_zero amount
 215                         then m
 216                         else
 217                                 case Data.Map.size accounts of
 218                                  n | n == max_accounts ->
 219                                         Data.Map.insert unit Unit_Sum{amount, accounts=Data.Map.empty} m
 220                                  _ -> do
 221                                         let diff = Data.Map.difference all_accounts accounts
 222                                         Data.Map.insert unit Unit_Sum{amount, accounts=diff} m
 223                  )
 224                  Data.Map.empty
 225                  (by_unit balance)
 226
 227 -- ** Tests
 228
 229 -- | Return 'True' if and only if the given 'Equilibre' satisfies:
 230 --
 231 -- * 'is_equilibrated',
 232 -- * or 'is_inferrable'.
 233 is_equilibrable :: Equilibre -> Bool
 234 is_equilibrable e@(Equilibre eq) =
 235         Data.Map.null eq || is_inferrable e
 236
 237 -- | Return 'True' if and only if the given 'Equilibre' maps no 'Unit'.
 238 is_equilibrated :: Equilibre -> Bool
 239 is_equilibrated (Equilibre eq) = Data.Map.null eq
 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 type Expanded = Lib.TreeMap.TreeMap Account.Name Account_Sum_Expanded
 263 data Account_Sum_Expanded
 264  =   Account_Sum_Expanded
 265  { inclusive :: Amount.By_Unit
 266  , exclusive :: Amount.By_Unit
 267  }
 268  deriving (Data, Eq, Read, Show, Typeable)
 269
 270 -- | Return the given 'By_Account' with:
 271 --
 272 -- * all missing 'Account.ascending' 'Account's inserted,
 273 --
 274 -- * and every mapped Amount.'Amount.By_Unit'
 275 -- added with any Amount.'Amount.By_Unit'
 276 -- of the 'Account's’ for which it is 'Account.ascending'.
 277 expand :: By_Account -> Expanded
 278 expand =
 279         Lib.TreeMap.map_by_depth_first
 280          (\descendants value ->
 281                 let exc = fromMaybe Data.Map.empty value in
 282                 Account_Sum_Expanded
 283                  { exclusive = exc
 284                  , inclusive =
 285                         Data.Map.foldr
 286                          ( Data.Map.unionWith (GHC.Num.+)
 287                          . ( inclusive
 288                                  . fromMaybe (error "Oops, should not happen in: Hcompta.Calc.Balance.expand")
 289                                  . Lib.TreeMap.node_value) )
 290                          exc $ Lib.TreeMap.nodes $ descendants
 291                  })