src/Symantic/Compta/Input/Journal.hs

   1 {-# OPTIONS_GHC -Wno-name-shadowing #-}
   2 {-# LANGUAGE NoOverloadedLists #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 --{-# LANGUAGE QualifiedDo #-}
   5 {-# LANGUAGE StandaloneDeriving #-}
   6 module Symantic.Compta.Input.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 Symantic.Compta.Calc.Balance
  28 --import Symantic.Compta.Calc.Chart
  29 import Symantic.Compta.Calc.Unit
  30
  31 import Debug.Trace
  32
  33 -- * Type 'JournalDo'
  34 -- | This 'Monad' enables the 'do' syntax for entering 'move's and 'post's,
  35 -- which is less verbose than the list syntax.
  36 newtype JournalDo repr a = JournalDo { unJournalDo ::
  37   MT.Writer (JournalGenerator repr) a
  38   } deriving newtype (Functor, Applicative, Monad)
  39 type instance Ty (JournalDo repr) TyUnit = Ty repr TyUnit
  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 instance Listable repr => Listable (JournalRepr repr) where
 120   nil = JournalRepr $ return []
 121   cons (JournalRepr x) (JournalRepr xs) = JournalRepr $ liftA2 (:) x xs
 122   -- NOTE: those two should never be needed, but Balanceable can't rule them out
 123   cons (JournalReprAny x) (JournalRepr xs) = JournalRepr $
 124     liftA2 (:) (JournalDo (return undefined)) xs
 125   concat (JournalRepr xs) (JournalRepr ys) = JournalRepr $ liftA2 (<>) xs ys
 126 instance Zeroable (repr TyAmount) => Zeroable (JournalRepr repr TyAmount) where
 127   zero = JournalReprAny zero
 128 instance Addable (repr TyAmount) => Addable (JournalRepr repr TyAmount) where
 129   JournalReprAny x + JournalReprAny y = JournalReprAny (x + y)
 130 instance
 131   ( Negable (repr [TyMove])
 132   , Negable (repr [TyPost])
 133   , Negable (repr a)
 134   ) => Negable (JournalRepr repr a) where
 135   negate (JournalReprAny x) = JournalReprAny (negate x)
 136   negate (JournalRepr x) = JournalRepr $ JournalDo $
 137     MT.mapWriter (negate <$>) $ unJournalDo x
 138 instance
 139   ( Listable repr
 140   , FromInteger (repr TyAmount)
 141   ) => FromInteger (JournalRepr repr TyAmount) where
 142   fromInteger = JournalReprAny . fromInteger
 143 instance
 144   ( Listable repr
 145   , FromInteger (repr TyAccount)
 146   ) => FromInteger (JournalRepr repr TyAccount) where
 147   fromInteger = JournalReprAny . fromInteger
 148 instance
 149   ( Listable repr
 150   , Accountable repr
 151   , Amountable repr
 152   , Postable repr
 153   , Zeroable (repr TyAmount)
 154   , FromInteger (repr TyAccount)
 155   ) => FromInteger (JournalRepr repr TyPost) where
 156   fromInteger i = post (fromInteger i) zero
 157 instance
 158   ( Listable repr
 159   , Accountable repr
 160   , Amountable repr
 161   , Postable repr
 162   , Zeroable (repr TyAmount)
 163   , FromInteger (repr TyAccount)
 164   ) => FromInteger (JournalRepr repr [TyPost]) where
 165   fromInteger i = post (fromInteger i) zero `cons` nil
 166 {-
 167 instance
 168   ( Postable repr
 169   , FromInteger (JournalRepr repr acct)
 170   , Listable repr
 171   , Monad m
 172   ) => FromInteger (JournalRepr repr [TyPost]) where
 173   fromInteger i = cons (fromInteger i) nil
 174 instance
 175   ( Postable repr
 176   , IsString (JournalRepr repr acct)
 177   , Listable repr
 178   , Monad m
 179   ) => IsString (JournalRepr repr TyPost) where
 180   fromString s = do
 181     acct :: acct <- fromString s
 182     post acct (Map.empty :: Map unit qty)
 183 instance
 184   ( Postable repr
 185   , IsString (JournalRepr repr acct)
 186   , Listable repr
 187   , Monad m
 188   ) => IsString (JournalRepr repr [TyPost]) where
 189   fromString s = do
 190     acct :: acct <- fromString s
 191     cons (post acct (Map.empty :: Map unit qty)) nil
 192 instance
 193   ( FromRational qty
 194   , Listable repr
 195   , Monad m
 196   ) => FromRational (JournalRepr repr qty) where
 197   fromRational = JournalRepr . return . fromRational
 198 type instance QuantityOf (Map unit qty) = qty
 199 instance
 200   ( IsString unit
 201   , Monad m
 202   ) => EURable (Map unit qty) (JournalRepr repr) where
 203   eur = (Map.singleton "€" <$>)
 204 -}
 205 instance EURable repr => EURable (JournalRepr repr) where
 206   eur (JournalReprAny x) = JournalReprAny (eur x)
 207 instance USDable repr => USDable (JournalRepr repr) where
 208   usd (JournalReprAny x) = JournalReprAny (usd x)
 209
 210 instance
 211   ( Listable repr
 212   , Accountable repr
 213   , Amountable repr
 214   , Postable repr
 215   ) => Postable (JournalRepr repr) where
 216   post (JournalReprAny acct) (JournalReprAny amt) = JournalRepr $ JournalDo $
 217     MT.writer (TyPost, mempty{posts = post acct amt `cons` nil})
 218 instance
 219   ( Addable (Ty repr TyQuantity)
 220   , Listable repr
 221   , Moveable repr
 222   , Negable (Ty repr TyQuantity)
 223   , Nullable (Ty repr TyQuantity)
 224   , Ord (Ty repr TyAccountSection)
 225   , Ord (Ty repr TyUnit)
 226   , Postable repr
 227   , Show (Ty repr TyAccountSection)
 228   , Show (Ty repr TyQuantity)
 229   , Show (Ty repr TyUnit)
 230   ) => Moveable (JournalRepr repr) where
 231   move (JournalRepr ps) = JournalRepr $ JournalDo $
 232     (`MT.mapWriterT` unJournalDo ps) $ fmap $ \(_ps, out) ->
 233       ( TyMove, out
 234         { moves = move (posts out) `cons` moves out
 235         , posts = nil
 236         }
 237       )
 238
 239 {-
 240 instance FromInteger (JournalRepr acct amt repr AccountCode) where
 241   fromInteger i = JournalRepr do
 242     env <- MT.ask
 243     let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
 244     case HashMap.lookup ac (accountByCode env) of
 245       Just{} -> return ac
 246       _ -> error ("Chart does not allow AccountCode: "<>show ac<>" "<>show (accountByCode env))
 247 -}
 248 --instance FromInteger qty => FromInteger (JournalRepr acct amt repr qty) where
 249 --  fromInteger = JournalRepr . return . fromInteger
 250 {-
 251 type instance AccountSectionOf (ChartPath section) = section
 252 type instance UnitOf (Map unit qty) = unit
 253 type instance AmountOf () = Map Unit Q
 254 type instance AccountOf () = NonEmpty AccountSegment
 255
 256 type Account = AccountCode
 257 type AccountPath = ChartPath AccountSegment
 258 type Amount = Map Unit Q
 259 type Q = Quantity (Flow Decimal)
 260
 261 instance FromInteger qty => FromInteger (Flow qty) where
 262   fromInteger i | i <= 0 = Out (fromInteger i)
 263                 | otherwise = In (fromInteger i)
 264
 265 instance
 266   Listable repr =>
 267   IsString (JournalRepr acct amt repr (ChartPath AccountSegment)) where
 268   fromString s = JournalRepr $ MT.ReaderT $ \env -> do
 269     case nonEmpty (fromString s) of
 270       Just acct | HashMap.member acct (accountByName env) -> MT.writer (acct, mempty)
 271       Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
 272       Nothing -> error "Invalid empty AccountPath"
 273 instance
 274   Listable repr =>
 275   FromInteger (JournalRepr acct amt repr (ChartPath AccountSegment)) where
 276   fromInteger i = JournalRepr $ MT.ReaderT $ \env -> do
 277     let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
 278     case HashMap.lookup ac (accountByCode env) of
 279       Just (Just acct, _) -> MT.writer (acct, mempty)
 280       _ -> error ("Chart does not allow AccountCode: "<>show ac<>" "<>show (accountByCode env))
 281 instance
 282   Listable repr =>
 283   IsString (JournalRepr acct amt repr AccountCode) where
 284   fromString s = JournalRepr $ MT.ReaderT $ \env -> do
 285     case nonEmpty (fromString s) of
 286       Just acct | Just (ac, _) <- HashMap.lookup acct (accountByName env) -> MT.writer (ac, mempty)
 287       Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
 288       Nothing -> error "Invalid empty AccountPath"
 289
 290 -- ** Type 'JournalEnv'
 291 data JournalEnv unit = JournalEnv
 292   { accountByCode :: HashMap.HashMap AccountCode (Maybe AccountPath, ChartNode)
 293   , accountByName :: HashMap.HashMap AccountPath (AccountCode, ChartNode)
 294   , defaultUnit :: unit
 295   }
 296 journalEnv ch = JournalEnv
 297   { accountByCode = HashMap.fromList byCode
 298   , accountByName = HashMap.fromList byName
 299   , defaultUnit = inject ""
 300   } where
 301   (byCode, byName) = goChart (AccountCode 0, []) ch
 302   goChart p = Map.foldMapWithKey (goNode p) . unChart
 303   goNode (AccountCode kc, kn) n (node, children) =
 304     let keyCode = AccountCode (kc Prelude.* 10 Prelude.^ digitNumber n Prelude.+ n) in
 305     let keyName = kn <> maybeToList (sectionName node) in
 306     let (bc, bn) = goChart (keyCode, keyName) children in
 307     ( (keyCode, (nonEmpty keyName, node)) : bc
 308     , case nonEmpty keyName of
 309         Just k -> (k, (keyCode, node)) : bn
 310         Nothing -> bn
 311     )
 312 instance
 313   ( FromInteger qty
 314   , Listable repr
 315   ) => FromInteger (JournalRepr acct (Map unit qty) repr (Map unit qty)) where
 316   fromInteger i = JournalRepr $
 317     --qty <- unJournalDo (fromInteger i :: JournalRepr acct (Map unit qty) repr qty)
 318     MT.writer (Map.singleton (defaultUnit env) (fromInteger i), mempty)
 319
 320 -- | @('digitNumber' n)@ retourne le nombre de digits nécessaires pour encoder 'n'.
 321 digitNumber :: Natural -> Natural
 322 digitNumber = go where
 323   go n | n < 10 = 1
 324        | otherwise = 1 Prelude.+ go (n`Prelude.div`10)
 325
 326 -}