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.union (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.union (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.union (accounts x) (accounts y)
 190                          })
 191                  (by_unit b0)
 192                  (by_unit b1)
 193          }
 194
 195 -- * The 'Equilibre' type
 196
 197 -- | See 'equilibre'.
 198 newtype Equilibre
 199  =      Equilibre By_Unit
 200  deriving (Data, Eq, Read, Show, Typeable)
 201
 202 -- | Return the 'by_unit' of the given 'Balance' with:
 203 --
 204 -- * 'Unit's whose 'Unit_Sum' 'amount' verifying 'Amount.is_zero' removed,
 205 --
 206 -- * and remaining 'Unit's having their 'Unit_Sum' 'accounts'
 207 -- complemented with the 'by_account' of the given 'Balance'
 208 -- (i.e. now mapping to accounts __not__ involved to build the 'Unit_Sum').
 209 equilibre :: Balance -> Equilibre
 210 equilibre balance = do
 211         let all_accounts = Lib.TreeMap.flatten (const ()) (by_account balance)
 212         let max_accounts = Data.Map.size all_accounts
 213         Equilibre $
 214                 Data.Map.foldlWithKey
 215                  (\m unit Unit_Sum{amount, accounts} ->
 216                         if Amount.is_zero amount
 217                         then m
 218                         else
 219                                 case Data.Map.size accounts of
 220                                  n | n == max_accounts ->
 221                                         Data.Map.insert unit Unit_Sum{amount, accounts=Data.Map.empty} m
 222                                  _ -> do
 223                                         let diff = Data.Map.difference all_accounts accounts
 224                                         Data.Map.insert unit Unit_Sum{amount, accounts=diff} m
 225                  )
 226                  Data.Map.empty
 227                  (by_unit balance)
 228
 229
 230 -- | Return either:
 231 --
 232 --   * 'Left': the 'Posting.By_Account's (lazy list) that cannot be inferred
 233 --   * 'Right': the given 'Posting.By_Account's with inferred 'Amount's inserted.
 234 infer_equilibre
 235  :: Posting.By_Account
 236  -> Either [Unit_Sum]
 237            Posting.By_Account
 238 infer_equilibre ps = do
 239         let bal = postings ps nil
 240         let Equilibre equ = equilibre bal
 241         (\(l, r) -> case l of
 242                  _:_ -> Left l
 243                  _   -> Right r) $ do
 244         Lib.Foldable.accumLeftsAndFoldrRights
 245          (\p -> Data.Map.insertWith
 246                  (\pn -> (++) pn . Data.List.filter (not . Data.Map.null . Posting.amounts))
 247                  (Posting.account p) [p])
 248          ps $ do
 249         Data.Foldable.foldr
 250          (\unit_sum@(Unit_Sum{ amount=amt, accounts }) acc ->
 251                 case Data.Map.size accounts of
 252                  0 -> acc
 253                  1 -> (Right $ (Posting.nil $ fst $ Data.Map.elemAt 0 accounts)
 254                                  { Posting.amounts = Amount.from_List [negate amt] }
 255                          ):acc
 256                  _ -> Left [unit_sum]:acc
 257          )
 258          []
 259          equ
 260
 261 -- ** Tests
 262
 263 -- | Return 'True' if and only if the given 'Equilibre' satisfies:
 264 --
 265 -- * 'is_equilibrated',
 266 -- * or 'is_inferrable'.
 267 is_equilibrable :: Equilibre -> Bool
 268 is_equilibrable e@(Equilibre eq) =
 269         Data.Map.null eq || is_inferrable e
 270
 271 -- | Return 'True' if and only if the given 'Equilibre' maps no 'Unit'.
 272 is_equilibrated :: Equilibre -> Bool
 273 is_equilibrated (Equilibre eq) = Data.Map.null eq
 274
 275 -- | Return 'True' if and only if the given 'Equilibre'
 276 -- maps only to 'Unit_Sum's whose 'accounts'
 277 -- maps exactly one 'Account'.
 278 is_inferrable :: Equilibre -> Bool
 279 is_inferrable (Equilibre eq) =
 280         Data.Foldable.all
 281          (\Unit_Sum{accounts} -> Data.Map.size accounts == 1)
 282          eq
 283
 284 -- | Return 'True' if and only if the given 'Equilibre'
 285 -- maps to at least one 'Unit_Sum's whose 'accounts'
 286 -- maps more than one 'Account'.
 287 is_non_inferrable :: Equilibre -> Bool
 288 is_non_inferrable (Equilibre eq) =
 289         Data.Foldable.any
 290          (\Unit_Sum{accounts} -> Data.Map.size accounts > 1)
 291          eq
 292
 293 -- * The 'Expanded' type
 294
 295 -- | See 'expand'.
 296 type Expanded = Lib.TreeMap.TreeMap Account.Name Account_Sum_Expanded
 297 data Account_Sum_Expanded
 298  =   Account_Sum_Expanded
 299  { inclusive :: Amount.By_Unit
 300  , exclusive :: Amount.By_Unit
 301  }
 302  deriving (Data, Eq, Read, Show, Typeable)
 303
 304 -- | Return the given 'By_Account' with:
 305 --
 306 -- * all missing 'Account.ascending' 'Account's inserted,
 307 --
 308 -- * and every mapped Amount.'Amount.By_Unit'
 309 -- added with any Amount.'Amount.By_Unit'
 310 -- of the 'Account's’ for which it is 'Account.ascending'.
 311 expand :: By_Account -> Expanded
 312 expand =
 313         Lib.TreeMap.map_by_depth_first
 314          (\descendants value ->
 315                 let exc = fromMaybe Data.Map.empty value in
 316                 Account_Sum_Expanded
 317                  { exclusive = exc
 318                  , inclusive =
 319                         Data.Map.foldr
 320                          ( Data.Map.unionWith (GHC.Num.+)
 321                          . ( inclusive
 322                                  . fromMaybe (error "Oops, should not happen in: Hcompta.Calc.Balance.expand")
 323                                  . Lib.TreeMap.node_value) )
 324                          exc $ Lib.TreeMap.nodes $ descendants
 325                  })