src/Literate/Accounting/Balance.hs

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