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