src/Symantic/Compta/Norm/PCG/Journal.hs

   1 {-# OPTIONS_GHC -Wno-missing-signatures #-}
   2 {-# OPTIONS_GHC -Wno-unused-do-bind #-}
   3 {-# OPTIONS_GHC -Wno-orphans #-}
   4 {-# OPTIONS_GHC -Wno-unused-imports #-}
   5 {-# OPTIONS_GHC -Wno-name-shadowing #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7 --{-# LANGUAGE QualifiedDo #-}
   8 module Symantic.Compta.Norm.PCG.Journal where
   9
  10 import Control.Applicative (Applicative(..), liftA2)
  11 import Control.DeepSeq (NFData)
  12 import Control.Monad (Monad(..), forM)
  13 import Data.Bool
  14 import Data.Decimal (Decimal)
  15 import Data.Either (Either(..))
  16 import Data.Eq (Eq(..))
  17 import Data.Function (($), (.), id)
  18 import Data.Functor (Functor, (<$>), (<$))
  19 import Data.Hashable (Hashable)
  20 import Data.Kind (Type)
  21 import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
  22 import Data.Map.Strict (Map)
  23 import Data.Maybe (Maybe(..), maybeToList)
  24 import Data.Monoid (Monoid(..), Endo(..))
  25 import Data.Ord (Ord(..))
  26 import Data.Semigroup (Semigroup(..))
  27 import Data.String (String)
  28 import Data.Tuple (uncurry)
  29 import GHC.Generics (Generic)
  30 import GHC.Stack (HasCallStack)
  31 import GHC.TypeLits (Symbol)
  32 import Numeric.Natural (Natural)
  33 import Prelude (error)
  34 import Text.Show (Show(..), showString)
  35 import qualified Control.Monad as Monad (Monad(..), forM)
  36 import qualified Control.Monad.Trans.Class as MT
  37 import qualified Control.Monad.Trans.Reader as MT
  38 import qualified Control.Monad.Trans.State as MT
  39 import qualified Control.Monad.Trans.Writer as MT
  40 import qualified Data.Char as Char
  41 import qualified Data.Foldable as Foldable
  42 import qualified Data.HashMap.Strict as HashMap
  43 import qualified Data.List as List
  44 import qualified Data.List.NonEmpty as NonEmpty
  45 import qualified Data.Map.Strict as Map
  46 import qualified Data.Tree as Tree
  47 import qualified Prelude
  48
  49 import Symantic.Compta.Input.Journal
  50 import Symantic.Compta.Calc.Balance
  51 import Symantic.Compta.Calc.Flow
  52 import Symantic.Compta.Calc.Unit
  53 import Symantic.Compta.Lang
  54 import Symantic.Compta.Norm.PCG.Chart
  55 import Symantic.Compta.Utils.Error
  56 import qualified Symantic.Compta.Calc.Chart as Chart
  57
  58 -- * Type 'JournalPCG'
  59 newtype JournalPCG repr a = JournalPCG { unJournalPCG ::
  60   MT.Reader (JournalEnv repr) (repr {-Ty (JournalPCG repr)-} a)
  61   } deriving anyclass (Functor, Applicative, Monad)
  62 type instance Ty (JournalPCG repr) TyAccountSection = Ty repr TyAccountSection
  63 type instance Ty (JournalPCG repr) TyAccount        = Ty repr TyAccount
  64 type instance Ty (JournalPCG repr) TyAmount         = Ty repr TyAmount
  65 type instance Ty (JournalPCG repr) TyUnit           = Ty repr TyUnit
  66 type instance Ty (JournalPCG repr) TyQuantity       = Ty repr TyQuantity
  67
  68 --instance Trans (JournalPCG repr) repr where
  69   --trans (JournalPCG m) = _e m
  70
  71 journal ::
  72   IsString (Ty repr TyUnit) =>
  73   Chart -> JournalRepr (JournalPCG repr) TyMove -> repr [TyMove]
  74 journal ch jnl = MT.runReader (unJournalPCG (runJournalRepr jnl)) (journalEnv ch)
  75
  76 -- ** Type 'JournalEnv'
  77 data JournalEnv (repr::Type -> Type) = JournalEnv
  78   { journalChart :: Chart
  79   --, accountByCode :: HashMap.HashMap AccountCode ChartNode
  80   --, accountByName :: HashMap.HashMap AccountPath (AccountCode, ChartNode)
  81   , defaultUnit :: Ty repr TyUnit
  82   }
  83 journalEnv ::
  84   IsString (Ty repr TyUnit) =>
  85   Chart -> JournalEnv repr
  86 journalEnv ch = JournalEnv
  87   { journalChart = ch
  88   --, accountByCode = HashMap.fromList byCode
  89   --, accountByName = HashMap.fromList byName
  90   , defaultUnit = fromString ""
  91   }
  92   -- where
  93   -- (byCode{-, byName-}) = goChart (AccountCode 0{-, []-}) ch
  94   -- goChart p = Map.foldMapWithKey (goNode p) . Chart.unChart
  95   -- goNode (AccountCode kc{-, kn-}) n (node, children) =
  96   --   let keyCode = AccountCode (kc Prelude.* 10 Prelude.^ digitNumber n Prelude.+ n) in
  97   --   --let keyName = kn <> maybeToList (sectionName node) in
  98   --   let (bc{-, bn-}) = goChart (keyCode{-, keyName-}) children in
  99   --   ( (keyCode, ({-nonEmpty keyName,-} node)) : bc
 100   --   {-
 101   --   , case nonEmpty keyName of
 102   --       Just k -> (k, (keyCode, node)) : bn
 103   --       Nothing -> bn
 104   --   -}
 105   --   )
 106
 107 -- | @('digitNumber' n)@ retourne le nombre de digits nécessaires pour encoder 'n'.
 108 digitNumber :: Natural -> Natural
 109 digitNumber = go where
 110   go n | n < 10 = 1
 111        | otherwise = 1 Prelude.+ go (n`Prelude.div`10)
 112
 113 instance
 114   ( Postable repr
 115   , Listable repr
 116   ) => IsString (JournalPCG repr TyAccount) where
 117   fromString = error ""
 118 instance
 119   ( Postable repr
 120   , Listable repr
 121   , Zeroable (repr TyAmount)
 122   ) => IsString (JournalPCG repr TyPost) where
 123   fromString s = JournalPCG do
 124     acct <- unJournalPCG $ fromString s
 125     return $ post acct zero
 126 instance
 127   ( Postable repr
 128   , Listable repr
 129   , Zeroable (repr TyAmount)
 130   , Inject (Chart.ChartPath AccountCode) repr TyAccount
 131   --, FromInteger (JournalPCG repr TyPost)
 132   ) => FromInteger (JournalPCG repr TyPost) where
 133   fromInteger i = JournalPCG do
 134     acct <- unJournalPCG $ fromInteger i
 135     return $ post acct zero
 136 instance
 137   Zeroable (repr TyAmount) =>
 138   Zeroable (JournalPCG repr TyAmount) where
 139   zero = JournalPCG (return zero)
 140 instance Addable a => Addable (JournalPCG repr a) where
 141   x + y = (+) <$> x <*> y
 142 instance Listable repr => Listable (JournalPCG repr) where
 143   nil = JournalPCG (return nil)
 144   cons (JournalPCG x) (JournalPCG xs) = JournalPCG (liftA2 cons x xs)
 145   concat (JournalPCG xs) (JournalPCG ys) = JournalPCG (concat <$> xs <*> ys)
 146 instance Postable repr => Postable (JournalPCG repr) where
 147   post (JournalPCG acct) (JournalPCG amt) = JournalPCG do
 148     post <$> acct <*> amt
 149 instance
 150   ( Addable (Ty repr TyQuantity)
 151   , Moveable repr
 152   , Negable (Ty repr TyQuantity)
 153   , Nullable (Ty repr TyQuantity)
 154   , Ord (Ty repr TyAccountSection)
 155   , Ord (Ty repr TyUnit)
 156   , Postable repr
 157   , Show (Ty repr TyAccountSection)
 158   , Show (Ty repr TyQuantity)
 159   , Show (Ty repr TyUnit)
 160   , Trans repr (BalanceRepr Maybe repr)
 161   , Trans repr (InferPost repr)
 162   ) => Moveable (JournalPCG repr) where
 163   move (JournalPCG ps) = JournalPCG $ go <$> ps
 164     where
 165     go ps =
 166       case equilibrium ps of
 167         Right eps -> move eps
 168         Left errs -> error ("equilibrium: "<>show errs)
 169 instance Accountable repr => Accountable (JournalPCG repr) where
 170   account = JournalPCG . return . account
 171 instance Amountable repr => Amountable (JournalPCG repr) where
 172   amount = JournalPCG . return . amount
 173 instance Negable (repr qty) => Negable (JournalPCG repr qty) where
 174   negate = JournalPCG . (negate <$>) . unJournalPCG
 175 {-
 176 instance
 177   ( Postable repr
 178   , Listable repr
 179   ) => Postable acct amt (JournalPCG repr) where
 180   post acct amt = JournalPCG $ MT.ReaderT $ \_env -> post acct amt
 181 instance
 182   ( Postable acct (Map unit qty) repr
 183   , FromInteger (JournalPCG acct (Map unit qty) repr acct)
 184   , Listable repr
 185   ) => FromInteger (JournalPCG acct (Map unit qty) repr [TyPost]) where
 186   fromInteger i = cons (fromInteger i) nil
 187 instance
 188   ( Postable acct (Map unit qty) repr
 189   , IsString (JournalPCG acct (Map unit qty) repr acct)
 190   , Listable repr
 191   ) => IsString (JournalPCG acct (Map unit qty) repr [TyPost]) where
 192   fromString s = do
 193     acct :: acct <- fromString s
 194     cons (post acct (Map.empty :: Map unit qty)) nil
 195 -}
 196 {-
 197 instance
 198   ( FromRational qty
 199   , Listable repr
 200   ) => FromRational (JournalPCG repr qty) where
 201   fromRational i = JournalPCG $ MT.ReaderT $ \_env ->
 202     fromRational i
 203 instance FromInteger (JournalPCG repr AccountCode) where
 204   fromInteger i = JournalPCG do
 205     env <- MT.ask
 206     let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
 207     case HashMap.lookup ac (accountByCode env) of
 208       Just{} -> return ac
 209       _ -> error ("Chart does not allow AccountCode: "<>show ac<>" "<>show (accountByCode env))
 210 -}
 211 {-
 212 instance
 213   Listable repr =>
 214   IsString (JournalPCG repr (Chart.ChartPath AccountSegment)) where
 215   fromString s = JournalM $ do
 216     env <- MT.lift MT.ask
 217     case nonEmpty (fromString s) of
 218       Just acct | HashMap.member acct (accountByName env) -> return acct
 219       Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
 220       Nothing -> error "Invalid empty AccountPath"
 221 instance
 222   Listable repr =>
 223   FromInteger (JournalPCG repr (Chart.ChartPath AccountSegment)) where
 224   fromInteger i = JournalM $ do
 225     env <- MT.lift MT.ask
 226     let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
 227     case HashMap.lookup ac (accountByCode env) of
 228       Just (Just acct, _) -> return acct
 229       _ -> error ("Chart does not allow AccountCode: "<>show ac)
 230 -}
 231 instance
 232   ( Listable repr
 233   --, Ty repr TyAccount ~ Chart.ChartPath Natural --AccountCodeSegment
 234   , Inject (Chart.ChartPath AccountCode) repr TyAccount
 235   ) => FromInteger (JournalPCG repr TyAccount) where
 236   fromInteger i = JournalPCG $ do
 237     env <- MT.ask
 238     let code = if 0 <= i then fromInteger i else error ("Invalid AccountCode: "<>show code)
 239     let path = {-chartSection <$>-} NonEmpty.fromList (AccountCode <$> digitsOfNatural code)
 240     case Chart.lookup path (journalChart env) of
 241       Just{} -> return $ inject path
 242       _ -> error ("Chart does not allow AccountCode: "<>show code)
 243 --instance FromInteger qty => FromInteger (JournalPCG repr qty) where
 244 --  fromInteger = JournalPCG . return . fromInteger
 245 --type instance QuantityOf (Map unit qty) = qty
 246 instance
 247   ( Listable repr
 248   , Inject (Map (Ty repr TyUnit) (Ty repr TyQuantity)) repr TyAmount
 249   , FromInteger (Ty repr TyQuantity)
 250   ) => FromInteger (JournalPCG repr TyAmount) where
 251   fromInteger i = JournalPCG $ do
 252     env <- MT.ask
 253     --qty <- unJournalM (fromInteger i :: JournalPCG acct (Map unit qty) repr qty)
 254     --q <- unJournalPCG $ fromInteger i
 255     return $ inject $ Map.singleton (defaultUnit env) (fromInteger i::Ty repr TyQuantity)
 256 instance Unitable (JournalPCG repr) where
 257   unit u = JournalPCG . MT.local (\env -> env{defaultUnit=u}) . unJournalPCG
 258 instance EURable repr => EURable (JournalPCG repr) where
 259   eur qty = JournalPCG $ eur <$> unJournalPCG qty
 260 instance USDable repr => USDable (JournalPCG repr) where
 261   usd qty = JournalPCG $ usd <$> unJournalPCG qty
 262 {-
 263 instance
 264   Listable repr =>
 265   IsString (JournalPCG repr AccountCode) where
 266   fromString s = JournalM $ do
 267     env <- MT.lift MT.ask
 268     case nonEmpty (fromString s) of
 269       Just acct | Just (ac, _) <- HashMap.lookup acct (accountByName env) -> return ac
 270       Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
 271       Nothing -> error "Invalid empty AccountPath"
 272 -}
 273
 274
 275 balance :: forall repr a.
 276   Balanceable a ~ 'True =>
 277   Addable (Ty repr TyQuantity) =>
 278   Ord (Ty repr TyAccountSection) =>
 279   Ord (Ty repr TyUnit) =>
 280   Trans repr (BalanceRepr Maybe repr) =>
 281   repr a ->
 282   Balance (Ty repr TyAccountSection)
 283           (Ty repr TyUnit)
 284           (Ty repr TyQuantity)
 285           (Trickle (Ty (BalanceRepr Trickle repr) TyAmount))
 286 balance =
 287   runBalanceRepr @Trickle .
 288   trickleBalanceRepr .
 289   trans @_ @(BalanceRepr Maybe repr)
 290
 291 {-
 292 instance Listable repr => Listable (JournalPCG repr) where
 293   nil = Monad.return []
 294   cons = liftA2 (:)
 295   concat = liftA2 (<>)
 296 -}
 297
 298 --type instance AccountSectionOf (Chart.ChartPath section) = section
 299 --type instance UnitOf (Map unit qty) = unit
 300 --type instance AmountOf () = Map Unit Q
 301 --type instance AccountOf () = NonEmpty AccountCode
 302
 303 --type Account = AccountCode
 304 --type AccountCodeSegment = AccountCode
 305 --type AccountPath = Chart.ChartPath AccountSegment
 306 --type Amount = Map Unit Q
 307 --type Q = (Flow Decimal)
 308