module Csound.Typed.GlobalState.SE(
    SE(..), LocalHistory(..),
    runSE, execSE, evalSE, execGEinSE, hideGEinDep,
    fromDep, fromDep_, geToSe,
    newLocalVar, newLocalVars, newGlobalVars, newClearableGlobalVars,
    -- array variables
    newLocalArrVar, newGlobalArrVar, newTmpArrVar
) where

import Control.Monad
import Control.Monad.Trans.Class

import Csound.Dynamic hiding (newLocalVar, newLocalVars, newLocalArrVar, newTmpArrVar)
import qualified Csound.Dynamic as D(newLocalVar, newLocalVars, newLocalArrVar, newTmpArrVar)
import Csound.Typed.GlobalState.GE
import Csound.Typed.GlobalState.Elements(newPersistentGlobalVar, newClearableGlobalVar, newPersistentGloabalArrVar)

-- | The Csound's @IO@-monad. All values that produce side effects are wrapped
-- in the @SE@-monad.
newtype SE a = SE { forall a. SE a -> Dep a
unSE :: Dep a }

instance Functor SE where
    fmap :: forall a b. (a -> b) -> SE a -> SE b
fmap a -> b
f = Dep b -> SE b
forall a. Dep a -> SE a
SE (Dep b -> SE b) -> (SE a -> Dep b) -> SE a -> SE b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> DepT GE a -> Dep b
forall a b. (a -> b) -> DepT GE a -> DepT GE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (DepT GE a -> Dep b) -> (SE a -> DepT GE a) -> SE a -> Dep b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SE a -> DepT GE a
forall a. SE a -> Dep a
unSE

instance Applicative SE where
    pure :: forall a. a -> SE a
pure = Dep a -> SE a
forall a. Dep a -> SE a
SE (Dep a -> SE a) -> (a -> Dep a) -> a -> SE a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Dep a
forall a. a -> DepT GE a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a b. SE (a -> b) -> SE a -> SE b
(<*>) = SE (a -> b) -> SE a -> SE b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad SE where
    SE a
ma >>= :: forall a b. SE a -> (a -> SE b) -> SE b
>>= a -> SE b
mf = Dep b -> SE b
forall a. Dep a -> SE a
SE (Dep b -> SE b) -> Dep b -> SE b
forall a b. (a -> b) -> a -> b
$ SE a -> Dep a
forall a. SE a -> Dep a
unSE SE a
ma Dep a -> (a -> Dep b) -> Dep b
forall a b. DepT GE a -> (a -> DepT GE b) -> DepT GE b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SE b -> Dep b
forall a. SE a -> Dep a
unSE (SE b -> Dep b) -> (a -> SE b) -> a -> Dep b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SE b
mf

runSE :: SE a -> GE a
runSE :: forall a. SE a -> GE a
runSE = ((a, LocalHistory) -> a) -> GE (a, LocalHistory) -> GE a
forall a b. (a -> b) -> GE a -> GE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, LocalHistory) -> a
forall a b. (a, b) -> a
fst (GE (a, LocalHistory) -> GE a)
-> (SE a -> GE (a, LocalHistory)) -> SE a -> GE a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepT GE a -> GE (a, LocalHistory)
forall (m :: * -> *) a.
(Functor m, Monad m) =>
DepT m a -> m (a, LocalHistory)
runDepT (DepT GE a -> GE (a, LocalHistory))
-> (SE a -> DepT GE a) -> SE a -> GE (a, LocalHistory)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SE a -> DepT GE a
forall a. SE a -> Dep a
unSE

execSE :: SE () -> GE InstrBody
execSE :: SE () -> GE InstrBody
execSE SE ()
a = DepT GE () -> GE InstrBody
forall (m :: * -> *).
(Functor m, Monad m) =>
DepT m () -> m InstrBody
execDepT (DepT GE () -> GE InstrBody) -> DepT GE () -> GE InstrBody
forall a b. (a -> b) -> a -> b
$ SE () -> DepT GE ()
forall a. SE a -> Dep a
unSE SE ()
a

