{-# LANGUAGE ExistentialQuantification #-}
module Hcompta.LCC.Compta where

import Control.Monad (Monad(..))
import Data.Bool (Bool(..))
import Data.Either (either)
import Data.Eq (Eq)
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Functor.Identity (Identity(..))
import Prelude (error)
import Text.Show (Show(..))
import qualified Control.Monad.Classes as MC
import qualified Control.Monad.Trans.State.Strict as SS
import qualified Hcompta.LCC.Lib.Strict as S

import Hcompta.LCC.Amount
import Hcompta.LCC.Balance
import Hcompta.LCC.Chart
import Hcompta.LCC.Journal
import Hcompta.LCC.IO
import Hcompta.LCC.Transaction
import Language.Symantic as Sym
import qualified Hcompta as H

-- * Type 'LCC'
data LCC src
 =   LCC
 {   lcc_chart    :: !Chart
 ,   lcc_journals :: !(Journals src (Transactions src))
 ,   lcc_style    :: !Style_Amounts
 ,   lcc_base     :: !CanonFile
 } deriving (Eq, Show)
instance H.Get Style_Amounts (LCC src) where
	get = lcc_style
instance H.Sumable Balance (LCC src) where
	b += l = b H.+= lcc_journals l

-- ** Type 'State_Sym'
data State_Sym src ss
 =   State_Sym
 {   state_sym_types :: !(Sym.Imports Sym.NameTy, Sym.ModulesTy src)
 ,   state_sym_terms :: !(Sym.Imports Sym.NameTe, Sym.Modules src ss)
 } deriving (Eq, Show)

state_sym ::
 forall src ss.
 Sym.Source src =>
 Sym.ImportTypes ss =>
 Sym.ModulesInj src ss =>
 Sym.ModulesTyInj ss =>
 State_Sym src ss
state_sym =
	let mods = either (error . show) id Sym.modulesInj in
	State_Sym
	 { state_sym_types = (Sym.importTypes @ss [], Sym.modulesTyInj @ss)
	 , state_sym_terms = (Sym.importModules [] mods, mods)
	 }

-- State_Sym src ss
type instance MC.CanDo (S.StateT (State_Sym src ss) m) (MC.EffState (State_Sym src ss)) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero (State_Sym src ss) (S.StateT (State_Sym src ss) m) where
	stateN _px = S.StateT . SS.state

-- (Sym.Imports Sym.NameTe, Sym.Modules src ss)
type instance MC.CanDo (S.StateT (State_Sym src ss) m) (MC.EffState (Sym.Imports Sym.NameTe, Sym.Modules src ss)) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Imports Sym.NameTe, Sym.Modules src ss) (S.StateT (State_Sym src ss) m) where
	stateN _px f = S.StateT $ SS.state $ \st ->
		(\a -> st{state_sym_terms=a}) <$> f (state_sym_terms st)

-- (Sym.Imports Sym.NameTy, Sym.ModulesTy src)
type instance MC.CanDo (S.StateT (State_Sym src ss) m) (MC.EffState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Imports Sym.NameTy, Sym.ModulesTy src) (S.StateT (State_Sym src ss) m) where
	stateN _px f = S.StateT $ SS.state $ \st ->
		(\a -> st{state_sym_types=a}) <$> f (state_sym_types st)

-- * Type 'Database'
newtype Database db a = Database (S.StateT db Identity a)

-- * Type 'Query'
newtype Query db a = Query { runQuery :: db -> a }

-- * Type 'Queryable'
class Queryable db a where
	query :: Query db a
instance Queryable (LCC src) Balance where
	query = Query $ H.sum . lcc_journals

