module Csound.Typed.GlobalState.GE(
GE, Dep, History(..), withOptions, withHistory, getOptions, evalGE, execGE,
onGlobals,
MidiAssign(..), Msg(..), renderMidiAssign, saveMidi,
saveAlwaysOnInstr, onInstr, saveUserInstr0, getSysExpr,
TotalDur(..), getTotalDur, setDuration, setDurationToInfinite,
saveGen,
saveBandLimitedWave,
saveStr,
GetCache, SetCache, withCache
) where
import Control.Applicative
import Control.Monad
import Data.Default
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Reader
import Csound.Dynamic
import Csound.Typed.GlobalState.Options
import Csound.Typed.GlobalState.Cache
import Csound.Typed.GlobalState.Elements
type Dep a = DepT GE a
newtype GE a = GE { unGE :: ReaderT Options (StateT History IO) a }
runGE :: GE a -> Options -> History -> IO (a, History)
runGE (GE f) opt hist = runStateT (runReaderT f opt) hist
evalGE :: Options -> GE a -> IO a
evalGE options a = fmap fst $ runGE a options def
execGE :: Options -> GE a -> IO History
execGE options a = fmap snd $ runGE a options def
instance Functor GE where
fmap f = GE . fmap f . unGE
instance Applicative GE where
pure = return
(<*>) = ap
instance Monad GE where
return = GE . return
ma >>= mf = GE $ unGE ma >>= unGE . mf
instance MonadIO GE where
liftIO = GE . liftIO . liftIO
data History = History
{ genMap :: GenMap
, stringMap :: StringMap
, globals :: Globals
, instrs :: Instrs
, midis :: [MidiAssign]
, totalDur :: Maybe TotalDur
, alwaysOnInstrs :: [InstrId]
, userInstr0 :: Dep ()
, bandLimitedMap :: BandLimitedMap
, cache :: Cache GE }
instance Default History where
def = History def def def def def def def (return ()) def def
data Msg = Msg
data MidiAssign = MidiAssign MidiType Channel InstrId
renderMidiAssign :: Monad m => MidiAssign -> DepT m ()
renderMidiAssign (MidiAssign ty chn instrId) = case ty of
Massign -> massign chn instrId
Pgmassign mn -> pgmassign chn instrId mn
where
massign n instr = depT_ $ opcs "massign" [(Xr, [Ir,Ir])] [int n, prim $ PrimInstrId instr]
pgmassign pgm instr mchn = depT_ $ opcs "pgmassign" [(Xr, [Ir,Ir,Ir])] ([int pgm, prim $ PrimInstrId instr] ++ maybe [] (return . int) mchn)
data TotalDur = NumDur Double | InfiniteDur
deriving (Eq, Ord)
getTotalDur :: Options -> (Maybe TotalDur) -> Double
getTotalDur _ = toDouble . maybe InfiniteDur id
where
toDouble x = case x of
NumDur d -> d
InfiniteDur -> infiniteDur
infiniteDur = 7 * 24 * 60 * 60
saveStr :: String -> GE E
saveStr = fmap prim . onStringMap . newString
where onStringMap = onHistory stringMap (\val h -> h{ stringMap = val })
saveGen :: Gen -> GE E
saveGen = onGenMap . newGen
where onGenMap = onHistory genMap (\val h -> h{ genMap = val })
saveBandLimitedWave :: BandLimited -> GE Int
saveBandLimitedWave = onBandLimitedMap . saveBandLimited
where onBandLimitedMap = onHistory
(\a -> (genMap a, bandLimitedMap a))
(\(gm, blm) h -> h { genMap = gm, bandLimitedMap = blm})
setDurationToInfinite :: GE ()
setDurationToInfinite = setTotalDur InfiniteDur
setDuration :: Double -> GE ()
setDuration = setTotalDur . NumDur
setTotalDur :: TotalDur -> GE ()
setTotalDur = onTotalDur . modify . const . Just
where onTotalDur = onHistory totalDur (\a h -> h { totalDur = a })
saveMidi :: MidiAssign -> GE ()
saveMidi ma = onMidis $ modify (ma: )
where onMidis = onHistory midis (\a h -> h { midis = a })
saveUserInstr0 :: Dep () -> GE ()
saveUserInstr0 expr = onUserInstr0 $ modify ( >> expr)
where onUserInstr0 = onHistory userInstr0 (\a h -> h { userInstr0 = a })
getSysExpr :: GE (Dep ())
getSysExpr = withHistory $ clearGlobals . globals
where clearGlobals = snd . renderGlobals
saveAlwaysOnInstr :: InstrId -> GE ()
saveAlwaysOnInstr instrId = onAlwaysOnInstrs $ modify (instrId : )
where onAlwaysOnInstrs = onHistory alwaysOnInstrs (\a h -> h { alwaysOnInstrs = a })
withOptions :: (Options -> a) -> GE a
withOptions f = GE $ asks f
getOptions :: GE Options
getOptions = withOptions id
withHistory :: (History -> a) -> GE a
withHistory f = GE $ lift $ fmap f get
modifyHistory :: (History -> History) -> GE ()
modifyHistory = GE . lift . modify
onHistory :: (History -> a) -> (a -> History -> History) -> State a b -> GE b
onHistory getter setter st = GE $ ReaderT $ \_ -> StateT $ \history ->
let (res, s1) = runState st (getter history)
in return (res, setter s1 history)
type UpdField a b = State a b -> GE b
onInstr :: UpdField Instrs a
onInstr = onHistory instrs (\a h -> h { instrs = a })
onGlobals :: UpdField Globals a
onGlobals = onHistory globals (\a h -> h { globals = a })
type GetCache a b = a -> Cache GE -> Maybe b
fromCache :: GetCache a b -> a -> GE (Maybe b)
fromCache f key = withHistory $ f key . cache
type SetCache a b = a -> b -> Cache GE -> Cache GE
toCache :: SetCache a b -> a -> b -> GE ()
toCache f key val = modifyHistory $ \h -> h { cache = f key val (cache h) }
withCache :: TotalDur -> GetCache key val -> SetCache key val -> key -> GE val -> GE val
withCache dur lookupResult saveResult key getResult = do
ma <- fromCache lookupResult key
res <- case ma of
Just a -> return a
Nothing -> do
r <- getResult
toCache saveResult key r
return r
setTotalDur dur
return res