execGEinSE :: SE (GE a) -> SE a
execGEinSE :: forall a. SE (GE a) -> SE a
execGEinSE SE (GE a)
a = GE a -> SE a
forall a. GE a -> SE a
geToSe (GE a -> SE a) -> SE (GE a) -> SE a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SE (GE a)
a
{-
(SE sa) = SE $ do
    ga <- sa
    a  <- lift ga
    return a
-}

hideGEinDep :: GE (Dep a) -> Dep a
hideGEinDep :: forall a. GE (Dep a) -> Dep a
hideGEinDep = DepT GE (DepT GE a) -> DepT GE a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (DepT GE (DepT GE a) -> DepT GE a)
-> (GE (DepT GE a) -> DepT GE (DepT GE a))
-> GE (DepT GE a)
-> DepT GE a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GE (DepT GE a) -> DepT GE (DepT GE a)
forall (m :: * -> *) a. Monad m => m a -> DepT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

fromDep :: Dep a -> SE (GE a)
fromDep :: forall a. Dep a -> SE (GE a)
fromDep = (a -> GE a) -> SE a -> SE (GE a)
forall a b. (a -> b) -> SE a -> SE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> GE a
forall a. a -> GE a
forall (m :: * -> *) a. Monad m => a -> m a
return (SE a -> SE (GE a)) -> (Dep a -> SE a) -> Dep a -> SE (GE a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dep a -> SE a
forall a. Dep a -> SE a
SE

fromDep_ :: Dep () -> SE ()
fromDep_ :: DepT GE () -> SE ()
fromDep_ = DepT GE () -> SE ()
forall a. Dep a -> SE a
SE

evalSE :: SE a -> GE a
evalSE :: forall a. SE a -> GE a
evalSE = DepT GE a -> GE a
forall (m :: * -> *) a. (Functor m, Monad m) => DepT m a -> m a
evalDepT (DepT GE a -> GE a) -> (SE a -> DepT GE a) -> SE a -> GE a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SE a -> DepT GE a
forall a. SE a -> Dep a
unSE

geToSe :: GE a -> SE a
geToSe :: forall a. GE a -> SE a
geToSe = Dep a -> SE a
forall a. Dep a -> SE a
SE (Dep a -> SE a) -> (GE a -> Dep a) -> GE a -> SE a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GE a -> Dep a
forall (m :: * -> *) a. Monad m => m a -> DepT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

----------------------------------------------------------------------
-- allocation of the local vars

newLocalVars :: [Rate] -> GE [E] -> SE [Var]
newLocalVars :: [Rate] -> GE [InstrBody] -> SE [Var]
newLocalVars [Rate]
rs GE [InstrBody]
vs = Dep [Var] -> SE [Var]
forall a. Dep a -> SE a
SE (Dep [Var] -> SE [Var]) -> Dep [Var] -> SE [Var]
forall a b. (a -> b) -> a -> b
$ [Rate] -> GE [InstrBody] -> Dep [Var]
forall (m :: * -> *).
Monad m =>
[Rate] -> m [InstrBody] -> DepT m [Var]
D.newLocalVars [Rate]
rs GE [InstrBody]
vs

newLocalVar :: Rate -> GE E -> SE Var
newLocalVar :: Rate -> GE InstrBody -> SE Var
newLocalVar Rate
rate GE InstrBody
val = Dep Var -> SE Var
forall a. Dep a -> SE a
SE (Dep Var -> SE Var) -> Dep Var -> SE Var
forall a b. (a -> b) -> a -> b
$ Rate -> GE InstrBody -> Dep Var
forall (m :: * -> *). Monad m => Rate -> m InstrBody -> DepT m Var
D.newLocalVar Rate
rate GE InstrBody
val

----------------------------------------------------------------------
-- allocation of the global vars

newGlobalVars :: [Rate] -> GE [E] -> SE [Var]
newGlobalVars :: [Rate] -> GE [InstrBody] -> SE [Var]
newGlobalVars [Rate]
rs GE [InstrBody]
vs = GE [Var] -> SE [Var]
forall a. GE a -> SE a
geToSe (GE [Var] -> SE [Var]) -> GE [Var] -> SE [Var]
forall a b. (a -> b) -> a -> b
$ (Rate -> InstrBody -> GE Var) -> [Rate] -> [InstrBody] -> GE [Var]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Rate -> InstrBody -> GE Var
f [Rate]
rs ([InstrBody] -> GE [Var]) -> GE [InstrBody] -> GE [Var]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GE [InstrBody]
vs
    where f :: Rate -> InstrBody -> GE Var
f Rate
r InstrBody
v = UpdField Globals Var
forall a. UpdField Globals a
onGlobals UpdField Globals Var -> UpdField Globals Var
forall a b. (a -> b) -> a -> b
$ Rate -> InstrBody -> State Globals Var
newPersistentGlobalVar Rate
r InstrBody
v

newClearableGlobalVars :: [Rate] -> GE [E] -> SE [Var]
newClearableGlobalVars :: [Rate] -> GE [InstrBody] -> SE [Var]
newClearableGlobalVars [Rate]
rs GE [InstrBody]
vs = GE [Var] -> SE [Var]
forall a. GE a -> SE a
geToSe (GE [Var] -> SE [Var]) -> GE [Var] -> SE [Var]
forall a b. (a -> b) -> a -> b
$ (Rate -> InstrBody -> GE Var) -> [Rate] -> [InstrBody] -> GE [Var]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Rate -> InstrBody -> GE Var
f [Rate]
rs ([InstrBody] -> GE [Var]) -> GE [InstrBody] -> GE [Var]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GE [InstrBody]
vs
    where f :: Rate -> InstrBody -> GE Var
f Rate
r InstrBody
v = UpdField Globals Var
forall a. UpdField Globals a
onGlobals UpdField Globals Var -> UpdField Globals Var
forall a b. (a -> b) -> a -> b
$ Rate -> InstrBody -> State Globals Var
newClearableGlobalVar Rate
r InstrBody
v

------------------------------------------------------------------
-- allocation of array vars

newLocalArrVar :: Rate -> GE [E] -> SE Var
newLocalArrVar :: Rate -> GE [InstrBody] -> SE Var
newLocalArrVar Rate
rate GE [InstrBody]
val = Dep Var -> SE Var
forall a. Dep a -> SE a
SE (Dep Var -> SE Var) -> Dep Var -> SE Var
forall a b. (a -> b) -> a -> b
$ Rate -> GE [InstrBody] -> Dep Var
forall (m :: * -> *).
Monad m =>
Rate -> m [InstrBody] -> DepT m Var
D.newLocalArrVar Rate
rate GE [InstrBody]
val

newTmpArrVar :: Rate -> SE Var
newTmpArrVar :: Rate -> SE Var
newTmpArrVar Rate
rate = Dep Var -> SE Var
forall a. Dep a -> SE a
SE (Dep Var -> SE Var) -> Dep Var -> SE Var
forall a b. (a -> b) -> a -> b
$ Rate -> Dep Var
forall (m :: * -> *). Monad m => Rate -> DepT m Var
D.newTmpArrVar Rate
rate

newGlobalArrVar :: Rate -> GE [E] -> SE Var
newGlobalArrVar :: Rate -> GE [InstrBody] -> SE Var
newGlobalArrVar Rate
r GE [InstrBody]
v = GE Var -> SE Var
forall a. GE a -> SE a
geToSe (GE Var -> SE Var) -> GE Var -> SE Var
forall a b. (a -> b) -> a -> b
$ UpdField Globals Var
forall a. UpdField Globals a
onGlobals UpdField Globals Var
-> ([InstrBody] -> State Globals Var) -> [InstrBody] -> GE Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rate -> [InstrBody] -> State Globals Var
newPersistentGloabalArrVar Rate
r ([InstrBody] -> GE Var) -> GE [InstrBody] -> GE Var
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GE [InstrBody]
v