lcc/Hcompta/LCC/Compta.hs

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