{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}


{-|
  Shpadoinkle Continuation is the abstract structure of Shpadoinkle's event handling system.
  It allows for asynchronous effects in event handlers by providing a model for atomic updates
  of application state.
-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}


module Shpadoinkle.Continuation (
  -- * The Continuation Type
  Continuation (..)
  , runContinuation
  , done, pur, impur, kleisli, causes, causedBy, merge, contIso, before, after
  -- * The Class
  , Continuous (..)
  -- ** Hoist
  , hoist
  -- * Forgetting
  , voidC', voidC, forgetC
  -- * Lifts
  , liftC', liftCMay', liftC, liftCMay
  -- * Utilities
  -- ** Product
  , leftC', leftC, rightC', rightC
  -- ** Coproduct
  , eitherC', eitherC
  -- ** Maybe
  , maybeC', maybeC, comaybe, comaybeC', comaybeC
  -- * Updates
  , writeUpdate, shouldUpdate, constUpdate
  -- * Monad Transformer
  , ContinuationT (..), voidRunContinuationT, kleisliT, commit
  -- * Re-exports
  , module Control.DeepSeq
  ) where


import           Control.Arrow                       (first)
import qualified Control.Categorical.Functor         as F
import           Control.DeepSeq                     (NFData (..), force)
import           Control.Monad                       (void)
import           Control.Monad.Trans.Class           (MonadTrans (..))
import           Control.PseudoInverseCategory       (EndoIso (..))
import           Data.Foldable                       (traverse_)
import           Data.Maybe                          (fromMaybe)
import           GHC.Conc                            (retry)
import           GHCJS.DOM                           (currentWindowUnchecked)
import           GHCJS.DOM.Window                    (Window)
import           GHCJS.DOM.WindowOrWorkerGlobalScope (clearTimeout, setTimeout)
import           Language.Javascript.JSaddle         (MonadJSM, fun, JSM)
import           UnliftIO                            (MonadUnliftIO, TVar,
                                                      UnliftIO, askUnliftIO,
                                                      atomically, liftIO,
                                                      newTVarIO, readTVar,
                                                      readTVarIO, unliftIO,
                                                      writeTVar)
import           UnliftIO.Concurrent                 (forkIO)


-- | A Continuation builds up an
--   atomic state update incrementally in a series of stages. For each stage we perform
--   a monadic IO computation and we may get a pure state updating function. When
--   all of the stages have been executed we are left with a composition of the resulting
--   pure state updating functions, and this composition is applied atomically to the state.
--
--   Additionally, a Continuation stage may feature a Rollback action which cancels all state
--   updates generated so far but allows for further state updates to be generated based on
--   further monadic IO computation.
--
--   The functions generating each stage of the Continuation
--   are called with states which reflect the current state of the app, with all
--   the pure state updating functions generated so far having been
--   applied to it, so that each stage "sees" both the current state
--   (even if it changed since the start of computing the Continuation), and the updates made
--   so far, although those updates are not committed to the real state until the Continuation
--   finishes and they are all done atomically together.
data Continuation m a = Continuation (a -> a) (a -> m (Continuation m a))
                      | Rollback (Continuation m a)
                      | Merge (Continuation m a)
                      | Pure (a -> a)



-- | A pure state updating function can be turned into a Continuation. This function
--   is here so that users of the Continuation API can do basic things without needing
--   to depend on the internal structure of the type.
pur :: (a -> a) -> Continuation m a
pur :: (a -> a) -> Continuation m a
pur = (a -> a) -> Continuation m a
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure


-- | A Continuation which doesn't touch the state and doesn't have any side effects
done :: Continuation m a
done :: Continuation m a
done = (a -> a) -> Continuation m a
forall a (m :: * -> *). (a -> a) -> Continuation m a
pur a -> a
forall a. a -> a
id


