src/Literate/Accounting/Balance.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE PartialTypeSignatures #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 {-# LANGUAGE StandaloneDeriving #-}
   5 {-# LANGUAGE UndecidableInstances #-}
   6 {-# LANGUAGE NoMonomorphismRestriction #-}
   7 {-# LANGUAGE NoOverloadedLists #-}
   8
   9 module Literate.Accounting.Balance where
  10
  11 import Control.DeepSeq (NFData)
  12 import Data.Decimal (Decimal)
  13 import Data.Either (Either (..), lefts, rights)
  14 import Data.Eq (Eq (..))
  15 import Data.Function (id, ($), (.))
  16 import Data.Functor (Functor (..), (<$), (<$>))
  17 import Data.List qualified as List
  18 import Data.List.NonEmpty qualified as NonEmpty
  19 import Data.Map.Strict (Map)
  20 import Data.Map.Strict qualified as Map
  21 import Data.Maybe (Maybe (..), catMaybes, fromMaybe, isJust, maybe)
  22 import Data.Monoid (Monoid (..))
  23 import Data.Ord (Ord (..))
  24 import Data.Semigroup (Semigroup (..))
  25 import Data.String (String)
  26 import Data.Typeable ()
  27 import GHC.Generics (Generic)
  28 import GHC.IO.Unsafe (unsafePerformIO)
  29 import Lens.Micro
  30 import Literate.Accounting.Chart as Chart
  31 import Literate.Accounting.Flow
  32 import Literate.Accounting.Math
  33 import Literate.Accounting.Move
  34 import Literate.Accounting.Unit
  35 import System.IO (IO, writeFile)
  36 import System.IO.Unsafe
  37 import System.Random
  38 import Text.Show (Show (..))
  39 import Prelude qualified
  40
  41 --type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a)
  42
  43 -- * Type 'Balance'
  44 data Balance acct unit qty sum = Balance
  45   { balanceByAccount :: Chart acct (sum (Amounts unit qty))
  46   , balanceByUnit :: Amounts unit (SumForUnit (Account acct) qty)
  47   }
  48   deriving (Generic)
  49 deriving instance (Eq acct, Eq unit, Eq qty, Eq (sum (Amounts unit qty))) => Eq (Balance acct unit qty sum)
  50 deriving instance (Show acct, Show unit, Show qty, Show (sum (Amounts unit qty))) => Show (Balance acct unit qty sum)
  51 deriving instance (NFData acct, NFData unit, NFData qty, NFData (sum (Amounts unit qty))) => NFData (Balance acct unit qty sum)
  52 instance Zeroable (Balance acct unit qty sum) where
  53   zero = Balance (Chart Map.empty) zero
  54 instance (Ord acct, Ord unit, Addable qty, Addable (sum (Amounts unit qty))) => Addable (Balance acct unit qty sum) where
  55   Balance xa xu + Balance ya yu = Balance (xa + ya) (xu + yu)
  56
  57 tableBalance ::
  58   Ord acct =>
  59   Show acct =>
  60   Show unit =>
  61   Show qty =>
  62   Addable qty =>
  63   Balance acct unit (Flow qty) Trickle ->
  64   [[String]]
  65 tableBalance Balance{..} =
  66   Chart.foldrWithPath
  67     ( \acct Trickle{inclusive = Amounts amt} ->
  68         ( [ show acct
  69           , List.intercalate "+" $ catMaybes $ (\(u, q) -> show . (u,) <$> flowIn q) <$> Map.toList amt
  70           , List.intercalate "+" $ catMaybes $ (\(u, q) -> show . (u,) <$> flowOut q) <$> Map.toList amt
  71           --, show (unFlow <$> amt)
  72           ]
  73             :
  74         )
  75     )
  76     []
  77     balanceByAccount
  78 {-
  79 -- * Type 'BalanceReprByAccount'
  80 type BalanceReprByAccount f section unit qty =
  81   Chart.Chart section (f (SumByAccount unit qty))
  82
  83 -- ** Type 'SumByAccount'
  84 -- | A sum of quantities, concerning a single account.
  85 type SumByAccount = Map
  86
  87 -- * Type 'BalanceReprByUnit'
  88 type BalanceReprByUnit section unit qty =
  89   Map unit (SumForUnit (Chart.ChartPath section) qty)
  90 -}
  91
  92 -- ** Type 'SumForUnit'
  93
  94 {- | A sum of quantities with their 'Account's involved,
  95  concerning a single @unit@.
  96 -}
  97 data SumForUnit acct qty = SumForUnit
  98   { -- | The sum of quantities for a single @unit@.
  99     sumForUnitQuantity :: qty
 100   , -- | The accounts either involved to build 'sumForUnitQuantity',
 101     -- or *not* involved when inside a 'DeviationByUnit'.
 102     sumForUnitAccounts :: Map acct ()
 103   }
 104   deriving (Eq, Ord, Show, Generic, NFData)
 105
 106 instance Zeroable qty => Zeroable (SumForUnit acct qty) where
 107   zero = SumForUnit zero Map.empty
 108 instance (Ord acct, Addable qty) => Addable (SumForUnit acct qty) where
 109   x + y =
 110     SumForUnit
 111       (sumForUnitQuantity x + sumForUnitQuantity y)
 112       (sumForUnitAccounts x + sumForUnitAccounts y)
 113 instance (Ord acct, Negable qty) => Negable (SumForUnit acct qty) where
 114   negate x =
 115     SumForUnit
 116       { sumForUnitQuantity = negate (sumForUnitQuantity x)
 117       , sumForUnitAccounts = negate (sumForUnitAccounts x)
 118       }
 119 instance (Ord acct, Subable qty) => Subable (SumForUnit acct qty) where
 120   x - y =
 121     SumForUnit
 122       { sumForUnitQuantity = sumForUnitQuantity x - sumForUnitQuantity y
 123       , sumForUnitAccounts = sumForUnitAccounts x - sumForUnitAccounts y
 124       }
 125
 126 -- * Class 'Balanceable'
 127 class Balanceable a acct unit qty f where
 128   balance :: a -> Balance acct unit qty f
 129 instance
 130   ( Balanceable a acct unit qty f
 131   , Addable qty
 132   , Addable (f (Amounts unit qty))
 133   , Ord acct
 134   , Ord unit
 135   ) =>
 136   Balanceable [a] acct unit qty f
 137   where
 138   balance = List.foldr (\a acc -> acc + balance a) zero
 139 instance Ord acct => Balanceable (Account acct, Amounts unit qty) acct unit qty Maybe where
 140   balance (acct, amt) =
 141     Balance
 142       { balanceByAccount = Chart.singleton Nothing acct (Just amt)
 143       , balanceByUnit =
 144           Amounts $
 145             Map.map
 146               ( \qty ->
 147                   SumForUnit
 148                     { sumForUnitQuantity = qty
 149                     , sumForUnitAccounts = Map.singleton acct ()
 150                     }
 151               )
 152               $ unAmounts amt
 153       }
 154 instance Ord acct => Postable acct unit qty (Balance acct unit qty Maybe) where
 155   acct += amt =
 156     Balance
 157       { balanceByAccount = Chart.singleton Nothing acct (Just amt)
 158       , balanceByUnit =
 159           Amounts $
 160             Map.map
 161               ( \qty ->
 162                   SumForUnit
 163                     { sumForUnitQuantity = qty
 164                     , sumForUnitAccounts = Map.singleton acct ()
 165                     }
 166               )
 167               $ unAmounts amt
 168       }
 169
 170 rrr :: Prelude.Int
 171 rrr :: Prelude.Int = unsafePerformIO randomIO
 172 {- $setup
 173  >>> r :: Prelude.Int = rrr
 174 -}
 175
 176 -- >>> r
 177 -- 7388298653183775731
 178
 179 b0 :: Balance String Unit (Quantity Decimal) Maybe
 180 b0 =
 181   balance
 182     [
 183       ( "Capital" NonEmpty.:| []
 184       , Amounts (Map.singleton (Unit "$") (Quantity (540 :: Decimal)))
 185       )
 186     ,
 187       ( "Capital" NonEmpty.:| ["Banque"]
 188       , Amounts (Map.singleton (Unit "$") (Quantity (30 :: Decimal)))
 189       )
 190     ,
 191       ( "Immo" NonEmpty.:| ["Stable"]
 192       , Amounts (Map.singleton (Unit "&") (Quantity (12 :: Decimal)))
 193       )
 194     ]
 195
 196 {- >>> trickleBalance $ b0
 197 Balance {balanceByAccount = + "Capital" Trickle {exclusive = fromList [("$",540)], inclusive = fromList [("$",570)]}
 198 | ` "Banque" Trickle {exclusive = fromList [("$",30)], inclusive = fromList [("$",30)]}
 199 ` "Immo" Trickle {exclusive = fromList [], inclusive = fromList [("&",12)]}
 200   ` "Stable" Trickle {exclusive = fromList [("&",12)], inclusive = fromList [("&",12)]}
 201 , balanceByUnit = fromList [("$",SumForUnit {sumForUnitQuantity = 570, sumForUnitAccounts = fromList [("Capital" :| [],()),("Capital" :| ["Banque"],())]}),("&",SumForUnit {sumForUnitQuantity = 12, sumForUnitAccounts = fromList [("Immo" :| ["Stable"],())]})]}
 202 -}
 203
 204 data Post acct amt = Post
 205   { _postAccount :: acct
 206   , postAmounts :: amt
 207   }
 208
 209 class Accountable a section where
 210   account :: Lens' a (ChartPath section)
 211 class Amountable a unit qty where
 212   amounts :: Lens' a (Amounts unit qty)
 213
 214 --accountOf :: Functor f => (acct -> f acct) -> (Post acct amt) -> f (Post acct amt)
 215 -- accountOf k post = fmap (\newAccount -> post { _postAccount = newAccount }) (k (_postAccount post))
 216
 217 -- postAccount :: Lens' (Post acct amt) acct
 218 --postAccount :: Functor f => (acct -> f acct) -> (Post acct amt) -> f (Post acct amt)
 219 -- postAccount k post = fmap (\newAccount -> post { _postAccount = newAccount }) (k (_postAccount post))
 220
 221 -- type instance AccountOf (Post acct amt) = acct
 222 type instance AccountSectionOf (Post acct amt) = AccountSectionOf acct
 223 type instance AmountOf (Post acct amt) = amt
 224 type instance UnitOf (Post acct amt) = UnitOf amt
 225 type instance QuantityOf (Post acct amt) = QuantityOf amt
 226 type instance QuantityOf (Maybe a) = QuantityOf a
 227 type instance UnitOf (Maybe a) = UnitOf a
 228
 229 {-
 230 newtype Amount unit qty = Amount (unit, qty)
 231 type instance UnitOf (Amount unit qty) = unit
 232 type instance QuantityOf (Amount unit qty) = qty
 233 -}
 234
 235 -- type instance AccountSectionOf (Account accountSection) = accountSection
 236
 237 -- ** BalanceRepr 'equilibrium'
 238
 239 {- | Return the 'BalanceRepr' (adjusted by inferred quantities)
 240    of the given @post@s and either:
 241
 242    * 'Left': the @unit@s which have a non null 'SumForUnit'
 243              and for which no equibrating account can be inferred.
 244    * 'Right': the given @post@s with inferred quantities inserted.
 245 -}
 246 equilibrium ::
 247   forall post unit qty amt acct.
 248   Balanceable post acct unit qty Maybe =>
 249   Nullable qty =>
 250   Addable qty =>
 251   Negable qty =>
 252   Ord unit =>
 253   Ord acct =>
 254   Accountable post acct =>
 255   Amountable post unit qty =>
 256   [post] ->
 257   Either
 258     [(unit, SumForUnit (Account acct) qty)]
 259     [post]
 260 equilibrium posts =
 261   let Balance{..} :: Balance acct unit qty Maybe = balance posts
 262    in let balanceAccounts = Map.filter isJust $ Chart.flatten id balanceByAccount
 263        in let eithers =
 264                 Map.foldrWithKey
 265                   ( \unt sfu@SumForUnit{..} ->
 266                       let unusedAccounts = balanceAccounts `Map.difference` sumForUnitAccounts
 267                        in case Map.size unusedAccounts of
 268                             0 | null sumForUnitQuantity -> id
 269                             1 ->
 270                               -- The quantity can be inferred since having an equilibrated balance
 271                               -- means it must be the opposite of the quantity for that unit on other accounts.
 272                               (:) $
 273                                 Right $
 274                                   Amounts (Map.singleton unt (negate sumForUnitQuantity))
 275                                     <$ Map.elemAt 0 unusedAccounts
 276                             _ ->
 277                               -- There is more than one account not specifying a quantity for that unit
 278                               -- hence those cannot be inferred.
 279                               (:) $ Left (unt, sfu)
 280                   )
 281                   []
 282                   (unAmounts balanceByUnit)
 283            in case lefts eithers of
 284                 [] ->
 285                   Right $
 286                     let inferredPosts = Map.fromListWith (+) $ rights eithers
 287                      in ( \post ->
 288                             case Map.lookup (post ^. account) inferredPosts of
 289                               Nothing -> post
 290                               Just inferredAmounts -> post & amounts %~ (+ inferredAmounts)
 291                         )
 292                           <$> posts
 293                 ls -> Left ls
 294
 295 {-
 296 -- | Return 'True' if and only if the given 'DeviationByUnit' maps no @unit@.
 297 isEquilibrium :: DeviationByUnit section unit qty -> Bool
 298 isEquilibrium (DeviationByUnit dev) = Map.null dev
 299
 300 -- | Return 'True' if and only if the given 'DeviationByUnit'
 301 -- maps only to 'SumForUnit's whose 'sumForUnitAccounts'
 302 -- maps exactly one account.
 303 isEquilibriumInferrable :: DeviationByUnit section unit qty -> Bool
 304 isEquilibriumInferrable (DeviationByUnit dev) =
 305   Fold.all ((== 1) . Map.size . sumForUnitAccounts) dev
 306
 307 -- | {Ex,In}clusive 'BalanceReprByAccount':
 308 -- descending propagation of quantities accross accounts.
 309 -}
 310
 311 -- * Type 'Trickle'
 312
 313 -- A data type to calculate an 'inclusive' value
 314 -- (through some propagation mecanism,
 315 -- eg. incorporating the values of the children of a tree node),
 316 -- while keeping the original 'exclusive' value
 317 -- (eg. the original value of a tree node).
 318 --
 319
 320 -- * 'exclusive': contains the original 'SumByAccount'.
 321
 322 -- * 'inclusive': contains ('+') folded
 323
 324 --   over 'exclusive' and 'inclusive' of children.
 325 data Trickle amt = Trickle
 326   { exclusive :: amt
 327   , inclusive :: amt
 328   }
 329   deriving (Eq, Show, Generic, NFData)
 330 type instance QuantityOf (Trickle amt) = QuantityOf amt
 331 type instance UnitOf (Trickle amt) = UnitOf amt
 332 instance Semigroup a => Semigroup (Trickle a) where
 333   Trickle e0 i0 <> Trickle e1 i1 =
 334     Trickle (e0 <> e1) (i0 <> i1)
 335 instance Monoid a => Monoid (Trickle a) where
 336   mempty = Trickle mempty mempty
 337   mappend = (<>)
 338
 339 --type instance Ty (Trickle amt) TyUnit = Ty amt TyUnit
 340 --type instance Ty (Trickle amt) TyQuantity = Ty amt TyQuantity
 341 instance Addable amt => Addable (Trickle amt) where
 342   x + y =
 343     Trickle
 344       { exclusive = exclusive x + exclusive y
 345       , inclusive = inclusive x + inclusive y
 346       }
 347
 348 {- | Return the given 'Balance' with:
 349
 350  * all missing parent accounts inserted;
 351  * and every mapped 'Amounts' added with any 'Amounts'
 352    of the account for which it is a parent.
 353 -}
 354 trickleBalance ::
 355   Ord acct =>
 356   Ord unit =>
 357   Addable qty =>
 358   Balance acct unit qty Maybe ->
 359   Balance acct unit qty Trickle
 360 trickleBalance bal =
 361   bal
 362     { balanceByAccount =
 363         Chart.mapByDepthFirst
 364           ( \(Chart ch) a ->
 365               let exclusive = fromMaybe zero a
 366                in Trickle
 367                     { exclusive
 368                     , inclusive = Map.foldr (\(sba, _ch) -> (+ inclusive sba)) exclusive ch
 369                     }
 370           )
 371           (balanceByAccount bal)
 372     }