src/Literate/Accounting/Balance.hs

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