-- | A monadic computation of a pure state updating function can be turned into a Continuation.
{-# SPECIALIZE impur :: JSM (a -> a) -> Continuation JSM a #-}
impur :: Applicative m => m (a -> a) -> Continuation m a
impur :: m (a -> a) -> Continuation m a
impur m (a -> a)
m = (a -> m (Continuation m a)) -> Continuation m a
forall a (m :: * -> *).
(a -> m (Continuation m a)) -> Continuation m a
kleisli ((a -> m (Continuation m a)) -> Continuation m a)
-> (m (Continuation m a) -> a -> m (Continuation m a))
-> m (Continuation m a)
-> Continuation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Continuation m a) -> a -> m (Continuation m a)
forall a b. a -> b -> a
const (m (Continuation m a) -> Continuation m a)
-> m (Continuation m a) -> Continuation m a
forall a b. (a -> b) -> a -> b
$ (\a -> a
f -> (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
f (m (Continuation m a) -> a -> m (Continuation m a)
forall a b. a -> b -> a
const (Continuation m a -> m (Continuation m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Continuation m a
forall (m :: * -> *) a. Continuation m a
done))) ((a -> a) -> Continuation m a)
-> m (a -> a) -> m (Continuation m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a -> a)
m


-- | This turns a Kleisli arrow for computing a Continuation into the Continuation which
--   reads the state, runs the monadic computation specified by the arrow on that state,
--   and runs the resulting Continuation.
kleisli :: (a -> m (Continuation m a)) -> Continuation m a
kleisli :: (a -> m (Continuation m a)) -> Continuation m a
kleisli = (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
forall a. a -> a
id


-- | A monadic computation can be turned into a Continuation which does not touch the state.
{-# SPECIALIZE causes :: JSM () -> Continuation JSM a #-}
causes :: Applicative m => m () -> Continuation m a
causes :: m () -> Continuation m a
causes m ()
m = m (a -> a) -> Continuation m a
forall (m :: * -> *) a.
Applicative m =>
m (a -> a) -> Continuation m a
impur (a -> a
forall a. a -> a
id (a -> a) -> m () -> m (a -> a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m ()
m)


causedBy :: m (Continuation m a) -> Continuation m a
causedBy :: m (Continuation m a) -> Continuation m a
causedBy = (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
forall a. a -> a
id ((a -> m (Continuation m a)) -> Continuation m a)
-> (m (Continuation m a) -> a -> m (Continuation m a))
-> m (Continuation m a)
-> Continuation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Continuation m a) -> a -> m (Continuation m a)
forall a b. a -> b -> a
const


-- | A continuation can be forced to write its changes midflight.
merge :: Continuation m a -> Continuation m a
merge :: Continuation m a -> Continuation m a
merge = Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge


-- | Sequences two continuations one after the other.
before :: Applicative m => Continuation m a -> Continuation m a -> Continuation m a
Pure a -> a
f before :: Continuation m a -> Continuation m a -> Continuation m a
`before` Continuation a -> a
g a -> m (Continuation m a)
h = (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation (a -> a
g (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f) a -> m (Continuation m a)
h
Pure a -> a
_ `before` Rollback Continuation m a
g = Continuation m a
g
Pure a -> a
f `before` Merge Continuation m a
g = (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
f (m (Continuation m a) -> a -> m (Continuation m a)
forall a b. a -> b -> a
const (Continuation m a -> m (Continuation m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge Continuation m a
g)))
Pure a -> a
f `before` Pure a -> a
g = (a -> a) -> Continuation m a
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure (a -> a
g(a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
f)
Merge Continuation m a
f `before` Continuation m a
g = Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge (Continuation m a
f Continuation m a -> Continuation m a -> Continuation m a
forall (m :: * -> *) a.
Applicative m =>
Continuation m a -> Continuation m a -> Continuation m a
`before` Continuation m a
g)
Rollback Continuation m a
f `before` Continuation m a
g = Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback (Continuation m a
f Continuation m a -> Continuation m a -> Continuation m a
forall (m :: * -> *) a.
Applicative m =>
Continuation m a -> Continuation m a -> Continuation m a
`before` Continuation m a
g)
Continuation a -> a
f a -> m (Continuation m a)
g `before` Continuation m a
h = (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
f ((a -> m (Continuation m a)) -> Continuation m a)
-> (a -> m (Continuation m a)) -> Continuation m a
forall a b. (a -> b) -> a -> b
$ (Continuation m a -> Continuation m a)
-> m (Continuation m a) -> m (Continuation m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Continuation m a -> Continuation m a -> Continuation m a
forall (m :: * -> *) a.
Applicative m =>
Continuation m a -> Continuation m a -> Continuation m a
`before` Continuation m a
h) (m (Continuation m a) -> m (Continuation m a))
-> (a -> m (Continuation m a)) -> a -> m (Continuation m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (Continuation m a)
g


after :: Applicative m => Continuation m a -> Continuation m a -> Continuation m a
after :: Continuation m a -> Continuation m a -> Continuation m a
after = (Continuation m a -> Continuation m a -> Continuation m a)
-> Continuation m a -> Continuation m a -> Continuation m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Continuation m a -> Continuation m a -> Continuation m a
forall (m :: * -> *) a.
Applicative m =>
Continuation m a -> Continuation m a -> Continuation m a
before


-- | 'runContinuation' takes a 'Continuation' and a state value and runs the whole Continuation
--   as if the real state was frozen at the value given to 'runContinuation'. It performs all the
--   IO actions in the stages of the Continuation and returns a pure state updating function
--   which is the composition of all the pure state updating functions generated by the
--   non-rolled-back stages of the Continuation. If you are trying to update a 'Continuous'
--   territory, then you should probably be using 'writeUpdate' instead of 'runContinuation',
--   because 'writeUpdate' will allow each stage of the Continuation to see any extant updates
--   made to the territory after the Continuation started running.
{-# SPECIALIZE runContinuation :: Continuation JSM a -> a -> JSM (a -> a) #-}
runContinuation :: Monad m => Continuation m a -> a -> m (a -> a)
runContinuation :: Continuation m a -> a -> m (a -> a)
runContinuation = (a -> a) -> Continuation m a -> a -> m (a -> a)
forall (m :: * -> *) a.
Monad m =>
(a -> a) -> Continuation m a -> a -> m (a -> a)
runContinuation' a -> a
forall a. a -> a
id


{-# SPECIALIZE runContinuation' :: (a -> a) -> Continuation JSM a -> a -> JSM (a -> a) #-}
runContinuation' :: Monad m => (a -> a) -> Continuation m a -> a -> m (a -> a)
runContinuation' :: (a -> a) -> Continuation m a -> a -> m (a -> a)
runContinuation' a -> a
f (Continuation a -> a
g a -> m (Continuation m a)
h) a
x = do
  Continuation m a
i <- a -> m (Continuation m a)
h (a -> a
f a
x)
  (a -> a) -> Continuation m a -> a -> m (a -> a)
forall (m :: * -> *) a.
Monad m =>
(a -> a) -> Continuation m a -> a -> m (a -> a)
runContinuation' (a -> a
g(a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
f) Continuation m a
i a
x
runContinuation' a -> a
_ (Rollback Continuation m a
f) a
x = (a -> a) -> Continuation m a -> a -> m (a -> a)
forall (m :: * -> *) a.
Monad m =>
(a -> a) -> Continuation m a -> a -> m (a -> a)
runContinuation' a -> a
forall a. a -> a
id Continuation m a
f a
x
runContinuation' a -> a
f (Merge Continuation m a
g) a
x = (a -> a) -> Continuation m a -> a -> m (a -> a)
forall (m :: * -> *) a.
Monad m =>
(a -> a) -> Continuation m a -> a -> m (a -> a)
runContinuation' a -> a
f Continuation m a
g a
x
runContinuation' a -> a
f (Pure a -> a
g) a
_ = (a -> a) -> m (a -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a
g(a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
f)


-- | @f@ is a Functor to Hask from the category where the objects are
--   Continuation types and the morphisms are functions.
class Continuous f where
  mapC :: (Continuation m a -> Continuation m b) -> f m a -> f m b


instance Continuous Continuation where
  mapC :: (Continuation m a -> Continuation m b)
-> Continuation m a -> Continuation m b
mapC = (Continuation m a -> Continuation m b)
-> Continuation m a -> Continuation m b
forall a. a -> a
id


-- | Given a natural transformation, change a Continuation's underlying functor.
{-# SPECIALIZE hoist :: (forall b. JSM b -> n b) -> Continuation JSM a -> Continuation n a #-}
hoist :: Functor m => (forall b. m b -> n b) -> Continuation m a -> Continuation n a
hoist :: (forall b. m b -> n b) -> Continuation m a -> Continuation n a
hoist forall b. m b -> n b
_ (Pure a -> a
f)              = (a -> a) -> Continuation n a
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure a -> a
f
hoist forall b. m b -> n b
f (Rollback Continuation m a
r)          = Continuation n a -> Continuation n a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback ((forall b. m b -> n b) -> Continuation m a -> Continuation n a
forall (m :: * -> *) (n :: * -> *) a.
Functor m =>
(forall b. m b -> n b) -> Continuation m a -> Continuation n a
hoist forall b. m b -> n b
f Continuation m a
r)
hoist forall b. m b -> n b
f (Merge Continuation m a
g)             = Continuation n a -> Continuation n a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge ((forall b. m b -> n b) -> Continuation m a -> Continuation n a
forall (m :: * -> *) (n :: * -> *) a.
Functor m =>
(forall b. m b -> n b) -> Continuation m a -> Continuation n a
hoist forall b. m b -> n b
f Continuation m a
g)
hoist forall b. m b -> n b
f (Continuation a -> a
g a -> m (Continuation m a)
h) = (a -> a) -> (a -> n (Continuation n a)) -> Continuation n a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
g ((a -> n (Continuation n a)) -> Continuation n a)
-> (a -> n (Continuation n a)) -> Continuation n a
forall a b. (a -> b) -> a -> b
$ \a
x -> m (Continuation n a) -> n (Continuation n a)
forall b. m b -> n b
f (m (Continuation n a) -> n (Continuation n a))
-> m (Continuation n a) -> n (Continuation n a)
forall a b. (a -> b) -> a -> b
$ (forall b. m b -> n b) -> Continuation m a -> Continuation n a
forall (m :: * -> *) (n :: * -> *) a.
Functor m =>
(forall b. m b -> n b) -> Continuation m a -> Continuation n a
hoist forall b. m b -> n b
f (Continuation m a -> Continuation n a)
-> m (Continuation m a) -> m (Continuation n a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m (Continuation m a)
h a
x


-- | Apply a lens inside a Continuation to change the Continuation's type.
{-# SPECIALIZE liftC' :: (a -> b -> b) -> (b -> a) -> Continuation JSM a -> Continuation JSM b #-}
liftC' :: Functor m => (a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
liftC' :: (a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
liftC' a -> b -> b
f b -> a
g (Pure a -> a
h)              = (b -> b) -> Continuation m b
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure (\b
x -> a -> b -> b
f (a -> a
h (b -> a
g b
x)) b
x)
liftC' a -> b -> b
f b -> a
g (Rollback Continuation m a
r)          = Continuation m b -> Continuation m b
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback ((a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Functor m =>
(a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
liftC' a -> b -> b
f b -> a
g Continuation m a
r)
liftC' a -> b -> b
f b -> a
g (Merge Continuation m a
h)             = Continuation m b -> Continuation m b
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge ((a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Functor m =>
(a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
liftC' a -> b -> b
f b -> a
g Continuation m a
h)
liftC' a -> b -> b
f b -> a
g (Continuation a -> a
h a -> m (Continuation m a)
i) = (b -> b) -> (b -> m (Continuation m b)) -> Continuation m b
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation (\b
x -> a -> b -> b
f (a -> a
h (b -> a
g b
x)) b
x) (\b
x -> (a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Functor m =>
(a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
liftC' a -> b -> b
f b -> a
g (Continuation m a -> Continuation m b)
-> m (Continuation m a) -> m (Continuation m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m (Continuation m a)
i (b -> a
g b
x))


-- | Apply a traversal inside a Continuation to change the Continuation's type.
{-# SPECIALIZE liftCMay' :: (a -> b -> b) -> (b -> Maybe a) -> Continuation JSM a -> Continuation JSM b #-}
liftCMay' :: Applicative m => (a -> b -> b) -> (b -> Maybe a) -> Continuation m a -> Continuation m b
liftCMay' :: (a -> b -> b)
-> (b -> Maybe a) -> Continuation m a -> Continuation m b
liftCMay' a -> b -> b
f b -> Maybe a
g (Pure a -> a
h)     = (b -> b) -> Continuation m b
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure ((b -> b) -> Continuation m b) -> (b -> b) -> Continuation m b
forall a b. (a -> b) -> a -> b
$ \b
x -> b -> (a -> b) -> Maybe a -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
x ((a -> b -> b) -> b -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> b
f b
x (a -> b) -> (a -> a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
h) (Maybe a -> b) -> Maybe a -> b
forall a b. (a -> b) -> a -> b
$ b -> Maybe a
g b
x
liftCMay' a -> b -> b
f b -> Maybe a
g (Rollback Continuation m a
r) = Continuation m b -> Continuation m b
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback ((a -> b -> b)
-> (b -> Maybe a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Applicative m =>
(a -> b -> b)
-> (b -> Maybe a) -> Continuation m a -> Continuation m b
liftCMay' a -> b -> b
f b -> Maybe a
g Continuation m a
r)
liftCMay' a -> b -> b
f b -> Maybe a
g (Merge Continuation m a
h)    = Continuation m b -> Continuation m b
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge ((a -> b -> b)
-> (b -> Maybe a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Applicative m =>
(a -> b -> b)
-> (b -> Maybe a) -> Continuation m a -> Continuation m b
liftCMay' a -> b -> b
f b -> Maybe a
g Continuation m a
h)
liftCMay' a -> b -> b
f b -> Maybe a
g (Continuation a -> a
h a -> m (Continuation m a)
i) =
  (b -> b) -> (b -> m (Continuation m b)) -> Continuation m b
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation (\b
x -> b -> (a -> b) -> Maybe a -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
x ((a -> b -> b) -> b -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> b
f b
x (a -> b) -> (a -> a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
h) (Maybe a -> b) -> Maybe a -> b
forall a b. (a -> b) -> a -> b
$ b -> Maybe a
g b
x) ( m (Continuation m b)
-> (a -> m (Continuation m b)) -> Maybe a -> m (Continuation m b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Continuation m b -> m (Continuation m b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Continuation m b
forall (m :: * -> *) a. Continuation m a
done) ((Continuation m a -> Continuation m b)
-> m (Continuation m a) -> m (Continuation m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b -> b)
-> (b -> Maybe a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Applicative m =>
(a -> b -> b)
-> (b -> Maybe a) -> Continuation m a -> Continuation m b
liftCMay' a -> b -> b
f b -> Maybe a
g) (m (Continuation m a) -> m (Continuation m b))
-> (a -> m (Continuation m a)) -> a -> m (Continuation m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (Continuation m a)
i) (Maybe a -> m (Continuation m b))
-> (b -> Maybe a) -> b -> m (Continuation m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe a
g)


-- | Given a lens, change the value type of @f@ by applying the lens in the Continuations inside @f@.
{-# SPECIALIZE liftC :: Functor m => (a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b #-}
liftC :: Functor m => Continuous f => (a -> b -> b) -> (b -> a) -> f m a -> f m b
liftC :: (a -> b -> b) -> (b -> a) -> f m a -> f m b
liftC a -> b -> b
f b -> a
g = (Continuation m a -> Continuation m b) -> f m a -> f m b
forall (f :: (* -> *) -> * -> *) (m :: * -> *) a b.
Continuous f =>
(Continuation m a -> Continuation m b) -> f m a -> f m b
mapC ((a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Functor m =>
(a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
liftC' a -> b -> b
f b -> a
g)


-- | Given a traversal, change the value of @f@ by apply the traversal in the Continuations inside @f@.
{-# SPECIALIZE liftCMay :: Applicative m => (a -> b -> b) -> (b -> Maybe a) -> Continuation m a -> Continuation m b #-}
liftCMay :: Applicative m => Continuous f => (a -> b -> b) -> (b -> Maybe a) -> f m a -> f m b
liftCMay :: (a -> b -> b) -> (b -> Maybe a) -> f m a -> f m b
liftCMay a -> b -> b
f b -> Maybe a
g = (Continuation m a -> Continuation m b) -> f m a -> f m b
forall (f :: (* -> *) -> * -> *) (m :: * -> *) a b.
Continuous f =>
(Continuation m a -> Continuation m b) -> f m a -> f m b
mapC ((a -> b -> b)
-> (b -> Maybe a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Applicative m =>
(a -> b -> b)
-> (b -> Maybe a) -> Continuation m a -> Continuation m b
liftCMay' a -> b -> b
f b -> Maybe a
g)


-- | Change a void continuation into any other type of Continuation.
{-# SPECIALIZE voidC' :: Continuation JSM () -> Continuation JSM a #-}
voidC' :: Monad m => Continuation m () -> Continuation m a
voidC' :: Continuation m () -> Continuation m a
voidC' Continuation m ()
f = (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
forall a. a -> a
id ((a -> m (Continuation m a)) -> Continuation m a)
-> (a -> m (Continuation m a)) -> Continuation m a
forall a b. (a -> b) -> a -> b
$ \a
_ -> do
  () -> ()
_ <- Continuation m () -> () -> m (() -> ())
forall (m :: * -> *) a.
Monad m =>
Continuation m a -> a -> m (a -> a)
runContinuation Continuation m ()
f ()
  Continuation m a -> m (Continuation m a)
forall (m :: * -> *) a. Monad m => a -> m a
return Continuation m a
forall (m :: * -> *) a. Continuation m a
done


-- | Change the type of the f-embedded void Continuations into any other type of Continuation.
{-# SPECIALIZE voidC :: Monad m => Continuation m () -> Continuation m a #-}
{-# SPECIALIZE voidC :: Continuation JSM () -> Continuation JSM a #-}
voidC :: Monad m => Continuous f => f m () -> f m a
voidC :: f m () -> f m a
voidC = (Continuation m () -> Continuation m a) -> f m () -> f m a
forall (f :: (* -> *) -> * -> *) (m :: * -> *) a b.
Continuous f =>
(Continuation m a -> Continuation m b) -> f m a -> f m b
mapC Continuation m () -> Continuation m a
forall (m :: * -> *) a.
Monad m =>
Continuation m () -> Continuation m a
voidC'


-- | Forget about the Continuations.
{-# SPECIALIZE forgetC :: Continuation m a -> Continuation m b #-}
{-# SPECIALIZE forgetC :: Continuation JSM a -> Continuation JSM b #-}
forgetC :: Continuous f => f m a -> f m b
forgetC :: f m a -> f m b
forgetC = (Continuation m a -> Continuation m b) -> f m a -> f m b
forall (f :: (* -> *) -> * -> *) (m :: * -> *) a b.
Continuous f =>
(Continuation m a -> Continuation m b) -> f m a -> f m b
mapC (Continuation m b -> Continuation m a -> Continuation m b
forall a b. a -> b -> a
const Continuation m b
forall (m :: * -> *) a. Continuation m a
done)


--- | Change the type of a Continuation by applying it to the left coordinate of a tuple.
{-# SPECIALIZE leftC' :: Continuation JSM a -> Continuation JSM (a,b) #-}
leftC' :: Functor m => Continuation m a -> Continuation m (a,b)
leftC' :: Continuation m a -> Continuation m (a, b)
leftC' = (a -> (a, b) -> (a, b))
-> ((a, b) -> a) -> Continuation m a -> Continuation m (a, b)
forall (m :: * -> *) a b.
Functor m =>
(a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
liftC' (\a
x (a
_,b
y) -> (a
x,b
y)) (a, b) -> a
forall a b. (a, b) -> a
fst


-- | Change the type of @f@ by applying the Continuations inside @f@ to the left coordinate of a tuple.
{-# SPECIALIZE leftC :: Continuation JSM a -> Continuation JSM (a,b) #-}
leftC :: Functor m => Continuous f => f m a -> f m (a,b)
leftC :: f m a -> f m (a, b)
leftC = (Continuation m a -> Continuation m (a, b)) -> f m a -> f m (a, b)
forall (f :: (* -> *) -> * -> *) (m :: * -> *) a b.
Continuous f =>
(Continuation m a -> Continuation m b) -> f m a -> f m b
mapC Continuation m a -> Continuation m (a, b)
forall (m :: * -> *) a b.
Functor m =>
Continuation m a -> Continuation m (a, b)
leftC'


-- | Change the type of a Continuation by applying it to the right coordinate of a tuple.
{-# SPECIALIZE rightC' :: Continuation JSM b -> Continuation JSM (a,b) #-}
rightC' :: Functor m => Continuation m b -> Continuation m (a,b)
rightC' :: Continuation m b -> Continuation m (a, b)
rightC' = (b -> (a, b) -> (a, b))
-> ((a, b) -> b) -> Continuation m b -> Continuation m (a, b)
forall (m :: * -> *) a b.
Functor m =>
(a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
liftC' (\b
y (a
x,b
_) -> (a
x,b
y)) (a, b) -> b
forall a b. (a, b) -> b
snd


-- | Change the value type of @f@ by applying the Continuations inside @f@ to the right coordinate of a tuple.
{-# SPECIALIZE rightC :: Continuation JSM b -> Continuation JSM (a,b) #-}
rightC :: Functor m => Continuous f => f m b -> f m (a,b)
rightC :: f m b -> f m (a, b)
rightC = (Continuation m b -> Continuation m (a, b)) -> f m b -> f m (a, b)
forall (f :: (* -> *) -> * -> *) (m :: * -> *) a b.
Continuous f =>
(Continuation m a -> Continuation m b) -> f m a -> f m b
mapC Continuation m b -> Continuation m (a, b)
forall (m :: * -> *) b a.
Functor m =>
Continuation m b -> Continuation m (a, b)
rightC'


-- | Transform a Continuation to work on 'Maybe's. If it encounters 'Nothing', then it cancels itself.
{-# SPECIALIZE maybeC' :: Continuation JSM a -> Continuation JSM (Maybe a) #-}
maybeC' :: Applicative m => Continuation m a -> Continuation m (Maybe a)
maybeC' :: Continuation m a -> Continuation m (Maybe a)
maybeC' (Pure a -> a
f)              = (Maybe a -> Maybe a) -> Continuation m (Maybe a)
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure ((a -> a) -> Maybe a -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f)
maybeC' (Rollback Continuation m a
r)          = Continuation m (Maybe a) -> Continuation m (Maybe a)
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback (Continuation m a -> Continuation m (Maybe a)
forall (m :: * -> *) a.
Applicative m =>
Continuation m a -> Continuation m (Maybe a)
maybeC' Continuation m a
r)
maybeC' (Merge Continuation m a
f)             = Continuation m (Maybe a) -> Continuation m (Maybe a)
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge (Continuation m a -> Continuation m (Maybe a)
forall (m :: * -> *) a.
Applicative m =>
Continuation m a -> Continuation m (Maybe a)
maybeC' Continuation m a
f)
maybeC' (Continuation a -> a
f a -> m (Continuation m a)
g) = (Maybe a -> Maybe a)
-> (Maybe a -> m (Continuation m (Maybe a)))
-> Continuation m (Maybe a)
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation ((a -> a) -> Maybe a -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f) ((Maybe a -> m (Continuation m (Maybe a)))
 -> Continuation m (Maybe a))
-> (Maybe a -> m (Continuation m (Maybe a)))
-> Continuation m (Maybe a)
forall a b. (a -> b) -> a -> b
$
  \case
    Just a
x  -> Continuation m a -> Continuation m (Maybe a)
forall (m :: * -> *) a.
Applicative m =>
Continuation m a -> Continuation m (Maybe a)
maybeC' (Continuation m a -> Continuation m (Maybe a))
-> m (Continuation m a) -> m (Continuation m (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m (Continuation m a)
g a
x
    Maybe a
Nothing -> Continuation m (Maybe a) -> m (Continuation m (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Continuation m (Maybe a) -> Continuation m (Maybe a)
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback Continuation m (Maybe a)
forall (m :: * -> *) a. Continuation m a
done)


-- | Change the value type of @f@ by transforming the Continuations inside @f@ to work on 'Maybe's using maybeC'.
{-# SPECIALIZE maybeC' :: Continuation JSM a -> Continuation JSM (Maybe a) #-}
maybeC :: Applicative m => Continuous f => f m a -> f m (Maybe a)
maybeC :: f m a -> f m (Maybe a)
maybeC = (Continuation m a -> Continuation m (Maybe a))
-> f m a -> f m (Maybe a)
forall (f :: (* -> *) -> * -> *) (m :: * -> *) a b.
Continuous f =>
(Continuation m a -> Continuation m b) -> f m a -> f m b
mapC Continuation m a -> Continuation m (Maybe a)
forall (m :: * -> *) a.
Applicative m =>
Continuation m a -> Continuation m (Maybe a)
maybeC'


-- | Turn a @Maybe a@ updating function into an @a@ updating function which acts as
--   the identity function when the input function outputs 'Nothing'.
comaybe :: (Maybe a -> Maybe a) -> (a -> a)
comaybe :: (Maybe a -> Maybe a) -> a -> a
comaybe Maybe a -> Maybe a
f a
x = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
x (Maybe a -> a) -> (Maybe a -> Maybe a) -> Maybe a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Maybe a
f (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x


-- | Change the type of a Maybe-valued Continuation into the Maybe-wrapped type.
--   The resulting Continuation acts like the input Continuation except that
--   when the input Continuation would replace the current value with 'Nothing',
--   instead the current value is retained.
{-# SPECIALIZE comaybeC' :: Continuation JSM (Maybe a) -> Continuation JSM a #-}
comaybeC' :: Functor m => Continuation m (Maybe a) -> Continuation m a
comaybeC' :: Continuation m (Maybe a) -> Continuation m a
comaybeC' (Pure Maybe a -> Maybe a
f)             = (a -> a) -> Continuation m a
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure ((Maybe a -> Maybe a) -> a -> a
forall a. (Maybe a -> Maybe a) -> a -> a
comaybe Maybe a -> Maybe a
f)
comaybeC' (Rollback Continuation m (Maybe a)
r)         = Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback (Continuation m (Maybe a) -> Continuation m a
forall (m :: * -> *) a.
Functor m =>
Continuation m (Maybe a) -> Continuation m a
comaybeC' Continuation m (Maybe a)
r)
comaybeC' (Merge Continuation m (Maybe a)
f)            = Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge (Continuation m (Maybe a) -> Continuation m a
forall (m :: * -> *) a.
Functor m =>
Continuation m (Maybe a) -> Continuation m a
comaybeC' Continuation m (Maybe a)
f)
comaybeC' (Continuation Maybe a -> Maybe a
f Maybe a -> m (Continuation m (Maybe a))
g) = (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation ((Maybe a -> Maybe a) -> a -> a
forall a. (Maybe a -> Maybe a) -> a -> a
comaybe Maybe a -> Maybe a
f) ( (Continuation m (Maybe a) -> Continuation m a)
-> m (Continuation m (Maybe a)) -> m (Continuation m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Continuation m (Maybe a) -> Continuation m a
forall (m :: * -> *) a.
Functor m =>
Continuation m (Maybe a) -> Continuation m a
comaybeC' (m (Continuation m (Maybe a)) -> m (Continuation m a))
-> (a -> m (Continuation m (Maybe a))) -> a -> m (Continuation m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> m (Continuation m (Maybe a))
g (Maybe a -> m (Continuation m (Maybe a)))
-> (a -> Maybe a) -> a -> m (Continuation m (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)


-- | Transform the Continuations inside @f@ using comaybeC'.
{-# SPECIALIZE comaybeC :: Continuation JSM (Maybe a) -> Continuation JSM a #-}
comaybeC :: Functor m => Continuous f => f m (Maybe a) -> f m a
comaybeC :: f m (Maybe a) -> f m a
comaybeC = (Continuation m (Maybe a) -> Continuation m a)
-> f m (Maybe a) -> f m a
forall (f :: (* -> *) -> * -> *) (m :: * -> *) a b.
Continuous f =>
(Continuation m a -> Continuation m b) -> f m a -> f m b
mapC Continuation m (Maybe a) -> Continuation m a
forall (m :: * -> *) a.
Functor m =>
Continuation m (Maybe a) -> Continuation m a
comaybeC'


-- Just define these rather than introducing another dependency even though they are in either
mapLeft :: (a -> b) -> Either a c -> Either b c
mapLeft :: (a -> b) -> Either a c -> Either b c
mapLeft a -> b
f (Left a
x)  = b -> Either b c
forall a b. a -> Either a b
Left (a -> b
f a
x)
mapLeft a -> b
_ (Right c
x) = c -> Either b c
forall a b. b -> Either a b
Right c
x


mapRight :: (b -> c) -> Either a b -> Either a c
mapRight :: (b -> c) -> Either a b -> Either a c
mapRight b -> c
_ (Left a
x)  = a -> Either a c
forall a b. a -> Either a b
Left a
x
mapRight b -> c
f (Right b
x) = c -> Either a c
forall a b. b -> Either a b
Right (b -> c
f b
x)


-- | Combine Continuations heterogeneously into coproduct Continuations.
--   The first value the Continuation sees determines which of the
--   two input Continuation branches it follows. If the coproduct Continuation
--   sees the state change to a different Either-branch, then it cancels itself.
--   If the state is in a different Either-branch when the Continuation
--   completes than it was when the Continuation started, then the
--   coproduct Continuation will have no effect on the state.
{-# SPECIALIZE eitherC' :: Continuation JSM a -> Continuation JSM b -> Continuation JSM (Either a b) #-}
eitherC' :: Applicative m => Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' :: Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' Continuation m a
f Continuation m b
g = (Either a b -> Either a b)
-> (Either a b -> m (Continuation m (Either a b)))
-> Continuation m (Either a b)
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation Either a b -> Either a b
forall a. a -> a
id ((Either a b -> m (Continuation m (Either a b)))
 -> Continuation m (Either a b))
-> (Either a b -> m (Continuation m (Either a b)))
-> Continuation m (Either a b)
forall a b. (a -> b) -> a -> b
$ \case
  Left a
x -> case Continuation m a
f of
    Pure a -> a
h -> Continuation m (Either a b) -> m (Continuation m (Either a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Either a b -> Either a b) -> Continuation m (Either a b)
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure ((a -> a) -> Either a b -> Either a b
forall a b c. (a -> b) -> Either a c -> Either b c
mapLeft a -> a
h))
    Rollback Continuation m a
r -> Continuation m (Either a b) -> m (Continuation m (Either a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Continuation m (Either a b) -> m (Continuation m (Either a b)))
-> (Continuation m (Either a b) -> Continuation m (Either a b))
-> Continuation m (Either a b)
-> m (Continuation m (Either a b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continuation m (Either a b) -> Continuation m (Either a b)
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback (Continuation m (Either a b) -> m (Continuation m (Either a b)))
-> Continuation m (Either a b) -> m (Continuation m (Either a b))
forall a b. (a -> b) -> a -> b
$ Continuation m a -> Continuation m b -> Continuation m (Either a b)
forall (m :: * -> *) a b.
Applicative m =>
Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' Continuation m a
r Continuation m b
forall (m :: * -> *) a. Continuation m a
done
    Merge Continuation m a
h -> Continuation m (Either a b) -> m (Continuation m (Either a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Continuation m (Either a b) -> m (Continuation m (Either a b)))
-> (Continuation m (Either a b) -> Continuation m (Either a b))
-> Continuation m (Either a b)
-> m (Continuation m (Either a b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continuation m (Either a b) -> Continuation m (Either a b)
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge (Continuation m (Either a b) -> m (Continuation m (Either a b)))
-> Continuation m (Either a b) -> m (Continuation m (Either a b))
forall a b. (a -> b) -> a -> b
$ Continuation m a -> Continuation m b -> Continuation m (Either a b)
forall (m :: * -> *) a b.
Applicative m =>
Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' Continuation m a
h Continuation m b
forall (m :: * -> *) a. Continuation m a
done
    Continuation a -> a
h a -> m (Continuation m a)
i ->
      (\Continuation m a
j -> (Either a b -> Either a b)
-> (Either a b -> m (Continuation m (Either a b)))
-> Continuation m (Either a b)
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation ((a -> a) -> Either a b -> Either a b
forall a b c. (a -> b) -> Either a c -> Either b c
mapLeft a -> a
h) ( m (Continuation m (Either a b))
-> Either a b -> m (Continuation m (Either a b))
forall a b. a -> b -> a
const (m (Continuation m (Either a b))
 -> Either a b -> m (Continuation m (Either a b)))
-> (Continuation m (Either a b) -> m (Continuation m (Either a b)))
-> Continuation m (Either a b)
-> Either a b
-> m (Continuation m (Either a b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continuation m (Either a b) -> m (Continuation m (Either a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Continuation m (Either a b)
 -> Either a b -> m (Continuation m (Either a b)))
-> Continuation m (Either a b)
-> Either a b
-> m (Continuation m (Either a b))
forall a b. (a -> b) -> a -> b
$ Continuation m a -> Continuation m b -> Continuation m (Either a b)
forall (m :: * -> *) a b.
Applicative m =>
Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' Continuation m a
j (Continuation m b -> Continuation m b
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback Continuation m b
forall (m :: * -> *) a. Continuation m a
done)))
        (Continuation m a -> Continuation m (Either a b))
-> m (Continuation m a) -> m (Continuation m (Either a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m (Continuation m a)
i a
x
  Right b
x -> case Continuation m b
g of
    Pure b -> b
h -> Continuation m (Either a b) -> m (Continuation m (Either a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Either a b -> Either a b) -> Continuation m (Either a b)
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure ((b -> b) -> Either a b -> Either a b
forall b c a. (b -> c) -> Either a b -> Either a c
mapRight b -> b
h))
    Rollback Continuation m b
r -> Continuation m (Either a b) -> m (Continuation m (Either a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Continuation m (Either a b) -> m (Continuation m (Either a b)))
-> (Continuation m (Either a b) -> Continuation m (Either a b))
-> Continuation m (Either a b)
-> m (Continuation m (Either a b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continuation m (Either a b) -> Continuation m (Either a b)
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback (Continuation m (Either a b) -> m (Continuation m (Either a b)))
-> Continuation m (Either a b) -> m (Continuation m (Either a b))
forall a b. (a -> b) -> a -> b
$ Continuation m a -> Continuation m b -> Continuation m (Either a b)
forall (m :: * -> *) a b.
Applicative m =>
Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' Continuation m a
forall (m :: * -> *) a. Continuation m a
done Continuation m b
r
    Merge Continuation m b
h -> Continuation m (Either a b) -> m (Continuation m (Either a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Continuation m (Either a b) -> m (Continuation m (Either a b)))
-> (Continuation m (Either a b) -> Continuation m (Either a b))
-> Continuation m (Either a b)
-> m (Continuation m (Either a b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continuation m (Either a b) -> Continuation m (Either a b)
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge (Continuation m (Either a b) -> m (Continuation m (Either a b)))
-> Continuation m (Either a b) -> m (Continuation m (Either a b))
forall a b. (a -> b) -> a -> b
$ Continuation m a -> Continuation m b -> Continuation m (Either a b)
forall (m :: * -> *) a b.
Applicative m =>
Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' Continuation m a
forall (m :: * -> *) a. Continuation m a
done Continuation m b
h
    Continuation b -> b
h b -> m (Continuation m b)
i ->
      (\Continuation m b
j -> (Either a b -> Either a b)
-> (Either a b -> m (Continuation m (Either a b)))
-> Continuation m (Either a b)
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation ((b -> b) -> Either a b -> Either a b
forall b c a. (b -> c) -> Either a b -> Either a c
mapRight b -> b
h) (m (Continuation m (Either a b))
-> Either a b -> m (Continuation m (Either a b))
forall a b. a -> b -> a
const (m (Continuation m (Either a b))
 -> Either a b -> m (Continuation m (Either a b)))
-> (Continuation m (Either a b) -> m (Continuation m (Either a b)))
-> Continuation m (Either a b)
-> Either a b
-> m (Continuation m (Either a b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continuation m (Either a b) -> m (Continuation m (Either a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Continuation m (Either a b)
 -> Either a b -> m (Continuation m (Either a b)))
-> Continuation m (Either a b)
-> Either a b
-> m (Continuation m (Either a b))
forall a b. (a -> b) -> a -> b
$ Continuation m a -> Continuation m b -> Continuation m (Either a b)
forall (m :: * -> *) a b.
Applicative m =>
Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' (Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback Continuation m a
forall (m :: * -> *) a. Continuation m a
done) Continuation m b
j))
        (Continuation m b -> Continuation m (Either a b))
-> m (Continuation m b) -> m (Continuation m (Either a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> m (Continuation m b)
i b
x


-- | Create a structure containing coproduct Continuations using two case
--   alternatives which generate structures containing Continuations of
--   the types inside the coproduct. The Continuations in the resulting
--   structure will only have effect on the state while it is in the branch
--   of the coproduct selected by the input value used to create the structure.
{-# SPECIALIZE eitherC :: (a -> Continuation JSM a) -> (b -> Continuation JSM b) -> Either a b -> Continuation JSM (Either a b) #-}
eitherC :: Applicative m => Continuous f => (a -> f m a) -> (b -> f m b) -> Either a b -> f m (Either a b)
eitherC :: (a -> f m a) -> (b -> f m b) -> Either a b -> f m (Either a b)
eitherC a -> f m a
l b -> f m b
_ (Left a
x)  = (Continuation m a -> Continuation m (Either a b))
-> f m a -> f m (Either a b)
forall (f :: (* -> *) -> * -> *) (m :: * -> *) a b.
Continuous f =>
(Continuation m a -> Continuation m b) -> f m a -> f m b
mapC (\Continuation m a
c -> Continuation m a -> Continuation m b -> Continuation m (Either a b)
forall (m :: * -> *) a b.
Applicative m =>
Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' Continuation m a
c ((b -> b) -> Continuation m b
forall a (m :: * -> *). (a -> a) -> Continuation m a
pur b -> b
forall a. a -> a
id)) (a -> f m a
l a
x)
eitherC a -> f m a
_ b -> f m b
r (Right b
x) = (Continuation m b -> Continuation m (Either a b))
-> f m b -> f m (Either a b)
forall (f :: (* -> *) -> * -> *) (m :: * -> *) a b.
Continuous f =>
(Continuation m a -> Continuation m b) -> f m a -> f m b
mapC (Continuation m a -> Continuation m b -> Continuation m (Either a b)
forall (m :: * -> *) a b.
Applicative m =>
Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' ((a -> a) -> Continuation m a
forall a (m :: * -> *). (a -> a) -> Continuation m a
pur a -> a
forall a. a -> a
id)) (b -> f m b
r b
x)


-- | Transform the type of a Continuation using an isomorphism.
{-# SPECIALIZE contIso :: (a -> b) -> (b -> a) -> Continuation JSM a -> Continuation JSM b #-}
contIso :: Functor m => (a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
contIso :: (a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
contIso a -> b
f b -> a
g (Continuation a -> a
h a -> m (Continuation m a)
i) = (b -> b) -> (b -> m (Continuation m b)) -> Continuation m b
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation (a -> b
f(a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
h(a -> a) -> (b -> a) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.b -> a
g) ((Continuation m a -> Continuation m b)
-> m (Continuation m a) -> m (Continuation m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
contIso a -> b
f b -> a
g) (m (Continuation m a) -> m (Continuation m b))
-> (b -> m (Continuation m a)) -> b -> m (Continuation m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (Continuation m a)
i (a -> m (Continuation m a))
-> (b -> a) -> b -> m (Continuation m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
g)
contIso a -> b
f b -> a
g (Rollback Continuation m a
h) = Continuation m b -> Continuation m b
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback ((a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
contIso a -> b
f b -> a
g Continuation m a
h)
contIso a -> b
f b -> a
g (Merge Continuation m a
h)    = Continuation m b -> Continuation m b
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge ((a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
contIso a -> b
f b -> a
g Continuation m a
h)
contIso a -> b
f b -> a
g (Pure a -> a
h)     = (b -> b) -> Continuation m b
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure (a -> b
f(a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
h(a -> a) -> (b -> a) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.b -> a
g)


-- | @Continuation m@ is a Functor in the EndoIso category (where the objects
--   are types and the morphisms are EndoIsos).
instance Applicative m => F.Functor EndoIso EndoIso (Continuation m) where
  map :: EndoIso a b -> EndoIso  (Continuation m a) (Continuation m b)
  map :: EndoIso a b -> EndoIso (Continuation m a) (Continuation m b)
map (EndoIso a -> a
f a -> b
g b -> a
h) =
    (Continuation m a -> Continuation m a)
-> (Continuation m a -> Continuation m b)
-> (Continuation m b -> Continuation m a)
-> EndoIso (Continuation m a) (Continuation m b)
forall a b. (a -> a) -> (a -> b) -> (b -> a) -> EndoIso a b
EndoIso ((a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
f ((a -> m (Continuation m a)) -> Continuation m a)
-> (Continuation m a -> a -> m (Continuation m a))
-> Continuation m a
-> Continuation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Continuation m a) -> a -> m (Continuation m a)
forall a b. a -> b -> a
const (m (Continuation m a) -> a -> m (Continuation m a))
-> (Continuation m a -> m (Continuation m a))
-> Continuation m a
-> a
-> m (Continuation m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continuation m a -> m (Continuation m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure) ((a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
contIso a -> b
g b -> a
h) ((b -> a) -> (a -> b) -> Continuation m b -> Continuation m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
contIso b -> a
h a -> b
g)


-- | You can combine multiple Continuations homogeneously using the 'Monoid' typeclass
--   instance. The resulting Continuation will execute all the subcontinuations in parallel,
--   allowing them to see each other's state updates and roll back each other's updates,
--   applying all of the unmerged updates generated by all the subcontinuations atomically once
--   all of them are done. A merge in any one of the branches will cause all of
--   the changes that branch can see to be merged.
instance Applicative m => Semigroup (Continuation m a) where
  (Continuation a -> a
f a -> m (Continuation m a)
g) <> :: Continuation m a -> Continuation m a -> Continuation m a
<> (Continuation a -> a
h a -> m (Continuation m a)
i) =
    (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation (a -> a
f(a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
h) (\a
x -> Continuation m a -> Continuation m a -> Continuation m a
forall a. Semigroup a => a -> a -> a
(<>) (Continuation m a -> Continuation m a -> Continuation m a)
-> m (Continuation m a) -> m (Continuation m a -> Continuation m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m (Continuation m a)
g a
x m (Continuation m a -> Continuation m a)
-> m (Continuation m a) -> m (Continuation m a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m (Continuation m a)
i a
x)
  (Continuation a -> a
f a -> m (Continuation m a)
g) <> (Rollback Continuation m a
h) =
    Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback ((a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
f ((Continuation m a -> Continuation m a)
-> m (Continuation m a) -> m (Continuation m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Continuation m a -> Continuation m a -> Continuation m a
forall a. Semigroup a => a -> a -> a
<> Continuation m a
h) (m (Continuation m a) -> m (Continuation m a))
-> (a -> m (Continuation m a)) -> a -> m (Continuation m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (Continuation m a)
g))
  (Rollback Continuation m a
h) <> (Continuation a -> a
_ a -> m (Continuation m a)
g) =
    Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback ((a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
forall a. a -> a
id ((Continuation m a -> Continuation m a)
-> m (Continuation m a) -> m (Continuation m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Continuation m a
h Continuation m a -> Continuation m a -> Continuation m a
forall a. Semigroup a => a -> a -> a
<>) (m (Continuation m a) -> m (Continuation m a))
-> (a -> m (Continuation m a)) -> a -> m (Continuation m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (Continuation m a)
g))
  (Rollback Continuation m a
f) <> (Rollback Continuation m a
g) = Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback (Continuation m a
f Continuation m a -> Continuation m a -> Continuation m a
forall a. Semigroup a => a -> a -> a
<> Continuation m a
g)
  (Pure a -> a
f) <> (Pure a -> a
g) = (a -> a) -> Continuation m a
forall (m :: * -> *) a. (a -> a) -> Continuation m a
Pure (a -> a
f(a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
g)
  (Pure a -> a
f) <> (Continuation a -> a
g a -> m (Continuation m a)
h) = (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation (a -> a
f(a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
g) a -> m (Continuation m a)
h
  (Continuation a -> a
f a -> m (Continuation m a)
g) <> (Pure a -> a
h) = (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation (a -> a
f(a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
h) a -> m (Continuation m a)
g
  (Pure a -> a
f) <> (Rollback Continuation m a
g) = (a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
forall (m :: * -> *) a.
(a -> a) -> (a -> m (Continuation m a)) -> Continuation m a
Continuation a -> a
f (m (Continuation m a) -> a -> m (Continuation m a)
forall a b. a -> b -> a
const (Continuation m a -> m (Continuation m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback Continuation m a
g)))
  (Rollback Continuation m a
f) <> (Pure a -> a
_) = Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Rollback Continuation m a
f
  (Merge Continuation m a
f) <> Continuation m a
g = Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge (Continuation m a
f Continuation m a -> Continuation m a -> Continuation m a
forall a. Semigroup a => a -> a -> a
<> Continuation m a
g)
  Continuation m a
f <> (Merge Continuation m a
g) = Continuation m a -> Continuation m a
forall (m :: * -> *) a. Continuation m a -> Continuation m a
Merge (Continuation m a
f Continuation m a -> Continuation m a -> Continuation m a
forall a. Semigroup a => a -> a -> a
<> Continuation m a
g)


-- | Since combining Continuations homogeneously is an associative operation,
--   and this operation has a unit element (done), Continuations are a 'Monoid'.
instance Applicative m => Monoid (Continuation m a) where
  mempty :: Continuation m a
mempty = Continuation m a
forall (m :: * -> *) a. Continuation m a
done


{-# SPECIALIZE writeUpdate' :: NFData a => (a -> a) -> TVar a -> (a -> JSM (Continuation JSM a)) -> JSM () #-}
writeUpdate' :: MonadUnliftIO m => NFData a => (a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
writeUpdate' :: (a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
writeUpdate' a -> a
h TVar a
model a -> m (Continuation m a)
f = do
  a
i <- TVar a -> m a
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar a
model
  Continuation m a
m <- a -> m (Continuation m a)
f (a -> a
h a
i)
  case Continuation m a
m of
    Continuation a -> a
g a -> m (Continuation m a)
gs -> (a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, NFData a) =>
(a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
writeUpdate' (a -> a
g (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
h) TVar a
model a -> m (Continuation m a)
gs
    Pure a -> a
g -> STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
model (a -> STM ()) -> (a -> a) -> a -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
g (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
h (a -> STM ()) -> STM a -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
model)
    Merge Continuation m a
g -> do
      STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
model (a -> STM ()) -> (a -> a) -> a -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
h (a -> STM ()) -> STM a -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
model
      (a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, NFData a) =>
(a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
writeUpdate' a -> a
forall a. a -> a
id TVar a
model (m (Continuation m a) -> a -> m (Continuation m a)
forall a b. a -> b -> a
const (Continuation m a -> m (Continuation m a)
forall (m :: * -> *) a. Monad m => a -> m a
return Continuation m a
g))
    Rollback Continuation m a
gs -> (a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, NFData a) =>
(a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
writeUpdate' a -> a
forall a. a -> a
id TVar a
model (m (Continuation m a) -> a -> m (Continuation m a)
forall a b. a -> b -> a
const (Continuation m a -> m (Continuation m a)
forall (m :: * -> *) a. Monad m => a -> m a
return Continuation m a
gs))


-- | Run a Continuation on a state variable. This may update the state.
--   This is a synchronous, non-blocking operation for pure updates,
--   and an asynchronous, non-blocking operation for impure updates.
{-# SPECIALIZE writeUpdate :: NFData a => TVar a -> Continuation JSM a -> JSM () #-}
writeUpdate :: MonadUnliftIO m => NFData a => TVar a -> Continuation m a -> m ()
writeUpdate :: TVar a -> Continuation m a -> m ()
writeUpdate TVar a
model = \case
  Continuation a -> a
f a -> m (Continuation m a)
g -> m ThreadId -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ThreadId -> m ()) -> (m () -> m ThreadId) -> m () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, NFData a) =>
(a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
writeUpdate' a -> a
f TVar a
model a -> m (Continuation m a)
g
  Pure a -> a
f           -> STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
model (a -> STM ()) -> (a -> a) -> a -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f (a -> STM ()) -> STM a -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
model)
  Merge Continuation m a
f          -> TVar a -> Continuation m a -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, NFData a) =>
TVar a -> Continuation m a -> m ()
writeUpdate TVar a
model Continuation m a
f
  Rollback Continuation m a
f       -> TVar a -> Continuation m a -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, NFData a) =>
TVar a -> Continuation m a -> m ()
writeUpdate TVar a
model Continuation m a
f


-- | Execute a fold by watching a state variable and executing the next
--   step of the fold each time it changes.
{-# SPECIALIZE shouldUpdate :: forall a b. Eq a => (b -> a -> JSM b) -> b -> TVar a -> JSM () #-}
shouldUpdate :: forall a b m. MonadJSM m => MonadUnliftIO m => Eq a => (b -> a -> m b) -> b -> TVar a -> m ()
shouldUpdate :: (b -> a -> m b) -> b -> TVar a -> m ()
shouldUpdate b -> a -> m b
sun b
prev TVar a
currentModel = do
  -- get the current state of the model
  a
sampleModel   :: a          <- TVar a -> m a
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar a
currentModel
  -- duplicate that state so we can compare if the model changes
  TVar a
previousModel :: TVar a     <- a -> m (TVar a)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO a
sampleModel
  -- store the accumulating value in a TVar so we can control when it updates
  TVar b
currentState  :: TVar b     <- b -> m (TVar b)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO b
prev
  -- get the window once
  Window
window        :: Window     <- m Window
forall (m :: * -> *). MonadDOM m => m Window
currentWindowUnchecked
  -- get the execution context once
  UnliftIO m
context       :: UnliftIO m <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO

  let
    go :: [Int] -> m ()
    go :: [Int] -> m ()
go [Int]
frames = do

      -- block if the new model is the same as the old
      a
newModel <- STM a -> m a
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM a -> m a) -> STM a -> m a
forall a b. (a -> b) -> a -> b
$ do
        a
new' <- TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
currentModel
        a
old  <- TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
previousModel
        -- if the new model is different from the old
        -- unblock and write the new model for the next comparision
        if a
new' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
old then STM a
forall a. STM a
retry else a
new' a -> STM () -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
previousModel a
new'

      -- if we already had something scheduled to run, cancel it
      (Int -> m ()) -> [Int] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Window -> Maybe Int -> m ()
forall (m :: * -> *) self.
(MonadDOM m, IsWindowOrWorkerGlobalScope self) =>
self -> Maybe Int -> m ()
clearTimeout Window
window (Maybe Int -> m ()) -> (Int -> Maybe Int) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just) [Int]
frames

      -- generate a callback for the request animation frame
      let callback :: JSCallAsFunction
callback = JSCallAsFunction -> JSCallAsFunction
fun (JSCallAsFunction -> JSCallAsFunction)
-> JSCallAsFunction -> JSCallAsFunction
forall a b. (a -> b) -> a -> b
$ \JSVal
_ JSVal
_ [JSVal]
_ -> do
             -- get the current state
             b
x <- TVar b -> JSM b
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar b
currentState
             -- run the action against the current state, and the new model
             b
y <- IO b -> JSM b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> JSM b) -> IO b -> JSM b
forall a b. (a -> b) -> a -> b
$ UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
context (m b -> IO b) -> m b -> IO b
forall a b. (a -> b) -> a -> b
$ b -> a -> m b
sun b
x a
newModel
             -- write the new state for the next run
             STM () -> JSM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> JSM ()) -> STM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ TVar b -> b -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar b
currentState b
y
             -- note this means that @newModel@ updates for each call to @go@
             -- but @currentState@ only updates if the frame is actually called
             (Int -> JSM ()) -> [Int] -> JSM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Window -> Maybe Int -> JSM ()
forall (m :: * -> *) self.
(MonadDOM m, IsWindowOrWorkerGlobalScope self) =>
self -> Maybe Int -> m ()
clearTimeout Window
window (Maybe Int -> JSM ()) -> (Int -> Maybe Int) -> Int -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just) [Int]
frames

      -- schedule the action to run on the next frame
      Int
frameId' <- Window -> JSCallAsFunction -> Maybe Int -> m Int
forall (m :: * -> *) self handler.
(MonadDOM m, IsWindowOrWorkerGlobalScope self, ToJSVal handler) =>
self -> handler -> Maybe Int -> m Int
setTimeout Window
window JSCallAsFunction
callback Maybe Int
forall a. Maybe a
Nothing

      [Int] -> m ()
go (Int
frameId'Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
frames)

  () () -> m ThreadId -> m ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m () -> m ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO ([Int] -> m ()
go [Int]
forall a. Monoid a => a
mempty)


-- | A monad transformer for building up a Continuation in a series of steps in a monadic computation
newtype ContinuationT model m a = ContinuationT
  { ContinuationT model m a -> m (a, Continuation m model)
runContinuationT :: m (a, Continuation m model) }


-- | This adds the given Continuation to the Continuation being built up in the monadic context
--   where this function is invoked.
{-# SPECIALIZE commit :: Continuation JSM model -> ContinuationT model JSM () #-}
commit :: Applicative m => Continuation m model -> ContinuationT model m ()
commit :: Continuation m model -> ContinuationT model m ()
commit = m ((), Continuation m model) -> ContinuationT model m ()
forall model (m :: * -> *) a.
m (a, Continuation m model) -> ContinuationT model m a
ContinuationT (m ((), Continuation m model) -> ContinuationT model m ())
-> (Continuation m model -> m ((), Continuation m model))
-> Continuation m model
-> ContinuationT model m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), Continuation m model) -> m ((), Continuation m model)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((), Continuation m model) -> m ((), Continuation m model))
-> (Continuation m model -> ((), Continuation m model))
-> Continuation m model
-> m ((), Continuation m model)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((),)


-- | This turns a monadic computation to build up a Continuation into the Continuation which it
--   represents. The actions inside the monadic computation will be run when the Continuation
--   is run. The return value of the monadic computation will be discarded.
{-# SPECIALIZE voidRunContinuationT :: ContinuationT model JSM a -> Continuation JSM model #-}
voidRunContinuationT :: Functor m => ContinuationT model m a -> Continuation m model
voidRunContinuationT :: ContinuationT model m a -> Continuation m model
voidRunContinuationT ContinuationT model m a
m = (model -> m (Continuation m model)) -> Continuation m model
forall a (m :: * -> *).
(a -> m (Continuation m a)) -> Continuation m a
kleisli ((model -> m (Continuation m model)) -> Continuation m model)
-> (m (Continuation m model) -> model -> m (Continuation m model))
-> m (Continuation m model)
-> Continuation m model
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Continuation m model) -> model -> m (Continuation m model)
forall a b. a -> b -> a
const (m (Continuation m model) -> Continuation m model)
-> m (Continuation m model) -> Continuation m model
forall a b. (a -> b) -> a -> b
$ (a, Continuation m model) -> Continuation m model
forall a b. (a, b) -> b
snd ((a, Continuation m model) -> Continuation m model)
-> m (a, Continuation m model) -> m (Continuation m model)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContinuationT model m a -> m (a, Continuation m model)
forall model (m :: * -> *) a.
ContinuationT model m a -> m (a, Continuation m model)
runContinuationT ContinuationT model m a
m


-- | This turns a function for building a Continuation in a monadic computation
--   which is parameterized by the current state of the model
--   into a Continuation which reads the current state of the model,
--   runs the resulting monadic computation, and runs the Continuation
--   resulting from that computation.
{-# SPECIALIZE kleisliT :: (model -> ContinuationT model JSM a) -> Continuation JSM model #-}
kleisliT :: Applicative m => (model -> ContinuationT model m a) -> Continuation m model
kleisliT :: (model -> ContinuationT model m a) -> Continuation m model
kleisliT model -> ContinuationT model m a
f = (model -> m (Continuation m model)) -> Continuation m model
forall a (m :: * -> *).
(a -> m (Continuation m a)) -> Continuation m a
kleisli (Continuation m model -> m (Continuation m model)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Continuation m model -> m (Continuation m model))
-> (model -> Continuation m model)
-> model
-> m (Continuation m model)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContinuationT model m a -> Continuation m model
forall (m :: * -> *) model a.
Functor m =>
ContinuationT model m a -> Continuation m model
voidRunContinuationT (ContinuationT model m a -> Continuation m model)
-> (model -> ContinuationT model m a)
-> model
-> Continuation m model
forall b c a. (b -> c) -> (a -> b) -> a -> c
. model -> ContinuationT model m a
f)


instance Functor m => Functor (ContinuationT model m) where
  fmap :: (a -> b) -> ContinuationT model m a -> ContinuationT model m b
fmap a -> b
f = m (b, Continuation m model) -> ContinuationT model m b
forall model (m :: * -> *) a.
m (a, Continuation m model) -> ContinuationT model m a
ContinuationT (m (b, Continuation m model) -> ContinuationT model m b)
-> (ContinuationT model m a -> m (b, Continuation m model))
-> ContinuationT model m a
-> ContinuationT model m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Continuation m model) -> (b, Continuation m model))
-> m (a, Continuation m model) -> m (b, Continuation m model)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (a, Continuation m model) -> (b, Continuation m model)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> b
f) (m (a, Continuation m model) -> m (b, Continuation m model))
-> (ContinuationT model m a -> m (a, Continuation m model))
-> ContinuationT model m a
-> m (b, Continuation m model)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContinuationT model m a -> m (a, Continuation m model)
forall model (m :: * -> *) a.
ContinuationT model m a -> m (a, Continuation m model)
runContinuationT


instance Applicative m => Applicative (ContinuationT model m) where
  pure :: a -> ContinuationT model m a
pure = m (a, Continuation m model) -> ContinuationT model m a
forall model (m :: * -> *) a.
m (a, Continuation m model) -> ContinuationT model m a
ContinuationT (m (a, Continuation m model) -> ContinuationT model m a)
-> (a -> m (a, Continuation m model))
-> a
-> ContinuationT model m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Continuation m model) -> m (a, Continuation m model)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, Continuation m model) -> m (a, Continuation m model))
-> (a -> (a, Continuation m model))
-> a
-> m (a, Continuation m model)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Continuation m model
forall (m :: * -> *) a. Continuation m a
done)

  ContinuationT model m (a -> b)
ft <*> :: ContinuationT model m (a -> b)
-> ContinuationT model m a -> ContinuationT model m b
<*> ContinuationT model m a
xt = m (b, Continuation m model) -> ContinuationT model m b
forall model (m :: * -> *) a.
m (a, Continuation m model) -> ContinuationT model m a
ContinuationT (m (b, Continuation m model) -> ContinuationT model m b)
-> m (b, Continuation m model) -> ContinuationT model m b
forall a b. (a -> b) -> a -> b
$ do
    (\(a -> b
f, Continuation m model
fc) (a
x, Continuation m model
xc) -> (a -> b
f a
x, Continuation m model
fc Continuation m model
-> Continuation m model -> Continuation m model
forall a. Semigroup a => a -> a -> a
<> Continuation m model
xc))
      ((a -> b, Continuation m model)
 -> (a, Continuation m model) -> (b, Continuation m model))
-> m (a -> b, Continuation m model)
-> m ((a, Continuation m model) -> (b, Continuation m model))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContinuationT model m (a -> b) -> m (a -> b, Continuation m model)
forall model (m :: * -> *) a.
ContinuationT model m a -> m (a, Continuation m model)
runContinuationT ContinuationT model m (a -> b)
ft
      m ((a, Continuation m model) -> (b, Continuation m model))
-> m (a, Continuation m model) -> m (b, Continuation m model)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ContinuationT model m a -> m (a, Continuation m model)
forall model (m :: * -> *) a.
ContinuationT model m a -> m (a, Continuation m model)
runContinuationT ContinuationT model m a
xt


instance Monad m => Monad (ContinuationT model m) where
  return :: a -> ContinuationT model m a
return = m (a, Continuation m model) -> ContinuationT model m a
forall model (m :: * -> *) a.
m (a, Continuation m model) -> ContinuationT model m a
ContinuationT (m (a, Continuation m model) -> ContinuationT model m a)
-> (a -> m (a, Continuation m model))
-> a
-> ContinuationT model m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Continuation m model) -> m (a, Continuation m model)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Continuation m model) -> m (a, Continuation m model))
-> (a -> (a, Continuation m model))
-> a
-> m (a, Continuation m model)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Continuation m model
forall (m :: * -> *) a. Continuation m a
done)

  ContinuationT model m a
m >>= :: ContinuationT model m a
-> (a -> ContinuationT model m b) -> ContinuationT model m b
>>= a -> ContinuationT model m b
f = m (b, Continuation m model) -> ContinuationT model m b
forall model (m :: * -> *) a.
m (a, Continuation m model) -> ContinuationT model m a
ContinuationT (m (b, Continuation m model) -> ContinuationT model m b)
-> m (b, Continuation m model) -> ContinuationT model m b
forall a b. (a -> b) -> a -> b
$ do
    (a
x, Continuation m model
g) <- ContinuationT model m a -> m (a, Continuation m model)
forall model (m :: * -> *) a.
ContinuationT model m a -> m (a, Continuation m model)
runContinuationT ContinuationT model m a
m
    (b
y, Continuation m model
h) <- ContinuationT model m b -> m (b, Continuation m model)
forall model (m :: * -> *) a.
ContinuationT model m a -> m (a, Continuation m model)
runContinuationT (a -> ContinuationT model m b
f a
x)
    (b, Continuation m model) -> m (b, Continuation m model)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
y, Continuation m model
g Continuation m model
-> Continuation m model -> Continuation m model
forall (m :: * -> *) a.
Applicative m =>
Continuation m a -> Continuation m a -> Continuation m a
`before` Continuation m model
h)


instance MonadTrans (ContinuationT model) where
  lift :: m a -> ContinuationT model m a
lift = m (a, Continuation m model) -> ContinuationT model m a
forall model (m :: * -> *) a.
m (a, Continuation m model) -> ContinuationT model m a
ContinuationT (m (a, Continuation m model) -> ContinuationT model m a)
-> (m a -> m (a, Continuation m model))
-> m a
-> ContinuationT model m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (a, Continuation m model))
-> m a -> m (a, Continuation m model)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Continuation m model
forall (m :: * -> *) a. Continuation m a
done)


-- | Create an update to a constant value.
constUpdate :: a -> Continuation m a
constUpdate :: a -> Continuation m a
constUpdate = (a -> a) -> Continuation m a
forall a (m :: * -> *). (a -> a) -> Continuation m a
pur ((a -> a) -> Continuation m a)
-> (a -> a -> a) -> a -> Continuation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a b. a -> b -> a
const
{-# INLINE constUpdate #-}