-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Effect
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module defines `Effect`, `Sub` and `Sink` types, which are used to define
-- `Miso.Types.update` function and `Miso.Types.subs` field of the `Miso.Types.App`.
--
----------------------------------------------------------------------------
module Miso.Effect
  ( -- ** Effect
    -- *** Types
    Effect
  , Sub
  , SubName
  , Sink
    -- *** Combinators
  , (<#)
  , (#>)
  , batch
  , io
  , io_
  , for
  , issue
  , withSink
  , mapSub
  -- * Internal
  , runEffect
  -- * Deprecated
  , scheduleIO
  , scheduleIO_
  , scheduleIOFor_
  , scheduleSub
  , effectSub
  , batchEff
  , noEff
  ) where
-----------------------------------------------------------------------------
#if __GLASGOW_HASKELL__ <= 881
import           Control.Monad.Fail (MonadFail, fail)
import qualified Control.Monad.Fail as Fail
#endif
import           Data.Foldable (for_)
import           Control.Monad.RWS ( RWS, put, tell, execRWS
                                   , MonadState, MonadReader, MonadWriter
                                   )
-----------------------------------------------------------------------------
import           Miso.FFI.Internal (JSM, consoleError)
import           Miso.String (ms, MisoString)
-----------------------------------------------------------------------------
-- | Type synonym for constructing event subscriptions.
--
-- The 'Sink' callback is used to dispatch actions which are then fed
-- back into the 'Miso.Types.update' function.
type Sub action = Sink action -> JSM ()
-----------------------------------------------------------------------------
-- | SubName
-- The name of a 'Sub' (e.g. "websocket")
--
type SubName = MisoString
-----------------------------------------------------------------------------
-- | Function to asynchronously dispatch actions to the 'Miso.Types.update' function.
type Sink action = action -> JSM ()
-----------------------------------------------------------------------------
-- | Smart constructor for an 'Effect' with exactly one action.
infixl 0 <#
(<#) :: model -> JSM action -> Effect model action
<# :: forall model action. model -> JSM action -> Effect model action
(<#) model
m JSM action
action = model -> EffectCore model action ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put model
m EffectCore model action ()
-> EffectCore model action () -> EffectCore model action ()
forall a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(action -> JSM ()) -> JSM ()] -> EffectCore model action ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ \action -> JSM ()
f -> action -> JSM ()
f (action -> JSM ()) -> JSM action -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM action
action ]
-----------------------------------------------------------------------------
-- | `Effect` smart constructor, flipped
infixr 0 #>
(#>) :: JSM action -> model -> Effect model action
#> :: forall action model. JSM action -> model -> Effect model action
(#>) = (model -> JSM action -> Effect model action)
-> JSM action -> model -> Effect model action
forall a b c. (a -> b -> c) -> b -> a -> c
flip model -> JSM action -> Effect model action
forall model action. model -> JSM action -> Effect model action
(<#)
-----------------------------------------------------------------------------
-- | Smart constructor for an 'Effect' with multiple actions.
batch :: [JSM action] -> Effect model action
batch :: forall action model. [JSM action] -> Effect model action
batch [JSM action]
actions = [EffectCore model action ()] -> EffectCore model action ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
  [ [(action -> JSM ()) -> JSM ()] -> EffectCore model action ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ \action -> JSM ()
f -> action -> JSM ()
f (action -> JSM ()) -> 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
  ]
-----------------------------------------------------------------------------
-- | A monad for succinctly expressing model transitions in the @update@ function.
--
-- @Effect@ is a @RWS@, where the @State@ abstracts over manually passing the model
-- around. It's also a @Writer@ @Monad@, where the accumulator is a list of scheduled
-- @IO@ actions. Multiple actions can be scheduled using @Control.Monad.Writer.Class.tell@ 
-- from the @mtl@ library and a single action can be scheduled using 'scheduleIO'.
--
-- An @Effect@ represents the results of an update action.
--
-- It consists of the updated model and a list of subscriptions. Each @Sub@ is
-- run in a new thread so there is no risk of accidentally blocking the
-- application.
--
-- Tip: use the @Effect@ monad in combination with the stateful
-- <http://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Operators.html lens>
-- operators (all operators ending in "@=@"). The following example assumes
-- the lenses @field1@, @counter@ and @field2@ are in scope and that the
-- @LambdaCase@ language extension is enabled:
--
-- @
-- myApp = App
--   { update = \\case
--       MyAction1 -> do
--         field1 .= value1
--         counter += 1
--       MyAction2 -> do
--         field2 %= f
--         scheduleIO $ do
--           putStrLn \"Hello\"
--           putStrLn \"World!\"
--   , ...
--   }
-- @
type Effect model action = EffectCore model action ()
-----------------------------------------------------------------------------
-- | The name of a @Component@
type ComponentName = MisoString
-----------------------------------------------------------------------------
-- | The @EffectCore@ Monad, underlies @Effect@
newtype EffectCore model action a
  = EffectCore
  { forall model action a.
EffectCore model action a
-> RWS ComponentName [Sink action -> JSM ()] model a
runEffectCore :: RWS ComponentName [Sink action -> JSM ()] model a
  } deriving
    ( (forall a b.
 (a -> b) -> EffectCore model action a -> EffectCore model action b)
-> (forall a b.
    a -> EffectCore model action b -> EffectCore model action a)
-> Functor (EffectCore model action)
forall a b.
a -> EffectCore model action b -> EffectCore model action a
forall a b.
(a -> b) -> EffectCore model action a -> EffectCore model action b
forall model action a b.
a -> EffectCore model action b -> EffectCore model action a
forall model action a b.
(a -> b) -> EffectCore model action a -> EffectCore model action b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall model action a b.
(a -> b) -> EffectCore model action a -> EffectCore model action b
fmap :: forall a b.
(a -> b) -> EffectCore model action a -> EffectCore model action b
$c<$ :: forall model action a b.
a -> EffectCore model action b -> EffectCore model action a
<$ :: forall a b.
a -> EffectCore model action b -> EffectCore model action a
Functor
    , Functor (EffectCore model action)
Functor (EffectCore model action) =>
(forall a. a -> EffectCore model action a)
-> (forall a b.
    EffectCore model action (a -> b)
    -> EffectCore model action a -> EffectCore model action b)
-> (forall a b c.
    (a -> b -> c)
    -> EffectCore model action a
    -> EffectCore model action b
    -> EffectCore model action c)
-> (forall a b.
    EffectCore model action a
    -> EffectCore model action b -> EffectCore model action b)
-> (forall a b.
    EffectCore model action a
    -> EffectCore model action b -> EffectCore model action a)
-> Applicative (EffectCore model action)
forall a. a -> EffectCore model action a
forall model action. Functor (EffectCore model action)
forall a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action a
forall a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action b
forall a b.
EffectCore model action (a -> b)
-> EffectCore model action a -> EffectCore model action b
forall model action a. a -> EffectCore model action a
forall a b c.
(a -> b -> c)
-> EffectCore model action a
-> EffectCore model action b
-> EffectCore model action c
forall model action a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action a
forall model action a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action b
forall model action a b.
EffectCore model action (a -> b)
-> EffectCore model action a -> EffectCore model action b
forall model action a b c.
(a -> b -> c)
-> EffectCore model action a
-> EffectCore model action b
-> EffectCore model action c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall model action a. a -> EffectCore model action a
pure :: forall a. a -> EffectCore model action a
$c<*> :: forall model action a b.
EffectCore model action (a -> b)
-> EffectCore model action a -> EffectCore model action b
<*> :: forall a b.
EffectCore model action (a -> b)
-> EffectCore model action a -> EffectCore model action b
$cliftA2 :: forall model action a b c.
(a -> b -> c)
-> EffectCore model action a
-> EffectCore model action b
-> EffectCore model action c
liftA2 :: forall a b c.
(a -> b -> c)
-> EffectCore model action a
-> EffectCore model action b
-> EffectCore model action c
$c*> :: forall model action a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action b
*> :: forall a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action b
$c<* :: forall model action a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action a
<* :: forall a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action a
Applicative
    , Applicative (EffectCore model action)
Applicative (EffectCore model action) =>
(forall a b.
 EffectCore model action a
 -> (a -> EffectCore model action b) -> EffectCore model action b)
-> (forall a b.
    EffectCore model action a
    -> EffectCore model action b -> EffectCore model action b)
-> (forall a. a -> EffectCore model action a)
-> Monad (EffectCore model action)
forall a. a -> EffectCore model action a
forall model action. Applicative (EffectCore model action)
forall a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action b
forall a b.
EffectCore model action a
-> (a -> EffectCore model action b) -> EffectCore model action b
forall model action a. a -> EffectCore model action a
forall model action a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action b
forall model action a b.
EffectCore model action a
-> (a -> EffectCore model action b) -> EffectCore model action b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall model action a b.
EffectCore model action a
-> (a -> EffectCore model action b) -> EffectCore model action b
>>= :: forall a b.
EffectCore model action a
-> (a -> EffectCore model action b) -> EffectCore model action b
$c>> :: forall model action a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action b
>> :: forall a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action b
$creturn :: forall model action a. a -> EffectCore model action a
return :: forall a. a -> EffectCore model action a
Monad
    , MonadState model
    , MonadWriter [Sink action -> JSM ()]
    , MonadReader ComponentName
    )
-----------------------------------------------------------------------------
-- | @MonadFail@ instance for @EffectCore@
instance MonadFail (EffectCore model action) where
  fail :: forall a. String -> EffectCore model action a
fail String
s = do
    JSM () -> Effect model action
forall model action. JSM () -> Effect model action
io (JSM () -> Effect model action) -> JSM () -> Effect model action
forall a b. (a -> b) -> a -> b
$ ComponentName -> JSM ()
consoleError (String -> ComponentName
forall str. ToMisoString str => str -> ComponentName
ms String
s)
#if __GLASGOW_HASKELL__ <= 881
    Fail.fail s
#else
    String -> EffectCore model action a
forall a. String -> EffectCore model action a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s
#endif
-----------------------------------------------------------------------------
-- | Internal function used to unwrap an @EffectCore@
runEffect
    :: Effect model action
    -> MisoString
    -> model
    -> (model, [Sink action -> JSM ()])
runEffect :: forall model action.
Effect model action
-> ComponentName -> model -> (model, [Sink action -> JSM ()])
runEffect = RWS ComponentName [Sink action -> JSM ()] model ()
-> ComponentName -> model -> (model, [Sink action -> JSM ()])
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS (RWS ComponentName [Sink action -> JSM ()] model ()
 -> ComponentName -> model -> (model, [Sink action -> JSM ()]))
-> (Effect model action
    -> RWS ComponentName [Sink action -> JSM ()] model ())
-> Effect model action
-> ComponentName
-> model
-> (model, [Sink action -> JSM ()])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect model action
-> RWS ComponentName [Sink action -> JSM ()] model ()
forall model action a.
EffectCore model action a
-> RWS ComponentName [Sink action -> JSM ()] model a
runEffectCore
-----------------------------------------------------------------------------
-- | Turn a 'Sub' that consumes actions of type @a@ into a 'Sub' that consumes 
-- actions of type @b@ using the supplied function of type @a -> b@.
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)
-----------------------------------------------------------------------------
-- | Schedule a single 'IO' action for later execution.
--
-- Note that multiple 'IO' action can be scheduled using
-- @Control.Monad.Writer.Class.tell@ from the @mtl@ library.
io_ :: JSM action -> Effect model action
io_ :: forall action model. JSM action -> Effect model action
io_ JSM action
action = (Sink action -> JSM ()) -> Effect model action
forall action model. (Sink action -> JSM ()) -> Effect 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
>>=)
-----------------------------------------------------------------------------
-- | Like 'io_' but doesn't cause an action to be dispatched to
-- the @update@ function.
--
-- This is handy for scheduling @IO@ computations where you don't care
-- about their results or when they complete.
io :: JSM () -> Effect model action
io :: forall model action. JSM () -> Effect model action
io JSM ()
action = (Sink action -> JSM ()) -> Effect model action
forall action model. (Sink action -> JSM ()) -> Effect model action
withSink (\Sink action
_ -> JSM ()
action)
-----------------------------------------------------------------------------
-- | Like 'io' but generalized to any instance of 'Foldable'
--
-- This is handy for scheduling @IO@ computations that return a @Maybe@ value
--
for :: Foldable f => JSM (f action) -> Effect model action
for :: forall (f :: * -> *) action model.
Foldable f =>
JSM (f action) -> Effect model action
for JSM (f action)
actions = (Sink action -> JSM ()) -> Effect model action
forall action model. (Sink action -> JSM ()) -> Effect model action
withSink ((Sink action -> JSM ()) -> Effect model action)
-> (Sink action -> JSM ()) -> Effect 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
-----------------------------------------------------------------------------
-- | @sink@ allows users to access the sink of the 'Component' or top-level
-- 'App' in their application. This is useful for introducing 'IO' into the system.
--
-- A use-case is scheduling an 'IO' computation which creates a 3rd-party JS
-- widget which has an associated callback. The callback can then call the sink
-- to turn events into actions. To do this without accessing a sink requires
-- going via a @'Sub'scription@ which introduces a leaky-abstraction.
--
-- > update FetchJSON = withSink $ \sink -> getJSON (sink . ReceivedJSON) (sink . HandleError)
--
withSink :: (Sink action -> JSM ()) -> Effect model action
withSink :: forall action model. (Sink action -> JSM ()) -> Effect model action
withSink Sink action -> JSM ()
f = [Sink action -> JSM ()] -> EffectCore model action ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ Sink action -> JSM ()
f ]
-----------------------------------------------------------------------------
-- | A synonym for @tell@, specialized to @Effect@
--
-- > update :: Action -> Effect Model Action
-- > update = \case
-- >   Click -> issue HelloWorld
--
-- @since 1.9.0.0
--
-- Used to issue new @action@
issue :: action -> Effect model action
issue :: forall action model. action -> Effect model action
issue action
action = [(action -> JSM ()) -> JSM ()] -> EffectCore model action ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ \action -> JSM ()
f -> action -> JSM ()
f action
action ]
-----------------------------------------------------------------------------
{-# DEPRECATED scheduleIO "Please use 'io_' instead" #-}
scheduleIO :: JSM action -> Effect model action
scheduleIO :: forall action model. JSM action -> Effect model action
scheduleIO = JSM action -> Effect model action
forall action model. JSM action -> Effect model action
io_
-----------------------------------------------------------------------------
{-# DEPRECATED scheduleIO_ "Please use 'io' instead" #-}
scheduleIO_ :: JSM () -> Effect model action
scheduleIO_ :: forall model action. JSM () -> Effect model action
scheduleIO_ = JSM () -> Effect model action
forall model action. JSM () -> Effect model action
io
-----------------------------------------------------------------------------
{-# DEPRECATED scheduleIOFor_ "Please use 'for' instead" #-}
scheduleIOFor_ :: Foldable f => JSM (f action) -> Effect model action
scheduleIOFor_ :: forall (f :: * -> *) action model.
Foldable f =>
JSM (f action) -> Effect model action
scheduleIOFor_ = JSM (f action) -> Effect model action
forall (f :: * -> *) action model.
Foldable f =>
JSM (f action) -> Effect model action
for
-----------------------------------------------------------------------------
{-# DEPRECATED scheduleSub "Please use 'withSink' instead" #-}
scheduleSub :: (Sink action -> JSM ()) -> Effect model action
scheduleSub :: forall action model. (Sink action -> JSM ()) -> Effect model action
scheduleSub = (Sink action -> JSM ()) -> Effect model action
forall action model. (Sink action -> JSM ()) -> Effect model action
withSink
-----------------------------------------------------------------------------
{-# DEPRECATED effectSub "Please use 'put' and 'withSink' instead " #-}
effectSub :: model -> (Sink action -> JSM ()) -> Effect model action
effectSub :: forall model action.
model -> (Sink action -> JSM ()) -> Effect model action
effectSub model
m Sink action -> JSM ()
s = model -> EffectCore model action ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put model
m EffectCore model action ()
-> EffectCore model action () -> EffectCore model action ()
forall a b.
EffectCore model action a
-> EffectCore model action b -> EffectCore model action b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Sink action -> JSM ()) -> EffectCore model action ()
forall action model. (Sink action -> JSM ()) -> Effect model action
withSink Sink action -> JSM ()
s
-----------------------------------------------------------------------------
{-# DEPRECATED noEff "Please use 'put' instead " #-}
noEff :: model -> Effect model action
noEff :: forall model action. model -> EffectCore model action ()
noEff = model -> EffectCore model action ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
-----------------------------------------------------------------------------
{-# DEPRECATED batchEff "Please use 'put' and 'batch' instead " #-}
batchEff :: model -> [JSM action] -> Effect model action
batchEff :: forall model action. model -> [JSM action] -> Effect model action
batchEff model
model [JSM action]
actions = do
  model -> EffectCore model action ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put model
model
  [JSM action] -> EffectCore model action ()
forall action model. [JSM action] -> Effect model action
batch [JSM action]
actions
-----------------------------------------------------------------------------