module Hcompta.LCC.Compta where

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

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
import qualified Hcompta.LCC.Lib.Strict as S

-- * 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

-- ** 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 'Context'
type Context m = SS.State m

-- * 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 ctx where
	balance :: Context ctx Balance
instance Balanceable (LCC src) where
	balance = do
		js <- SS.gets lcc_journals
		return (H.sum js)


{-
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
 }
-}