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.Foldable
  12 import           Data.Typeable ()
  13 import           Data.Maybe (fromMaybe)
  14 import qualified GHC.Num
  15
  16 import qualified Hcompta.Model as Model ()
  17 import qualified Hcompta.Model.Account as Account
  18 import qualified Hcompta.Lib.Foldable as Lib.Foldable
  19 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  20 import           Hcompta.Model.Account (Account)
  21 import qualified Hcompta.Model.Amount as Amount
  22 import           Hcompta.Model.Amount (Amount, Unit)
  23 import qualified Hcompta.Model.Transaction as Transaction
  24 import           Hcompta.Model.Transaction (Transaction, Posting)
  25 import qualified Hcompta.Model.Transaction.Posting as Posting
  26 import qualified Hcompta.Model.Journal as Journal
  27 import           Hcompta.Model.Journal (Journal)
  28
  29 -- * The 'Balance' type
  30
  31 -- | Sum by 'Account' and sum by 'Unit' of some 'Posting's.
  32 data Balance
  33  =   Balance
  34  { by_account :: By_Account
  35  , by_unit    :: By_Unit
  36  } deriving (Data, Eq, Read, Show, Typeable)
  37
  38 type By_Account
  39  = Lib.TreeMap.TreeMap Account.Name Account_Sum
  40 -- | A sum of 'Amount's,
  41 -- concerning a single 'Account'.
  42 type Account_Sum
  43  = Amount.By_Unit
  44
  45 type By_Unit
  46  = Map Amount.Unit Unit_Sum
  47 -- | A sum of 'Amount's with their 'Account's involved,
  48 -- concerning a single 'Unit'.
  49 data Unit_Sum
  50  =   Unit_Sum
  51  { amount   :: Amount -- ^ The sum of 'Amount's for a single 'Unit'.
  52  , accounts :: Map Account () -- ^ The 'Account's involved to build 'amount'.
  53  } deriving (Data, Eq, Read, Show, Typeable)
  54
  55 -- ** Constructors
  56
  57 nil :: Balance
  58 nil =
  59         Balance
  60          { by_account = Lib.TreeMap.empty
  61          , by_unit    = Data.Map.empty
  62          }
  63
  64 nil_By_Account :: By_Account
  65 nil_By_Account =
  66         Lib.TreeMap.empty
  67
  68 nil_By_Unit :: By_Unit
  69 nil_By_Unit =
  70         Data.Map.empty
  71
  72 nil_Account_Sum :: Account_Sum
  73 nil_Account_Sum =
  74         Data.Map.empty
  75
  76 nil_Unit_Sum :: Unit_Sum
  77 nil_Unit_Sum =
  78         Unit_Sum
  79          { accounts = Data.Map.empty
  80          , amount = Amount.nil
  81          }
  82
  83 -- | Return a tuple associating the given 'Unit_Sum' with its 'Unit'.
  84 assoc_unit_sum :: Unit_Sum -> (Unit, Unit_Sum)
  85 assoc_unit_sum s = (Amount.unit $ amount s, s)
  86
  87 -- | Return a 'Map' associating the given 'Unit_Sum' with their respective 'Unit'.
  88 by_Unit_from_List :: [Unit_Sum] -> By_Unit
  89 by_Unit_from_List balances =
  90         Data.Map.fromListWith
  91          (\x y -> Unit_Sum
  92                  { amount=(GHC.Num.+) (amount x) (amount y)
  93                  , accounts=Data.Map.unionWith (const::()->()->()) (accounts x) (accounts y)
  94                  }) $
  95         Data.List.map assoc_unit_sum balances
  96
  97 -- ** Incremental constructors
  98
  99 -- | Return the given 'Balance'
 100 --   updated by the given 'Posting'.
 101 posting :: Posting -> Balance -> Balance
 102 posting post balance =
 103         balance
 104          { by_account =
 105                 Lib.TreeMap.insert
 106                  (Data.Map.unionWith (GHC.Num.+))
 107                  (Posting.account post)
 108                  (Posting.amounts post)
 109                  (by_account balance)
 110          , by_unit =
 111                 Data.Map.unionWith
 112                  (\x y -> Unit_Sum
 113                          { amount   = (GHC.Num.+) (amount x) (amount y)
 114                          , accounts = Data.Map.unionWith (const::()->()->()) (accounts x) (accounts y)
 115                          })
 116                  (by_unit balance) $
 117                 Data.Map.map
 118                  (\amount -> Unit_Sum
 119                          { amount
 120                          , accounts = Data.Map.singleton (Posting.account post) ()
 121                          })
 122                  (Posting.amounts post)
 123          }
 124
 125 -- | Return the given 'Balance'
 126 --   updated by the given 'Posting's.
 127 postings :: (Foldable to, Foldable ti) => to (ti Posting) -> Balance -> Balance
 128 postings = flip $ Data.Foldable.foldr (flip (Data.Foldable.foldr posting))
 129
 130 -- | Return the given 'Balance'
 131 --   updated by the 'Transaction.postings'
 132 --   of the given 'Transaction'.
 133 transaction :: Transaction -> Balance -> Balance
 134 transaction = postings . Transaction.postings
 135
 136 -- | Return the given 'Balance'
 137 --   updated by the 'Transaction.postings'
 138 --   and 'Transaction.virtual_postings'
 139 --   and 'Transaction.balanced_virtual_postings'
 140 --   of the given 'Transaction'.
 141 transaction_with_virtual :: Transaction -> Balance -> Balance
 142 transaction_with_virtual tr =
 143         postings (Transaction.balanced_virtual_postings tr) .
 144         postings (Transaction.virtual_postings tr) .
 145         postings (Transaction.postings tr)
 146
 147 -- | Return the given 'Balance'
 148 --   updated by the 'Transaction.balanced_virtual_postings' of the given 'Transaction'.
 149 transaction_balanced_virtual :: Transaction -> Balance -> Balance
 150 transaction_balanced_virtual =
 151         postings . Transaction.balanced_virtual_postings
 152
 153 -- | Return the given 'Balance'
 154 --   updated by the 'Journal.transactions'
 155 --   of the given 'Journal',
 156 --   through 'transaction'.
 157 journal :: Journal -> Balance -> Balance
 158 journal jour balance =
 159         Data.Map.foldl
 160          (Data.List.foldl (flip transaction))
 161          balance
 162          (Journal.transactions jour)
 163
 164 -- | Return the given 'Balance'
 165 --   updated by the 'Journal.transactions'
 166 --   of the given 'Journal',
 167 --   through 'transaction'.
 168 journal_with_virtual :: Journal -> Balance -> Balance
 169 journal_with_virtual jour balance =
 170         Data.Map.foldl
 171          (Data.List.foldl (flip transaction_with_virtual))
 172          balance
 173          (Journal.transactions jour)
 174
 175 -- | Return the first given 'Balance'
 176 --   updated by the second given 'Balance'.
 177 union :: Balance -> Balance -> Balance
 178 union b0 b1 =
 179         b0
 180          { by_account =
 181                 Lib.TreeMap.union
 182                  (Data.Map.unionWith (GHC.Num.+))
 183                  (by_account b0)
 184                  (by_account b1)
 185          , by_unit =
 186                 Data.Map.unionWith
 187                  (\x y -> Unit_Sum
 188                          { amount = (GHC.Num.+) (amount x) (amount y)
 189                          , accounts = Data.Map.unionWith (const::()->()->()) (accounts x) (accounts y)
 190                          })
 191                  (by_unit b0)
 192                  (by_unit b1)
 193          }
 194
 195 -- * The 'Deviation' type
 196
 197 -- | The 'By_Unit' whose 'Unit_Sum's’ 'amount'
 198 --   is not zero and possible 'Account' to 'infer_equilibrium'.
 199 newtype Deviation
 200  =      Deviation 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 deviation :: Balance -> Deviation
 211 deviation balance = do
 212         let all_accounts = Lib.TreeMap.flatten (const ()) (by_account balance)
 213         let max_accounts = Data.Map.size all_accounts
 214         Deviation $
 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 -- | Return the 'Balance' of the given 'Posting's and either:
 231 --
 232 --   * 'Left': the 'Posting's that cannot be inferred.
 233 --   * 'Right': the given 'Posting's with inferred 'Amount's inserted.
 234 infer_equilibrium
 235  :: Posting.By_Account
 236  -> (Balance, Either [Unit_Sum] Posting.By_Account)
 237 infer_equilibrium ps = do
 238         let bal = postings ps nil
 239         let Deviation dev = deviation bal
 240         (\(l, r) -> (bal, case l of { [] -> Right r; _ -> Left l })) $ do
 241         Lib.Foldable.accumLeftsAndFoldrRights
 242          (\p -> Data.Map.insertWith
 243                  (\pn -> (++) pn . Data.List.filter (not . Data.Map.null . Posting.amounts))
 244                  (Posting.account p) [p])
 245          ps $ do
 246         Data.Foldable.foldr
 247          (\unit_sum@(Unit_Sum{ amount=amt, accounts }) acc ->
 248                 case Data.Map.size accounts of
 249                  1 -> (Right $ (Posting.nil $ fst $ Data.Map.elemAt 0 accounts)
 250                          { Posting.amounts = Amount.from_List [negate amt] }):acc
 251                  _ -> Left [unit_sum]:acc)
 252          []
 253          dev
 254
 255 -- ** Tests
 256
 257 -- | Return 'True' if and only if the given 'Deviation' maps no 'Unit'.
 258 is_at_equilibrium :: Deviation -> Bool
 259 is_at_equilibrium (Deviation dev) = Data.Map.null dev
 260
 261 -- | Return 'True' if and only if the given 'Deviation'
 262 -- maps only to 'Unit_Sum's whose 'accounts'
 263 -- maps exactly one 'Account'.
 264 is_equilibrium_inferrable :: Deviation -> Bool
 265 is_equilibrium_inferrable (Deviation dev) =
 266         Data.Foldable.all
 267          (\Unit_Sum{accounts} -> Data.Map.size accounts == 1)
 268          dev
 269
 270 -- | Return 'True' if and only if the given 'Deviation'
 271 -- maps to at least one 'Unit_Sum's whose 'accounts'
 272 -- maps more than one 'Account'.
 273 is_equilibrium_non_inferrable :: Deviation -> Bool
 274 is_equilibrium_non_inferrable (Deviation dev) =
 275         Data.Foldable.any
 276          (\Unit_Sum{accounts} -> Data.Map.size accounts > 1)
 277          dev
 278
 279 -- * The 'Expanded' type
 280
 281 -- | Descending propagation of 'Amount's accross 'Account's.
 282 type Expanded = Lib.TreeMap.TreeMap Account.Name Account_Sum_Expanded
 283 data Account_Sum_Expanded
 284  =   Account_Sum_Expanded
 285  { inclusive :: Amount.By_Unit
 286  , exclusive :: Amount.By_Unit
 287  }
 288  deriving (Data, Eq, Read, Show, Typeable)
 289
 290 -- | Return the given 'By_Account' with:
 291 --
 292 -- * all missing 'Account.ascending' 'Account's inserted,
 293 --
 294 -- * and every mapped Amount.'Amount.By_Unit'
 295 -- added with any Amount.'Amount.By_Unit'
 296 -- of the 'Account's’ for which it is 'Account.ascending'.
 297 expanded :: By_Account -> Expanded
 298 expanded =
 299         Lib.TreeMap.map_by_depth_first
 300          (\descendants value ->
 301                 let exc = fromMaybe Data.Map.empty value in
 302                 Account_Sum_Expanded
 303                  { exclusive = exc
 304                  , inclusive =
 305                         Data.Map.foldr
 306                          ( Data.Map.unionWith (GHC.Num.+)
 307                          . ( inclusive
 308                                  . fromMaybe (error "Oops, should not happen in: Hcompta.Calc.Balance.expanded")
 309                                  . Lib.TreeMap.node_value) )
 310                          exc $ Lib.TreeMap.nodes $ descendants
 311                  })