lcc/Hcompta/LCC/Compta.hs

   1 module Hcompta.LCC.Compta where
   2
   3 import Control.Applicative (Applicative(..))
   4 import Control.Monad (Monad(..))
   5 import Data.Bool (Bool(..))
   6 import Data.Either (either)
   7 import Data.Eq (Eq)
   8 import Data.Function (($), (.), id)
   9 import Data.Functor (Functor(..), (<$>))
  10 import Data.Typeable (Typeable)
  11 import Prelude (error)
  12 import Text.Show (Show(..))
  13 import qualified Control.Monad.Classes as MC
  14 import qualified Control.Monad.Trans.State.Strict as SS
  15
  16 import Hcompta.LCC.Amount
  17 import Hcompta.LCC.Balance
  18 import Hcompta.LCC.Chart
  19 import Hcompta.LCC.Journal
  20 import Hcompta.LCC.IO
  21 import Hcompta.LCC.Transaction
  22 import Language.Symantic as Sym
  23 import qualified Hcompta as H
  24 import qualified Hcompta.LCC.Lib.Strict as S
  25
  26 -- * Type 'LCC'
  27 data LCC src
  28  =   LCC
  29  {   lcc_chart    :: !Chart
  30  ,   lcc_journals :: !(Journals src (Transactions src))
  31  ,   lcc_style    :: !Style_Amounts
  32  ,   lcc_base     :: !CanonFile
  33  } deriving (Eq, Show)
  34 instance H.Get Style_Amounts (LCC src) where
  35         get = lcc_style
  36
  37 -- ** Type 'State_Sym'
  38 data State_Sym src ss
  39  =   State_Sym
  40  {   state_sym_types :: !(Sym.Imports Sym.NameTy, Sym.ModulesTy src)
  41  ,   state_sym_terms :: !(Sym.Imports Sym.NameTe, Sym.Modules src ss)
  42  } deriving (Eq, Show)
  43
  44 state_sym ::
  45  forall src ss.
  46  Sym.Source src =>
  47  Sym.ImportTypes ss =>
  48  Sym.ModulesInj src ss =>
  49  Sym.ModulesTyInj ss =>
  50  State_Sym src ss
  51 state_sym =
  52         let mods = either (error . show) id Sym.modulesInj in
  53         State_Sym
  54          { state_sym_types = (Sym.importTypes @ss [], Sym.modulesTyInj @ss)
  55          , state_sym_terms = (Sym.importModules [] mods, mods)
  56          }
  57
  58 -- State_Sym src ss
  59 type instance MC.CanDo (S.StateT (State_Sym src ss) m) (MC.EffState (State_Sym src ss)) = 'True
  60 instance Monad m => MC.MonadStateN 'MC.Zero (State_Sym src ss) (S.StateT (State_Sym src ss) m) where
  61         stateN _px = S.StateT . SS.state
  62
  63 -- (Sym.Imports Sym.NameTe, Sym.Modules src ss)
  64 type instance MC.CanDo (S.StateT (State_Sym src ss) m) (MC.EffState (Sym.Imports Sym.NameTe, Sym.Modules src ss)) = 'True
  65 instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Imports Sym.NameTe, Sym.Modules src ss) (S.StateT (State_Sym src ss) m) where
  66         stateN _px f = S.StateT $ SS.state $ \st ->
  67                 (\a -> st{state_sym_terms=a}) <$> f (state_sym_terms st)
  68
  69 -- (Sym.Imports Sym.NameTy, Sym.ModulesTy src)
  70 type instance MC.CanDo (S.StateT (State_Sym src ss) m) (MC.EffState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)) = 'True
  71 instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Imports Sym.NameTy, Sym.ModulesTy src) (S.StateT (State_Sym src ss) m) where
  72         stateN _px f = S.StateT $ SS.state $ \st ->
  73                 (\a -> st{state_sym_types=a}) <$> f (state_sym_types st)
  74
  75 -- * Type 'Context'
  76 type Context m = SS.State m
  77
  78 -- * Type 'Code'
  79 newtype Code src ss m a
  80  =      Code (S.StateT (State_Sym src (Sym.Proxy (Code src ss) ': ss)) m a)
  81  deriving (Functor, Applicative, Monad, Typeable)
  82
  83 -- * Class 'Balanceable'
  84 class Balanceable ctx where
  85         balance :: Context ctx Balance
  86 instance Balanceable (LCC src) where
  87         balance = do
  88                 js <- SS.gets lcc_journals
  89                 return (H.sum js)
  90
  91
  92 {-
  93 main :: (Compta a -> b) -> FilePath -> b
  94
  95 main :: (Compta a -> b) -> FilePath -> IO b
  96
  97 (ComptaM a -> ComptaM b) -> ComptaM a -> ComptaM b
  98 (a -> b) -> (a -> b)
  99
 100 a -> b
 101
 102 balance :: Compta Journals -> Compta Balance
 103 balance :: Balanceable f => Compta f Balance
 104
 105 fp :: Compta a
 106
 107 balance ./toto
 108
 109 ./toto :: IO (Context a)
 110 balance :: Context LCC Balance
 111
 112 readLCC :: Context LCC ()
 113 readLedger :: Context Ledger ()
 114 readSQL :: Context SQL ()
 115
 116 write :: Context Ledger ()
 117
 118 init     :: Context ()
 119
 120 journals :: Context LCC Journals
 121 chart    :: Context LCC Chart
 122 styles   :: Context LCC styles
 123 stats    :: Context LCC stats
 124
 125 do
 126         load ./toto
 127         bal <- balance
 128
 129 load ./toto >>= \() ->
 130 balance >>= \bal ->
 131 -}
 132
 133 {-
 134 data Context src ss fmt a
 135  =   Context
 136  { state_sym    :: !(State_Sym src ss)
 137  , context_return :: fmt a
 138  }
 139 instance Functor (Context src ss fmt)
 140 instance Applicative (Context src ss fmt)
 141         pure = context_return
 142         f <*> a =
 143 instance Monad (Context src ss fmt) where
 144         return = context_return
 145         c >>= f = f (context_return c)
 146 -}
 147
 148 {-
 149 instance Functor LCC where
 150         fmap f c = c{lcc_return = f (lcc_return c)}
 151 instance Applicative LCC where
 152         pure a = LCC
 153          { lcc_chart    = mempty
 154          , lcc_journals = mempty
 155          , lcc_style    = mempty
 156          , lcc_return   = a
 157          }
 158         f <*> a =
 159                 LCC
 160                  { lcc_chart    = lcc_chart    f <> lcc_chart    a
 161                  , lcc_journals = lcc_journals f <> lcc_journals a
 162                  , lcc_style    = lcc_style    f <> lcc_style    a
 163                  , lcc_return   = lcc_return   f (lcc_return a)
 164                  }
 165 instance Monad LCC where
 166         return = pure
 167         c >>= f =
 168                 let c' = f (lcc_return c) in
 169                 c'
 170                  { lcc_chart    = lcc_chart    c <> lcc_chart    c'
 171                  , lcc_journals = lcc_journals c <> lcc_journals c'
 172                  , lcc_style    = lcc_style    c <> lcc_style    c'
 173                  }
 174 -}
 175
 176 {-
 177 instance Balanceable LCC where
 178         balance f = f{lcc_data = H.sum $ lcc_compta f}
 179 data LCC_IO a
 180  = LCC_IO
 181  { lcc_io_data :: Set FilePath
 182  , lcc_calc    :: IO a
 183  }
 184
 185 class Backend a where
 186 instance Backend (IO a) where
 187 instance Backend () where
 188 instance Backend (SQL a)
 189
 190 class Journalable a where
 191         journal_fold :: (Transaction -> j -> j) -> a -> j
 192
 193
 194 -- * Type 'ComptaT'
 195 type ComptaS src ss = SS.State (State_Compta src ss)
 196 -- type ComptaIO src ss = ComptaT src ss IO
 197
 198 runComptaS :: ComptaS src ss a -> State_Compta src ss -> (a, State_Compta src ss)
 199 runComptaS = SS.runState
 200
 201 -- ** Type 'State_Compta'
 202 data State_Compta src ss
 203  =   forall js. Journalable js
 204  =>  State_Compta
 205  {   state_compta_sty :: !Style_Amounts
 206  ,   state_compta_sym :: !(State_Sym src ss)
 207  ,   state_compta_jnl :: !js
 208  } deriving (Eq, Show)
 209
 210 compta ::
 211  forall src ss.
 212  Sym.Source src =>
 213  Sym.ImportTypes ss =>
 214  Sym.ModulesInj src ss =>
 215  Sym.ModulesTyInj ss =>
 216  State_Compta src ss
 217 compta = State_Compta
 218  { compta_sym  = state_sym
 219  , compta_data = mempty
 220  }
 221 -}