src/Literate/Accounting/Journal.hs

   1 {-# LANGUAGE StandaloneDeriving #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# LANGUAGE NoOverloadedLists #-}
   4 {-# OPTIONS_GHC -Wno-name-shadowing #-}
   5
   6 module Literate.Accounting.Journal where
   7
   8 {-
   9 import Control.Applicative (Applicative (..), liftA2)
  10 import Control.Monad (Monad (..))
  11 import Control.Monad.Trans.Writer qualified as MT
  12 import Data.Bool
  13 import Data.Function (($), (.))
  14 import Data.Functor (Functor (..), (<$>))
  15 import Data.Monoid (Monoid (..))
  16 import Data.Ord (Ord (..))
  17 import Data.Semigroup (Semigroup (..))
  18 import GHC.Stack (HasCallStack)
  19 import Literate.Accounting.Balance
  20 import Text.Show (Show (..))
  21 import Prelude (undefined)
  22
  23 import Literate.Accounting.Unit
  24
  25 import Debug.Trace
  26
  27 -- * Type 'JournalDo'
  28 -- | This 'Monad' enables the 'do' syntax for entering 'move's and 'post's,
  29 -- which is less verbose than the list syntax.
  30 newtype JournalDo repr a = JournalDo { unJournalDo ::
  31   MT.Writer (JournalGenerator repr) a
  32   } deriving newtype (Functor, Applicative, Monad)
  33 instance Unitable repr => Unitable (JournalDo repr) where
  34   unit u = JournalDo . MT.mapWriter (go <$>) . unJournalDo
  35     where
  36     go JournalGenerator{..} = JournalGenerator
  37       { moves = unit u moves
  38       , posts = unit u posts
  39       }
  40
  41 runJournalDo :: HasCallStack => JournalDo repr a -> repr [TyMove]
  42 runJournalDo p =
  43   let (_a, out) = MT.runWriter (unJournalDo p) in
  44   moves out
  45
  46 -- ** Type 'JournalGenerator'
  47 data JournalGenerator repr = JournalGenerator
  48   { moves :: repr [TyMove]
  49   , posts :: repr [TyPost]
  50   }
  51 instance Listable repr => Semigroup (JournalGenerator repr) where
  52   x <> y = JournalGenerator
  53     { moves = moves x `concat` moves y
  54     , posts = posts x `concat` posts y
  55     }
  56 instance Listable repr => Monoid (JournalGenerator repr) where
  57   mempty = JournalGenerator
  58     { moves = nil
  59     , posts = nil
  60     }
  61 instance
  62   ( Negable (repr [TyMove])
  63   , Negable (repr [TyPost])
  64   ) => Negable (JournalGenerator repr) where
  65   negate JournalGenerator{..} = JournalGenerator
  66     { moves = negate moves
  67     , posts = negate posts
  68     }
  69
  70 data JournalRepr repr a where
  71   JournalReprAny ::
  72     Balanceable a ~ 'False =>
  73     repr a -> JournalRepr repr a
  74   JournalRepr ::
  75     --Balanceable a ~ 'True =>
  76     JournalDo repr a -> JournalRepr repr a
  77
  78 instance Functor (JournalRepr repr) where
  79   fmap f = \case
  80     JournalRepr fx -> JournalRepr (fmap f fx)
  81 instance Listable repr => Applicative (JournalRepr repr) where
  82   pure = JournalRepr . pure
  83   JournalRepr fa <*> JournalRepr fb = JournalRepr (fa <*> fb)
  84 instance Listable repr => Monad (JournalRepr repr) where
  85   return = JournalRepr . return
  86   JournalRepr ma >>= f = JournalRepr $ ma >>= \a ->
  87     case f a of
  88       JournalRepr mb -> mb
  89
  90 type instance Ty (JournalRepr repr) TyUnit = Ty repr TyUnit
  91
  92 runJournalRepr :: JournalRepr repr TyMove -> repr [TyMove]
  93 runJournalRepr = \case
  94   JournalRepr j -> runJournalDo j
  95 instance
  96   Unitable repr =>
  97   Unitable (JournalRepr repr) where
  98   unit u = \case
  99     JournalReprAny x -> JournalReprAny (unit u x)
 100     JournalRepr x -> JournalRepr (unit u x)
 101 -}
 102 {-
 103 instance
 104   ( Listable repr
 105   , Monad m
 106   ) => IsList (JournalRepr acct amt repr [a]) where
 107   type Item (JournalRepr acct amt repr [a]) = JournalRepr acct amt repr a
 108   fromList = Foldable.foldr cons nil
 109   toList x = error "toList"
 110   fromListN _len = fromList
 111 -}
 112 {-
 113 instance Listable repr => Listable (JournalRepr repr) where
 114   nil = JournalRepr $ return []
 115   cons (JournalRepr x) (JournalRepr xs) = JournalRepr $ liftA2 (:) x xs
 116   -- NOTE: those two should never be needed, but Balanceable can't rule them out
 117   cons (JournalReprAny x) (JournalRepr xs) = JournalRepr $
 118     liftA2 (:) (JournalDo (return undefined)) xs
 119   concat (JournalRepr xs) (JournalRepr ys) = JournalRepr $ liftA2 (<>) xs ys
 120 instance Zeroable (repr TyAmount) => Zeroable (JournalRepr repr TyAmount) where
 121   zero = JournalReprAny zero
 122 instance Addable (repr TyAmount) => Addable (JournalRepr repr TyAmount) where
 123   JournalReprAny x + JournalReprAny y = JournalReprAny (x + y)
 124 instance
 125   ( Negable (repr [TyMove])
 126   , Negable (repr [TyPost])
 127   , Negable (repr a)
 128   ) => Negable (JournalRepr repr a) where
 129   negate (JournalReprAny x) = JournalReprAny (negate x)
 130   negate (JournalRepr x) = JournalRepr $ JournalDo $
 131     MT.mapWriter (negate <$>) $ unJournalDo x
 132 instance
 133   ( Listable repr
 134   , FromInteger (repr TyAmount)
 135   ) => FromInteger (JournalRepr repr TyAmount) where
 136   fromInteger = JournalReprAny . fromInteger
 137 instance
 138   ( Listable repr
 139   , FromInteger (repr TyAccount)
 140   ) => FromInteger (JournalRepr repr TyAccount) where
 141   fromInteger = JournalReprAny . fromInteger
 142 instance
 143   ( Listable repr
 144   , Accountable repr
 145   , Amountable repr
 146   , Postable repr
 147   , Zeroable (repr TyAmount)
 148   , FromInteger (repr TyAccount)
 149   ) => FromInteger (JournalRepr repr TyPost) where
 150   fromInteger i = post (fromInteger i) zero
 151 instance
 152   ( Listable repr
 153   , Accountable repr
 154   , Amountable repr
 155   , Postable repr
 156   , Zeroable (repr TyAmount)
 157   , FromInteger (repr TyAccount)
 158   ) => FromInteger (JournalRepr repr [TyPost]) where
 159   fromInteger i = post (fromInteger i) zero `cons` nil
 160 -}
 161 {-
 162 instance
 163   ( Postable repr
 164   , FromInteger (JournalRepr repr acct)
 165   , Listable repr
 166   , Monad m
 167   ) => FromInteger (JournalRepr repr [TyPost]) where
 168   fromInteger i = cons (fromInteger i) nil
 169 instance
 170   ( Postable repr
 171   , IsString (JournalRepr repr acct)
 172   , Listable repr
 173   , Monad m
 174   ) => IsString (JournalRepr repr TyPost) where
 175   fromString s = do
 176     acct :: acct <- fromString s
 177     post acct (Map.empty :: Map unit qty)
 178 instance
 179   ( Postable repr
 180   , IsString (JournalRepr repr acct)
 181   , Listable repr
 182   , Monad m
 183   ) => IsString (JournalRepr repr [TyPost]) where
 184   fromString s = do
 185     acct :: acct <- fromString s
 186     cons (post acct (Map.empty :: Map unit qty)) nil
 187 instance
 188   ( FromRational qty
 189   , Listable repr
 190   , Monad m
 191   ) => FromRational (JournalRepr repr qty) where
 192   fromRational = JournalRepr . return . fromRational
 193 type instance QuantityOf (Map unit qty) = qty
 194 instance
 195   ( IsString unit
 196   , Monad m
 197   ) => EURable (Map unit qty) (JournalRepr repr) where
 198   eur = (Map.singleton "€" <$>)
 199 -}
 200
 201 {-
 202 instance EURable repr => EURable (JournalRepr repr) where
 203   eur (JournalReprAny x) = JournalReprAny (eur x)
 204 instance USDable repr => USDable (JournalRepr repr) where
 205   usd (JournalReprAny x) = JournalReprAny (usd x)
 206
 207 instance
 208   ( Listable repr
 209   , Accountable repr
 210   , Amountable repr
 211   , Postable repr
 212   ) => Postable (JournalRepr repr) where
 213   post (JournalReprAny acct) (JournalReprAny amt) = JournalRepr $ JournalDo $
 214     MT.writer (TyPost, mempty{posts = post acct amt `cons` nil})
 215 instance
 216   ( Addable (Ty repr TyQuantity)
 217   , Listable repr
 218   , Moveable repr
 219   , Negable (Ty repr TyQuantity)
 220   , Nullable (Ty repr TyQuantity)
 221   , Ord (Ty repr TyAccountSection)
 222   , Ord (Ty repr TyUnit)
 223   , Postable repr
 224   , Show (Ty repr TyAccountSection)
 225   , Show (Ty repr TyQuantity)
 226   , Show (Ty repr TyUnit)
 227   ) => Moveable (JournalRepr repr) where
 228   move (JournalRepr ps) = JournalRepr $ JournalDo $
 229     (`MT.mapWriterT` unJournalDo ps) $ fmap $ \(_ps, out) ->
 230       ( TyMove, out
 231         { moves = move (posts out) `cons` moves out
 232         , posts = nil
 233         }
 234       )
 235 -}
 236 {-
 237 instance FromInteger (JournalRepr acct amt repr AccountCode) where
 238   fromInteger i = JournalRepr do
 239     env <- MT.ask
 240     let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
 241     case HashMap.lookup ac (accountByCode env) of
 242       Just{} -> return ac
 243       _ -> error ("Chart does not allow AccountCode: "<>show ac<>" "<>show (accountByCode env))
 244 -}
 245 --instance FromInteger qty => FromInteger (JournalRepr acct amt repr qty) where
 246 --  fromInteger = JournalRepr . return . fromInteger
 247 {-
 248 type instance AccountSectionOf (ChartPath section) = section
 249 type instance UnitOf (Map unit qty) = unit
 250 type instance AmountOf () = Map Unit Q
 251 type instance AccountOf () = NonEmpty AccountSegment
 252
 253 type Account = AccountCode
 254 type AccountPath = ChartPath AccountSegment
 255 type Amount = Map Unit Q
 256 type Q = Quantity (Flow Decimal)
 257
 258 instance FromInteger qty => FromInteger (Flow qty) where
 259   fromInteger i | i <= 0 = Out (fromInteger i)
 260                 | otherwise = In (fromInteger i)
 261
 262 instance
 263   Listable repr =>
 264   IsString (JournalRepr acct amt repr (ChartPath AccountSegment)) where
 265   fromString s = JournalRepr $ MT.ReaderT $ \env -> do
 266     case nonEmpty (fromString s) of
 267       Just acct | HashMap.member acct (accountByName env) -> MT.writer (acct, mempty)
 268       Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
 269       Nothing -> error "Invalid empty AccountPath"
 270 instance
 271   Listable repr =>
 272   FromInteger (JournalRepr acct amt repr (ChartPath AccountSegment)) where
 273   fromInteger i = JournalRepr $ MT.ReaderT $ \env -> do
 274     let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
 275     case HashMap.lookup ac (accountByCode env) of
 276       Just (Just acct, _) -> MT.writer (acct, mempty)
 277       _ -> error ("Chart does not allow AccountCode: "<>show ac<>" "<>show (accountByCode env))
 278 instance
 279   Listable repr =>
 280   IsString (JournalRepr acct amt repr AccountCode) where
 281   fromString s = JournalRepr $ MT.ReaderT $ \env -> do
 282     case nonEmpty (fromString s) of
 283       Just acct | Just (ac, _) <- HashMap.lookup acct (accountByName env) -> MT.writer (ac, mempty)
 284       Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
 285       Nothing -> error "Invalid empty AccountPath"
 286
 287 -- ** Type 'JournalEnv'
 288 data JournalEnv unit = JournalEnv
 289   { accountByCode :: HashMap.HashMap AccountCode (Maybe AccountPath, ChartNode)
 290   , accountByName :: HashMap.HashMap AccountPath (AccountCode, ChartNode)
 291   , defaultUnit :: unit
 292   }
 293 journalEnv ch = JournalEnv
 294   { accountByCode = HashMap.fromList byCode
 295   , accountByName = HashMap.fromList byName
 296   , defaultUnit = inject ""
 297   } where
 298   (byCode, byName) = goChart (AccountCode 0, []) ch
 299   goChart p = Map.foldMapWithKey (goNode p) . unChart
 300   goNode (AccountCode kc, kn) n (node, children) =
 301     let keyCode = AccountCode (kc Prelude.* 10 Prelude.^ digitNumber n Prelude.+ n) in
 302     let keyName = kn <> maybeToList (sectionName node) in
 303     let (bc, bn) = goChart (keyCode, keyName) children in
 304     ( (keyCode, (nonEmpty keyName, node)) : bc
 305     , case nonEmpty keyName of
 306         Just k -> (k, (keyCode, node)) : bn
 307         Nothing -> bn
 308     )
 309 instance
 310   ( FromInteger qty
 311   , Listable repr
 312   ) => FromInteger (JournalRepr acct (Map unit qty) repr (Map unit qty)) where
 313   fromInteger i = JournalRepr $
 314     --qty <- unJournalDo (fromInteger i :: JournalRepr acct (Map unit qty) repr qty)
 315     MT.writer (Map.singleton (defaultUnit env) (fromInteger i), mempty)
 316
 317 -- | @('digitNumber' n)@ retourne le nombre de digits nécessaires pour encoder 'n'.
 318 digitNumber :: Natural -> Natural
 319 digitNumber = go where
 320   go n | n < 10 = 1
 321        | otherwise = 1 Prelude.+ go (n`Prelude.div`10)
 322
 323 -}