src/Symantic/Compta/Calc/Balance.hs

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