{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Miso.Effect
(
Effect
, Sub
, Sink
, DOMRef
, ComponentInfo (..)
, ComponentId
, mkComponentInfo
, Schedule (..)
, Synchronicity (..)
, (<#)
, (#>)
, batch
, batch_
, io
, io_
, sync
, sync_
, for
, issue
, withSink
, mapSub
, noop
, beforeAll
, afterAll
, modifyAllJSM
, runEffect
, scheduleIO
, scheduleIO_
, scheduleIOFor_
, scheduleSub
, effectSub
, batchEff
, noEff
) where
import Control.Monad (void)
import Data.Foldable (for_)
import Control.Monad.RWS ( RWS, put, tell, execRWS, censor)
import Language.Javascript.JSaddle (JSVal, JSM)
#if __GLASGOW_HASKELL__ <= 881
import qualified Control.Monad.Fail as Fail
import Data.Functor.Identity (Identity(..))
#endif
mkComponentInfo
:: ComponentId
-> ComponentId
-> DOMRef
-> ComponentInfo parent
mkComponentInfo :: forall parent.
ComponentId -> ComponentId -> DOMRef -> ComponentInfo parent
mkComponentInfo = ComponentId -> ComponentId -> DOMRef -> ComponentInfo parent
forall parent.
ComponentId -> ComponentId -> DOMRef -> ComponentInfo parent
ComponentInfo
data ComponentInfo parent
= ComponentInfo
{ forall parent. ComponentInfo parent -> ComponentId
_componentId :: ComponentId
, forall parent. ComponentInfo parent -> ComponentId
_componentParentId :: ComponentId
, forall parent. ComponentInfo parent -> DOMRef
_componentDOMRef :: DOMRef
}
type ComponentId = Int
type Sub action = Sink action -> JSM ()
type Sink action = action -> JSM ()
infixl 0 <#
(<#) :: model -> JSM action -> Effect parent model action
<# :: forall model action parent.
model -> JSM action -> Effect parent model action
(<#) model
m JSM action
action = model
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put model
m RWST (ComponentInfo parent) [Schedule action] model Identity ()
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall a b.
RWST (ComponentInfo parent) [Schedule action] model Identity a
-> RWST (ComponentInfo parent) [Schedule action] model Identity b
-> RWST (ComponentInfo parent) [Schedule action] model Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Schedule action]
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ (Sink action -> JSM ()) -> Schedule action
forall action. (Sink action -> JSM ()) -> Schedule action
async ((Sink action -> JSM ()) -> Schedule action)
-> (Sink action -> JSM ()) -> Schedule action
forall a b. (a -> b) -> a -> b
$ \Sink action
f -> Sink action
f Sink action -> JSM action -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM action
action ]
async :: (Sink action -> JSM ()) -> Schedule action
async :: forall action. (Sink action -> JSM ()) -> Schedule action
async = Synchronicity -> (Sink action -> JSM ()) -> Schedule action
forall action.
Synchronicity -> (Sink action -> JSM ()) -> Schedule action
Schedule Synchronicity
Async
infixr 0 #>
(#>) :: JSM action -> model -> Effect parent model action
#> :: forall action model parent.
JSM action -> model -> Effect parent model action
(#>) = (model -> JSM action -> Effect parent model action)
-> JSM action -> model -> Effect parent model action
forall a b c. (a -> b -> c) -> b -> a -> c
flip model -> JSM action -> Effect parent model action
forall model action parent.
model -> JSM action -> Effect parent model action
(<#)
batch :: [JSM action] -> Effect parent model action
batch :: forall action parent model.
[JSM action] -> Effect parent model action
batch [JSM action]
actions = [RWST (ComponentInfo parent) [Schedule action] model Identity ()]
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
[ [Schedule action]
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ (Sink action -> JSM ()) -> Schedule action
forall action. (Sink action -> JSM ()) -> Schedule action
async ((Sink action -> JSM ()) -> Schedule action)
-> (Sink action -> JSM ()) -> Schedule action
forall a b. (a -> b) -> a -> b
$ \Sink action
f -> Sink action
f Sink action -> JSM action -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM action
action ]
| JSM action
action <- [JSM action]
actions
]
batch_ :: [JSM ()] -> Effect parent model action
batch_ :: forall parent model action. [JSM ()] -> Effect parent model action
batch_ [JSM ()]
actions = [RWST (ComponentInfo parent) [Schedule action] model Identity ()]
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
[ [Schedule action]
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ (Sink action -> JSM ()) -> Schedule action
forall action. (Sink action -> JSM ()) -> Schedule action
async (JSM () -> Sink action -> JSM ()
forall a b. a -> b -> a
const JSM ()
action) ]
| JSM ()
action <- [JSM ()]
actions
]
type Effect parent model action = RWS (ComponentInfo parent) [Schedule action] model ()
data Schedule action = Schedule Synchronicity (Sink action -> JSM ())
type DOMRef = JSVal
#if __GLASGOW_HASKELL__ <= 881
instance Fail.MonadFail Identity where
fail = error
#endif
runEffect
:: Effect parent model action
-> ComponentInfo parent
-> model
-> (model, [Schedule action])
runEffect :: forall parent model action.
Effect parent model action
-> ComponentInfo parent -> model -> (model, [Schedule action])
runEffect = RWS (ComponentInfo parent) [Schedule action] model ()
-> ComponentInfo parent -> model -> (model, [Schedule action])
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS
mapSub :: (a -> b) -> Sub a -> Sub b
mapSub :: forall a b. (a -> b) -> Sub a -> Sub b
mapSub a -> b
f Sub a
sub = \Sink b
g -> Sub a
sub (Sink b
g Sink b -> (a -> b) -> a -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
sync :: JSM action -> Effect parent model action
sync :: forall action parent model.
JSM action -> Effect parent model action
sync JSM action
action = [Schedule action]
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ Synchronicity -> (Sink action -> JSM ()) -> Schedule action
forall action.
Synchronicity -> (Sink action -> JSM ()) -> Schedule action
Schedule Synchronicity
Sync ((Sink action -> JSM ()) -> Schedule action)
-> (Sink action -> JSM ()) -> Schedule action
forall a b. (a -> b) -> a -> b
$ \Sink action
f -> Sink action
f Sink action -> JSM action -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM action
action ]
sync_ :: JSM () -> Effect parent model action
sync_ :: forall parent model action. JSM () -> Effect parent model action
sync_ JSM ()
action = [Schedule action]
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ Synchronicity -> (Sink action -> JSM ()) -> Schedule action
forall action.
Synchronicity -> (Sink action -> JSM ()) -> Schedule action
Schedule Synchronicity
Sync ((Sink action -> JSM ()) -> Schedule action)
-> (Sink action -> JSM ()) -> Schedule action
forall a b. (a -> b) -> a -> b
$ \Sink action
_ -> JSM ()
action ]
io :: JSM action -> Effect parent model action
io :: forall action parent model.
JSM action -> Effect parent model action
io JSM action
action = (Sink action -> JSM ()) -> Effect parent model action
forall action parent model.
(Sink action -> JSM ()) -> Effect parent model action
withSink (JSM action
action JSM action -> Sink action -> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
io_ :: JSM a -> Effect parent model action
io_ :: forall a parent model action. JSM a -> Effect parent model action
io_ JSM a
action = (Sink action -> JSM ()) -> Effect parent model action
forall action parent model.
(Sink action -> JSM ()) -> Effect parent model action
withSink (\Sink action
_ -> JSM a -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void JSM a
action)
for :: Foldable f => JSM (f action) -> Effect parent model action
for :: forall (f :: * -> *) action parent model.
Foldable f =>
JSM (f action) -> Effect parent model action
for JSM (f action)
actions = (Sink action -> JSM ()) -> Effect parent model action
forall action parent model.
(Sink action -> JSM ()) -> Effect parent model action
withSink ((Sink action -> JSM ()) -> Effect parent model action)
-> (Sink action -> JSM ()) -> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink -> JSM (f action)
actions JSM (f action) -> (f action -> JSM ()) -> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (f action -> Sink action -> JSM ())
-> Sink action -> f action -> JSM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip f action -> Sink action -> JSM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Sink action
sink
beforeAll :: JSM () -> Effect parent model action -> Effect parent model action
beforeAll :: forall parent model action.
JSM () -> Effect parent model action -> Effect parent model action
beforeAll = (JSM () -> JSM ())
-> Effect parent model action -> Effect parent model action
forall parent model action.
(JSM () -> JSM ())
-> Effect parent model action -> Effect parent model action
modifyAllJSM ((JSM () -> JSM ())
-> Effect parent model action -> Effect parent model action)
-> (JSM () -> JSM () -> JSM ())
-> JSM ()
-> Effect parent model action
-> Effect parent model action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSM () -> JSM () -> JSM ()
forall a b. JSM a -> JSM b -> JSM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
afterAll :: JSM () -> Effect parent model action -> Effect parent model action
afterAll :: forall parent model action.
JSM () -> Effect parent model action -> Effect parent model action
afterAll = (JSM () -> JSM ())
-> Effect parent model action -> Effect parent model action
forall parent model action.
(JSM () -> JSM ())
-> Effect parent model action -> Effect parent model action
modifyAllJSM ((JSM () -> JSM ())
-> Effect parent model action -> Effect parent model action)
-> (JSM () -> JSM () -> JSM ())
-> JSM ()
-> Effect parent model action
-> Effect parent model action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSM () -> JSM () -> JSM ()
forall a b. JSM a -> JSM b -> JSM a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
(<*)
modifyAllJSM
:: (JSM () -> JSM ())
-> Effect parent model action
-> Effect parent model action
modifyAllJSM :: forall parent model action.
(JSM () -> JSM ())
-> Effect parent model action -> Effect parent model action
modifyAllJSM JSM () -> JSM ()
f = ([Schedule action] -> [Schedule action])
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor (([Schedule action] -> [Schedule action])
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
-> RWST (ComponentInfo parent) [Schedule action] model Identity ())
-> ([Schedule action] -> [Schedule action])
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall a b. (a -> b) -> a -> b
$ \[Schedule action]
actions ->
[ Synchronicity -> (Sink action -> JSM ()) -> Schedule action
forall action.
Synchronicity -> (Sink action -> JSM ()) -> Schedule action
Schedule Synchronicity
x (JSM () -> JSM ()
f (JSM () -> JSM ())
-> (Sink action -> JSM ()) -> Sink action -> JSM ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sink action -> JSM ()
action)
| Schedule Synchronicity
x Sink action -> JSM ()
action <- [Schedule action]
actions
]
withSink :: (Sink action -> JSM ()) -> Effect parent model action
withSink :: forall action parent model.
(Sink action -> JSM ()) -> Effect parent model action
withSink Sink action -> JSM ()
f = [Schedule action]
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ (Sink action -> JSM ()) -> Schedule action
forall action. (Sink action -> JSM ()) -> Schedule action
async Sink action -> JSM ()
f ]
issue :: action -> Effect parent model action
issue :: forall action parent model. action -> Effect parent model action
issue action
action = [Schedule action]
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ (Sink action -> JSM ()) -> Schedule action
forall action. (Sink action -> JSM ()) -> Schedule action
async ((Sink action -> JSM ()) -> Schedule action)
-> (Sink action -> JSM ()) -> Schedule action
forall a b. (a -> b) -> a -> b
$ \Sink action
f -> Sink action
f action
action ]
{-# DEPRECATED scheduleIO "Please use 'io' instead" #-}
scheduleIO :: JSM action -> Effect parent model action
scheduleIO :: forall action parent model.
JSM action -> Effect parent model action
scheduleIO = JSM action -> Effect parent model action
forall action parent model.
JSM action -> Effect parent model action
io
{-# DEPRECATED scheduleIO_ "Please use 'io_' instead" #-}
scheduleIO_ :: JSM () -> Effect parent model action
scheduleIO_ :: forall parent model action. JSM () -> Effect parent model action
scheduleIO_ = JSM () -> Effect parent model action
forall a parent model action. JSM a -> Effect parent model action
io_
{-# DEPRECATED scheduleIOFor_ "Please use 'for' instead" #-}
scheduleIOFor_ :: Foldable f => JSM (f action) -> Effect parent model action
scheduleIOFor_ :: forall (f :: * -> *) action parent model.
Foldable f =>
JSM (f action) -> Effect parent model action
scheduleIOFor_ = JSM (f action) -> Effect parent model action
forall (f :: * -> *) action parent model.
Foldable f =>
JSM (f action) -> Effect parent model action
for
{-# DEPRECATED scheduleSub "Please use 'withSink' instead" #-}
scheduleSub :: (Sink action -> JSM ()) -> Effect parent model action
scheduleSub :: forall action parent model.
(Sink action -> JSM ()) -> Effect parent model action
scheduleSub = (Sink action -> JSM ()) -> Effect parent model action
forall action parent model.
(Sink action -> JSM ()) -> Effect parent model action
withSink
{-# DEPRECATED effectSub "Please use 'put' and 'withSink' instead " #-}
effectSub :: model -> (Sink action -> JSM ()) -> Effect parent model action
effectSub :: forall model action parent.
model -> (Sink action -> JSM ()) -> Effect parent model action
effectSub model
m Sink action -> JSM ()
s = model
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put model
m RWST (ComponentInfo parent) [Schedule action] model Identity ()
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall a b.
RWST (ComponentInfo parent) [Schedule action] model Identity a
-> RWST (ComponentInfo parent) [Schedule action] model Identity b
-> RWST (ComponentInfo parent) [Schedule action] model Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Sink action -> JSM ())
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall action parent model.
(Sink action -> JSM ()) -> Effect parent model action
withSink Sink action -> JSM ()
s
{-# DEPRECATED noEff "Please use 'put' instead " #-}
noEff :: model -> Effect parent model action
noEff :: forall model parent action. model -> Effect parent model action
noEff = model
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
{-# DEPRECATED batchEff "Please use 'put' and 'batch' instead " #-}
batchEff :: model -> [JSM action] -> Effect parent model action
batchEff :: forall model action parent.
model -> [JSM action] -> Effect parent model action
batchEff model
model [JSM action]
actions = do
model
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put model
model
[JSM action]
-> RWST (ComponentInfo parent) [Schedule action] model Identity ()
forall action parent model.
[JSM action] -> Effect parent model action
batch [JSM action]
actions
noop :: action -> Effect parent model action
noop :: forall action parent model. action -> Effect parent model action
noop = Effect parent model action -> action -> Effect parent model action
forall a b. a -> b -> a
const (() -> Effect parent model action
forall a.
a -> RWST (ComponentInfo parent) [Schedule action] model Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
data Synchronicity
= Async
| Sync
deriving (ComponentId -> Synchronicity -> ShowS
[Synchronicity] -> ShowS
Synchronicity -> String
(ComponentId -> Synchronicity -> ShowS)
-> (Synchronicity -> String)
-> ([Synchronicity] -> ShowS)
-> Show Synchronicity
forall a.
(ComponentId -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: ComponentId -> Synchronicity -> ShowS
showsPrec :: ComponentId -> Synchronicity -> ShowS
$cshow :: Synchronicity -> String
show :: Synchronicity -> String
$cshowList :: [Synchronicity] -> ShowS
showList :: [Synchronicity] -> ShowS
Show, Synchronicity -> Synchronicity -> Bool
(Synchronicity -> Synchronicity -> Bool)
-> (Synchronicity -> Synchronicity -> Bool) -> Eq Synchronicity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Synchronicity -> Synchronicity -> Bool
== :: Synchronicity -> Synchronicity -> Bool
$c/= :: Synchronicity -> Synchronicity -> Bool
/= :: Synchronicity -> Synchronicity -> Bool
Eq)