module Graphics.Web.Processing.Mid (
module Graphics.Web.Processing.Core.Types
, Context
, EventM
, ScriptM
, on
, execScriptM
, Var
, varName
, ProcVarMonad (..)
, module Graphics.Web.Processing.Core.Interface
) where
import Graphics.Web.Processing.Core.Monad
import Graphics.Web.Processing.Core.Types
import Graphics.Web.Processing.Core.Interface
import Graphics.Web.Processing.Core.Var (Var,varName)
import qualified Graphics.Web.Processing.Core.Var as Var
import Graphics.Web.Processing.Optimize
import Control.Monad (void)
import Control.Applicative
import Control.Monad.Trans.State.Strict
import Data.Monoid
import Data.Foldable (foldMap)
import Unsafe.Coerce
data EventState c =
EventState
{
event_preamble :: ProcM Preamble ()
, event_code :: ProcM c ()
}
emptyEventState :: EventState c
emptyEventState = EventState (return ()) (return ())
newtype EventM c a = EventM { unEventM :: State (EventState c) a }
instance Functor (EventM c) where
fmap f (EventM s) = EventM $ fmap f s
instance Applicative (EventM c) where
pure x = EventM $ pure x
ef <*> e = EventM $ unEventM ef <*> unEventM e
instance Monad (EventM c) where
return = pure
(EventM s) >>= f = EventM $ s >>= unEventM . f
addCode :: ProcM c () -> EventM c ()
addCode = liftProc
addPCode :: ProcM Preamble () -> EventM c ()
addPCode p = EventM $ modify $ \es -> es { event_preamble = event_preamble es >> p }
instance ProcMonad EventM where
liftProc p = EventM $ do
es <- get
let c = event_code es >> p
put $ es { event_code = void c }
return $ fst $ runProcM c
commandM t as = addCode $ commandM t as
assignM = addCode . assignM
writeComment = addCode . writeComment
iff b (EventM e1) (EventM e2) = do
let s1 = execState e1 emptyEventState
s2 = execState e2 emptyEventState
addPCode $ event_preamble s1
addPCode $ event_preamble s2
addCode $ iff b (event_code s1) (event_code s2)
createVarM = fail "EventM(createVarM): This error should never be called. Report this as an issue."
data ScriptState c =
ScriptState
{ script_code :: ProcM c ()
, script_setup :: Maybe (ProcM Setup ())
, script_draw :: Maybe (ProcM Draw ())
, script_mouseClicked :: Maybe (ProcM MouseClicked ())
, script_mouseReleased :: Maybe (ProcM MouseReleased ())
}
emptyScriptState :: ScriptState c
emptyScriptState = ScriptState (return ()) Nothing Nothing Nothing Nothing
newtype ScriptM c a = ScriptM { unScriptM :: State (ScriptState c) a }
instance Functor (ScriptM c) where
fmap f (ScriptM s) = ScriptM $ fmap f s
instance Applicative (ScriptM c) where
pure x = ScriptM $ pure x
ef <*> e = ScriptM $ unScriptM ef <*> unScriptM e
instance Monad (ScriptM c) where
return = pure
(ScriptM s) >>= f = ScriptM $ s >>= unScriptM . f
instance ProcMonad ScriptM where
liftProc p = ScriptM $ do
ss <- get
let c = script_code ss >> p
put $ ss { script_code = void c }
return $ fst $ runProcM $ c
commandM t as = liftProc $ commandM t as
assignM = liftProc . assignM
createVarM = liftProc . createVarM
writeComment = liftProc . writeComment
iff b (ScriptM e1) (ScriptM e2) = ScriptM $ do
s0 <- get
let s1 = execState e1 emptyScriptState
s2 = execState e2 emptyScriptState
f g = getLast $ foldMap (Last . g) [s0,s1,s2]
put $ ScriptState (script_code s0 >> iff b (script_code s1) (script_code s2))
(f script_setup)
(f script_draw)
(f script_mouseClicked)
(f script_mouseReleased)
class Context c where
addEvent :: c -> ProcM c () -> ScriptState d -> ScriptState d
instance Context Setup where
addEvent _ c s = s { script_setup = Just c }
instance Context Draw where
addEvent _ c s = s { script_draw = Just c }
instance Context MouseClicked where
addEvent _ c s = s { script_mouseClicked = Just c }
instance Context MouseReleased where
addEvent _ c s = s { script_mouseReleased = Just c }
on :: Context c => c -> EventM c () -> ScriptM Preamble ()
on c (EventM e) = ScriptM $ modify $ \ss ->
let n = fst $ runProcM $ script_code ss >> getVarNumber
es = execState e $ EventState (return ()) $ setVarNumber n
f = addEvent c $ event_code es
in f $ ss { script_code = script_code ss >> event_preamble es }
execScriptM :: ScriptM Preamble () -> ProcScript
execScriptM (ScriptM s0) =
let s = execState s0 emptyScriptState
in optimizeBySubstitution $ ProcScript
{ proc_preamble = execProcM $ script_code s
, proc_setup = maybe mempty execProcM $ script_setup s
, proc_draw = fmap execProcM $ script_draw s
, proc_mouseClicked = fmap execProcM $ script_mouseClicked s
, proc_mouseReleased = fmap execProcM $ script_mouseReleased s
}
class ProcMonad m => ProcVarMonad m where
newVar :: ProcType a => a -> m Preamble (Var a)
readVar :: ProcType a => Var a -> m c a
writeVar :: ProcType a => Var a -> a -> m c ()
switchContext :: ScriptM c a -> ScriptM d a
switchContext = unsafeCoerce
switchContextE :: EventM c a -> EventM d a
switchContextE = unsafeCoerce
instance ProcVarMonad ScriptM where
newVar = Var.newVar
writeVar = Var.writeVar
readVar v = do
x <- Var.readVar v
v' <- switchContext $ Var.newVar x
Var.readVar v'
instance ProcVarMonad EventM where
writeVar = Var.writeVar
readVar v = do
x <- Var.readVar v
addPCode $ void $ Var.newVar x
n <- switchContextE $ liftProc getVarNumber
let v' = fst $ runProcMWith n $ Var.newVar x
liftProc $ setVarNumber $ n + 1
writeVar v' x
Var.readVar v'
newVar = fail "EventM(newVar): This error should never be called. Report this as an issue."