-----------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans       #-}
-----------------------------------------------------------------------------
-- |
-- 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.Component`.
--
----------------------------------------------------------------------------
module Miso.Effect
  ( -- ** Effect
    -- *** Types
    Effect
  , Sub
  , Sink
  , DOMRef
  , ComponentInfo (..)
  , ComponentId
  , mkComponentInfo
    -- *** Combinators
  , (<#)
  , (#>)
  , batch
  , batch_
  , io
  , io_
  , for
  , issue
  , withSink
  , mapSub
  , noop
  -- * Internal
  , runEffect
  -- * Deprecated
  , scheduleIO
  , scheduleIO_
  , scheduleIOFor_
  , scheduleSub
  , effectSub
  , batchEff
  , noEff
  ) where
-----------------------------------------------------------------------------
import           Data.Foldable (for_)
import           Control.Monad.RWS ( RWS, put, tell, execRWS )
import           Language.Javascript.JSaddle (JSVal)
#if __GLASGOW_HASKELL__ <= 881
import qualified Control.Monad.Fail as Fail
import           Data.Functor.Identity (Identity(..))
#endif
-----------------------------------------------------------------------------
import           Miso.FFI.Internal (JSM)
-----------------------------------------------------------------------------
mkComponentInfo
  :: ComponentId
  -- ^ Component ID
  -> DOMRef
  -- ^ DOM Reference
  -> ComponentInfo parent
mkComponentInfo :: forall parent. ComponentId -> DOMRef -> ComponentInfo parent
mkComponentInfo = ComponentId -> DOMRef -> ComponentInfo parent
forall parent. ComponentId -> DOMRef -> ComponentInfo parent
ComponentInfo
-----------------------------------------------------------------------------
-- | This is the 'Reader r' in 'Effect'. Accessible via 'ask'. It holds
-- a phantom type for `parent`. This is used as a witness when calling the
-- 'parent' function, and using 'prop'.
data ComponentInfo parent
  = ComponentInfo
  { forall parent. ComponentInfo parent -> ComponentId
_componentId :: ComponentId
  , forall parent. ComponentInfo parent -> DOMRef
_componentDOMRef :: DOMRef
  }
-----------------------------------------------------------------------------
type ComponentId = Int
-----------------------------------------------------------------------------
-- | 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 ()
-----------------------------------------------------------------------------
-- | 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 parent model action
<# :: forall model action parent.
model -> JSM action -> Effect parent model action
(<#) model
m JSM action
action = model
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put model
m RWST
  (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
forall a b.
RWST
  (ComponentInfo parent) [Sink action -> JSM ()] model Identity a
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity b
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Sink action -> JSM ()]
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ \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 ]
-----------------------------------------------------------------------------
-- | `Effect` smart constructor, flipped
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
(<#)
-----------------------------------------------------------------------------
-- | Smart constructor for an 'Effect' with multiple actions.
--
-- @since 1.9.0.0
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) [Sink action -> JSM ()] model Identity ()]
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
  [ [Sink action -> JSM ()]
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ \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
  ]
-----------------------------------------------------------------------------
-- | Like @batch@ but action are discarded
--
-- @since 1.9.0.0
batch_ :: [JSM ()] -> Effect parent model action
batch_ :: forall parent model action. [JSM ()] -> Effect parent model action
batch_ [JSM ()]
actions = [RWST
   (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()]
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
  [ [Sink action -> JSM ()]
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ JSM () -> Sink action -> JSM ()
forall a b. a -> b -> a
const JSM ()
action ]
  | JSM ()
action <- [JSM ()]
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 'io_'.
--
-- 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:
--
-- @
-- myComponent = Component
--   { update = \\case
--       MyAction1 -> do
--         field1 .= value1
--         counter += 1
--       MyAction2 -> do
--         field2 %= f
--         io_ $ do
--           putStrLn \"Hello\"
--           putStrLn \"World!\"
--   , ...
--   }
-- @
type Effect parent model action = RWS (ComponentInfo parent) [Sink action -> JSM ()] model ()
-----------------------------------------------------------------------------
-- | Type to represent a DOM reference
type DOMRef = JSVal
-----------------------------------------------------------------------------
-- | @MonadFail@ instance for @EffectCore@
#if __GLASGOW_HASKELL__ <= 881
instance Fail.MonadFail Identity where
  fail = error
#endif
-----------------------------------------------------------------------------
-- | Internal function used to unwrap an @EffectCore@
runEffect
    :: Effect parent model action
    -> ComponentInfo parent
    -> model
    -> (model, [Sink action -> JSM ()])
runEffect :: forall parent model action.
Effect parent model action
-> ComponentInfo parent
-> model
-> (model, [Sink action -> JSM ()])
runEffect = RWS (ComponentInfo parent) [Sink action -> JSM ()] model ()
-> ComponentInfo parent
-> model
-> (model, [Sink action -> JSM ()])
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS
-----------------------------------------------------------------------------
-- | 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.
--
-- @since 1.9.0.0
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
>>=)
-----------------------------------------------------------------------------
-- | 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.
--
-- @since 1.9.0.0
io_ :: JSM () -> Effect parent model action
io_ :: forall parent model action. JSM () -> Effect parent model action
io_ JSM ()
action = (Sink action -> JSM ()) -> Effect parent model action
forall action parent model.
(Sink action -> JSM ()) -> Effect parent 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
--
-- @since 1.9.0.0
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
-----------------------------------------------------------------------------
-- | @withSink@ allows users to access the sink of the 'Component' or top-level
-- 'Component' in their application. This is useful for introducing 'IO' into the system.
-- A synonym for 'Control.Monad.Writer.tell', specialized to 'Effect'.
--
-- 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)
--
-- @since 1.9.0.0
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 = [Sink action -> JSM ()]
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ Sink action -> JSM ()
f ]
-----------------------------------------------------------------------------
-- | Issue a new 'Action' to be processed by 'update'.
--
-- > update :: Action -> Effect Model Action
-- > update = \case
-- >   Click -> issue HelloWorld
--
-- @since 1.9.0.0
issue :: action -> Effect parent model action
issue :: forall action parent model. action -> Effect parent model action
issue action
action = [(action -> JSM ()) -> JSM ()]
-> RWST
     (ComponentInfo parent)
     [(action -> JSM ()) -> JSM ()]
     model
     Identity
     ()
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 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 parent model action. JSM () -> 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) [Sink action -> JSM ()] model Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put model
m RWST
  (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
forall a b.
RWST
  (ComponentInfo parent) [Sink action -> JSM ()] model Identity a
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity b
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Sink action -> JSM ())
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] 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) [Sink action -> JSM ()] 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) [Sink action -> JSM ()] model Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put model
model
  [JSM action]
-> RWST
     (ComponentInfo parent) [Sink action -> JSM ()] model Identity ()
forall action parent model.
[JSM action] -> Effect parent model action
batch [JSM action]
actions
-----------------------------------------------------------------------------
-- | Helper for 'Component' construction, when you want to ignore the 'update'
-- function temporarily, or permanently.
--
-- @since 1.9.0.0
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) [Sink action -> JSM ()] model Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
-----------------------------------------------------------------------------