{-
-- * Type 'Base'
data Base =
 forall db.
 Typeable db =>
 Base (Type src vs db) db

-- * Type 'DataBase'
data DataBase = forall db. Typeable db => DataBase db

-- * Type 'Code'
newtype Code src ss m a
 =      Code (S.StateT (State_Sym src (Sym.Proxy (Code src ss) ': ss)) m a)
 deriving (Functor, Applicative, Monad, Typeable)
-}

{-
-- * Class 'Balanceable'
class Balanceable a where
	balance :: a -> Balance
instance Balanceable (LCC src) where
	balance = H.sum . lcc_journals @src
-}

-- LCC src
type instance MC.CanDo (S.StateT (LCC src) m) (MC.EffState (LCC src)) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero (LCC src) (S.StateT (LCC src) m) where
	stateN _px = S.StateT . SS.state





{-
main :: (Compta a -> b) -> FilePath -> b

main :: (Compta a -> b) -> FilePath -> IO b

(ComptaM a -> ComptaM b) -> ComptaM a -> ComptaM b
(a -> b) -> (a -> b)

a -> b

balance :: Compta Journals -> Compta Balance
balance :: Balanceable f => Compta f Balance

fp :: Compta a

balance ./toto

./toto :: IO (Context a)
balance :: Context LCC Balance

readLCC :: Context LCC ()
readLedger :: Context Ledger ()
readSQL :: Context SQL ()

write :: Context Ledger ()

init     :: Context ()

journals :: Context LCC Journals
chart    :: Context LCC Chart
styles   :: Context LCC styles
stats    :: Context LCC stats

do
	load ./toto
	bal <- balance
	
load ./toto >>= \() ->
balance >>= \bal ->
-}

{-
data Context src ss fmt a
 =   Context
 { state_sym    :: !(State_Sym src ss)
 , context_return :: fmt a
 }
instance Functor (Context src ss fmt)
instance Applicative (Context src ss fmt)
	pure = context_return
	f <*> a = 
instance Monad (Context src ss fmt) where
	return = context_return
	c >>= f = f (context_return c)
-}

{-
instance Functor LCC where
	fmap f c = c{lcc_return = f (lcc_return c)}
instance Applicative LCC where
	pure a = LCC
	 { lcc_chart    = mempty
	 , lcc_journals = mempty
	 , lcc_style    = mempty
	 , lcc_return   = a
	 }
	f <*> a =
		LCC
		 { lcc_chart    = lcc_chart    f <> lcc_chart    a
		 , lcc_journals = lcc_journals f <> lcc_journals a
		 , lcc_style    = lcc_style    f <> lcc_style    a
		 , lcc_return   = lcc_return   f (lcc_return a)
		 }
instance Monad LCC where
	return = pure
	c >>= f =
		let c' = f (lcc_return c) in
		c'
		 { lcc_chart    = lcc_chart    c <> lcc_chart    c'
		 , lcc_journals = lcc_journals c <> lcc_journals c'
		 , lcc_style    = lcc_style    c <> lcc_style    c'
		 }
-}

{-
instance Balanceable LCC where
	balance f = f{lcc_data = H.sum $ lcc_compta f}
data LCC_IO a
 = LCC_IO
 { lcc_io_data :: Set FilePath
 , lcc_calc    :: IO a
 }

class Backend a where
instance Backend (IO a) where
instance Backend () where
instance Backend (SQL a)

class Journalable a where
	journal_fold :: (Transaction -> j -> j) -> a -> j


-- * Type 'ComptaT'
type ComptaS src ss = SS.State (State_Compta src ss)
-- type ComptaIO src ss = ComptaT src ss IO

runComptaS :: ComptaS src ss a -> State_Compta src ss -> (a, State_Compta src ss)
runComptaS = SS.runState

-- ** Type 'State_Compta'
data State_Compta src ss
 =   forall js. Journalable js
 =>  State_Compta
 {   state_compta_sty :: !Style_Amounts
 ,   state_compta_sym :: !(State_Sym src ss)
 ,   state_compta_jnl :: !js
 } deriving (Eq, Show)

compta ::
 forall src ss.
 Sym.Source src =>
 Sym.ImportTypes ss =>
 Sym.ModulesInj src ss =>
 Sym.ModulesTyInj ss =>
 State_Compta src ss
compta = State_Compta
 { compta_sym  = state_sym
 , compta_data = mempty
 }
-}