src/Literate/Accounting/Journal.hs

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