lib/Hcompta/Calc/Balance.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 module Hcompta.Calc.Balance where
   6
   7 import           Data.Data
   8 import qualified Data.Foldable
   9 import           Data.Foldable (Foldable(..))
  10 import qualified Data.List
  11 import qualified Data.Map.Strict as Data.Map
  12 import           Data.Map.Strict (Map)
  13 import           Data.Maybe (fromMaybe)
  14 import           Data.Typeable ()
  15
  16 import qualified Hcompta.Lib.Foldable as Lib.Foldable
  17 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  18 import           Hcompta.Lib.TreeMap (TreeMap)
  19 import qualified Hcompta.Model.Account as Account
  20 import           Hcompta.Model.Account (Account)
  21
  22 -- * The 'Posting' class
  23
  24 -- | A 'posting' used to produce a 'Balance'
  25 --   must be an instance of this class.
  26 class
  27  ( Ord (Posting_Unit p)
  28  , Num (Posting_Amount p)
  29  ) =>
  30  Posting p where
  31         type Posting_Amount p
  32         type Posting_Unit p
  33         posting_account :: p -> Account
  34         posting_amounts :: p -> Map (Posting_Unit p) (Posting_Amount p)
  35         posting_make    :: Account -> Map (Posting_Unit p) (Posting_Amount p) -> p
  36
  37 -- * The 'Balance' type
  38
  39 -- | Sum by 'Account' and sum by 'unit' of some 'Posting's.
  40 data Balance amount unit
  41  =   Balance
  42  { balance_by_account :: Balance_by_Account amount unit
  43  , balance_by_unit    :: Balance_by_Unit amount unit
  44  } deriving (Data, Eq, Show, Typeable)
  45
  46 type Balance_by_Account amount unit
  47  = TreeMap Account.Name
  48            (Account_Sum amount unit)
  49
  50 -- | A sum of 'amount's,
  51 -- concerning a single 'Account'.
  52 type Account_Sum amount unit
  53  = Data.Map.Map unit amount
  54
  55 type Balance_by_Unit amount unit
  56  = Map unit (Unit_Sum amount)
  57
  58 -- | A sum of 'amount's with their 'Account's involved,
  59 -- concerning a single 'unit'.
  60 data Unit_Sum amount
  61  =   Unit_Sum
  62  { unit_sum_amount   :: amount -- ^ The sum of 'amount's for a single 'unit'.
  63  , unit_sum_accounts :: Map Account () -- ^ The 'Account's involved to build 'unit_sum_amount'.
  64  } deriving (Data, Eq, Show, Typeable)
  65
  66 -- ** Constructors
  67
  68 balance :: (Num amount, Ord unit) => Balance amount unit
  69 balance =
  70         Balance
  71          { balance_by_account = Lib.TreeMap.empty
  72          , balance_by_unit    = Data.Map.empty
  73          }
  74
  75 -- | Return the given 'Balance'
  76 --   updated by the given 'Posting'.
  77 posting ::
  78  ( Posting posting
  79  , unit   ~ Posting_Unit posting
  80  , amount ~ Posting_Amount posting
  81  ) => posting -> Balance amount unit -> Balance amount unit
  82 posting post bal =
  83         bal
  84          { balance_by_account =
  85                 Lib.TreeMap.insert
  86                  (Data.Map.unionWith (flip (+)))
  87                  (posting_account post)
  88                  (posting_amounts post)
  89                  (balance_by_account bal)
  90          , balance_by_unit =
  91                 Data.Map.unionWith
  92                  (\new old -> Unit_Sum
  93                          { unit_sum_amount   = (+)
  94                                  (unit_sum_amount old)
  95                                  (unit_sum_amount new)
  96                          , unit_sum_accounts = Data.Map.unionWith
  97                                  (const::()->()->())
  98                                  (unit_sum_accounts old)
  99                                  (unit_sum_accounts new)
 100                          })
 101                  (balance_by_unit bal) $
 102                 Data.Map.map
 103                  (\amount -> Unit_Sum
 104                          { unit_sum_amount   = amount
 105                          , unit_sum_accounts = Data.Map.singleton (posting_account post) ()
 106                          })
 107                  (posting_amounts post)
 108          }
 109
 110 -- | Return the given 'Balance'
 111 --   updated by the given 'Posting's.
 112 postings ::
 113  ( Posting posting
 114  , unit   ~ Posting_Unit   posting
 115  , amount ~ Posting_Amount posting
 116  , Foldable foldable )
 117  => foldable posting
 118  -> Balance amount unit
 119  -> Balance amount unit
 120 postings = flip (Data.Foldable.foldr posting)
 121
 122 -- | Return the first given 'Balance'
 123 --   updated by the second given 'Balance'.
 124 union
 125  :: (Num amount, Ord unit)
 126  => Balance amount unit
 127  -> Balance amount unit
 128  -> Balance amount unit
 129 union b0 b1 =
 130         b0
 131          { balance_by_account =
 132                 Lib.TreeMap.union
 133                  (Data.Map.unionWith (flip (+)))
 134                  (balance_by_account b0)
 135                  (balance_by_account b1)
 136          , balance_by_unit =
 137                 Data.Map.unionWith
 138                  (\new old -> Unit_Sum
 139                          { unit_sum_amount = (+)
 140                                  (unit_sum_amount old)
 141                                  (unit_sum_amount new)
 142                          , unit_sum_accounts = Data.Map.unionWith
 143                                  (const::()->()->())
 144                                  (unit_sum_accounts old)
 145                                  (unit_sum_accounts new)
 146                          })
 147                  (balance_by_unit b0)
 148                  (balance_by_unit b1)
 149          }
 150
 151 -- * The 'Deviation' type
 152
 153 -- | The 'Balance_by_Unit' whose 'unit_sum_amount'
 154 --   is not zero and possible 'Account' to 'infer_equilibrium'.
 155 newtype Deviation amount unit
 156  =      Deviation (Balance_by_Unit amount unit)
 157  deriving (Data, Eq, Show, Typeable)
 158
 159 -- | Return the 'balance_by_unit' of the given 'Balance' with:
 160 --
 161 -- * 'unit's whose 'unit_sum_amount' verifying 'amount_is_zero' removed,
 162 --
 163 -- * and remaining 'unit's having their 'unit_sum_accounts'
 164 -- complemented with the 'balance_by_account' of the given 'Balance'
 165 -- (i.e. now mapping to 'Account's __not__ involved to build the 'Unit_Sum').
 166 deviation
 167  :: (Amount amount, Ord unit)
 168  => Balance amount unit
 169  -> Deviation amount unit
 170 deviation bal = do
 171         let all_accounts = Lib.TreeMap.flatten (const ()) (balance_by_account bal)
 172         let max_accounts = Data.Map.size all_accounts
 173         Deviation $
 174                 Data.Map.foldlWithKey
 175                  (\m unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
 176                         if amount_is_zero unit_sum_amount
 177                         then m
 178                         else
 179                                 case Data.Map.size unit_sum_accounts of
 180                                  n | n == max_accounts ->
 181                                         Data.Map.insert unit Unit_Sum
 182                                          { unit_sum_amount
 183                                          , unit_sum_accounts = Data.Map.empty
 184                                          } m
 185                                  _ -> do
 186                                         let diff = Data.Map.difference all_accounts unit_sum_accounts
 187                                         Data.Map.insert unit Unit_Sum
 188                                          { unit_sum_amount
 189                                          , unit_sum_accounts = diff
 190                                          } m
 191                  )
 192                  Data.Map.empty
 193                  (balance_by_unit bal)
 194
 195 -- ** The 'Amount' class
 196
 197 -- | An 'amount' used to produce a 'Deviation'
 198 --   must be an instance of this class.
 199 class
 200  Num a =>
 201  Amount a where
 202         amount_is_zero :: a -> Bool
 203
 204 -- ** The equilibrium
 205
 206 -- | Return the 'Balance' of the given 'Posting's and either:
 207 --
 208 --   * 'Left': the 'Posting's that cannot be inferred.
 209 --   * 'Right': the given 'Posting's with inferred 'amount's inserted.
 210 infer_equilibrium ::
 211  ( Posting posting
 212  , Amount amount
 213  , Ord unit
 214  , amount ~ Posting_Amount posting
 215  , unit   ~ Posting_Unit   posting )
 216  => Map Account [posting]
 217  -> ( Balance amount unit
 218     , Either [Unit_Sum amount] (Map Account [posting])
 219     )
 220 infer_equilibrium ps = do
 221         let bal = flip (Data.Foldable.foldr postings) ps balance
 222         let Deviation dev = deviation bal
 223         (\(l, r) -> (bal, case l of { [] -> Right r; _ -> Left l })) $ do
 224         Lib.Foldable.accumLeftsAndFoldrRights
 225          (\p -> Data.Map.insertWith
 226                  (\pn -> (++) pn . Data.List.filter (not . Data.Map.null . posting_amounts))
 227                  (posting_account p) [p])
 228          ps $ do
 229         Data.Map.foldrWithKey
 230          (\unit unit_sum@(Unit_Sum{ unit_sum_amount=amt, unit_sum_accounts }) acc ->
 231                 case Data.Map.size unit_sum_accounts of
 232                  1 -> (Right $ (posting_make $ fst $ Data.Map.elemAt 0 unit_sum_accounts) (Data.Map.singleton unit (negate amt))):acc
 233                  _ -> Left [unit_sum]:acc)
 234          []
 235          dev
 236
 237 -- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
 238 is_at_equilibrium :: Deviation amount unit -> Bool
 239 is_at_equilibrium (Deviation dev) = Data.Map.null dev
 240
 241 -- | Return 'True' if and only if the given 'Deviation'
 242 -- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
 243 -- maps exactly one 'Account'.
 244 is_equilibrium_inferrable :: Deviation amount unit -> Bool
 245 is_equilibrium_inferrable (Deviation dev) =
 246         Data.Foldable.all
 247          (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
 248          dev
 249
 250 -- | Return 'True' if and only if the given 'Deviation'
 251 -- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
 252 -- maps more than one 'Account'.
 253 is_equilibrium_non_inferrable :: Deviation amount unit -> Bool
 254 is_equilibrium_non_inferrable (Deviation dev) =
 255         Data.Foldable.any
 256          (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
 257          dev
 258
 259 -- * The 'Expanded' type
 260
 261 -- | Descending propagation of 'amount's accross 'Account's.
 262 type Expanded amount unit
 263  = TreeMap Account.Name
 264            (Account_Sum_Expanded amount unit)
 265 data Account_Sum_Expanded amount unit
 266  =   Account_Sum_Expanded
 267  { inclusive :: Map unit amount
 268  , exclusive :: Map unit amount
 269  }
 270  deriving (Data, Eq, Show, Typeable)
 271
 272 -- | Return the given 'Balance_by_Account' with:
 273 --
 274 -- * all missing 'Account.ascending' 'Account's inserted,
 275 --
 276 -- * and every mapped 'amount'
 277 -- added with any 'amount'
 278 -- of the 'Account's’ for which it is 'Account.ascending'.
 279 expanded ::
 280  ( Num amount, Ord unit )
 281  => Balance_by_Account amount unit
 282  -> Expanded amount unit
 283 expanded =
 284         Lib.TreeMap.map_by_depth_first
 285          (\descendants value ->
 286                 let exc = fromMaybe Data.Map.empty value in
 287                 Account_Sum_Expanded
 288                  { exclusive = exc
 289                  , inclusive =
 290                         Data.Map.foldr
 291                          ( Data.Map.unionWith (flip (+))
 292                          . ( inclusive
 293                                  . fromMaybe (error "Oops, should not happen in: Hcompta.Calc.Balance.expanded")
 294                                  . Lib.TreeMap.node_value) )
 295                          exc $ Lib.TreeMap.nodes $ descendants
 296                  })