Converse.hs

-- | This module lets you handle effects using an effectful program using a
-- model of two communicating processes.
--
--  * The 'normal' computation: a computation that uses some effect @f@ and possibly others effects, @r@
--  * The handling computation: a computation that responds to the
--    effects @f@ of the normal computation by means of @Converse f@
--    and is also allowed to use the effects @r@.
--
-- This effect is called @Converse@, because it is meaningful both as a verb and as an adjective.
--
--  * The computations converse — having a one-to-one conversation where @f@ is the language
--  * The handling computation has perform the opposite\/converse of
--    the normal computation: when the normal computation /requests/ a
--    value by means of @f@ and the handler emits a @Converse f@
--    effect, the handler has to /provide/ that value.
--
module Control.Monad.Freer.Converse
  ( -- * Running tests
    runConverse
  , Converse
  , converse
  , peekEvent
  , showNext
  , module Control.Monad.Freer
  ) where
import           Control.Monad.Freer
import           Control.Monad.Freer.Internal
import           Data.Functor.Classes.FreerConverse.Parametric

-- | Handle the effects of another computation, as an effect.
--
-- For example, a handling computation may have type @Eff '[Converse f m v] a@
-- and handles effects for the 'normal' computation @Eff '[f] v@.
--
--
-- /Type parameters:/
--
-- [@f@] The effect that is communicated between the normal computation and the handling computation
-- [@r@] The remaining effects that both computations may use
-- [@v@] The result of the normal computation
-- [@a@] The result of the handling computation
data Converse f r v a where
  Converse
    :: (forall x. f x -> Eff r (Maybe x, a)) -- Maybe handle an effect. When Nothing is returned, the same effect can be handled next time, so this provides a 1-item lookahead. (FIXME: turn into haddocks when supported)
    -> (v -> Eff r a)                        -- Handle the result
    -> Converse f r v a

-- | Look at the next event without handling it
peekEvent :: (forall x. f x -> Eff r a) -> Eff (Converse f r v ': r) (Either v a)
peekEvent peeker = converse (fmap (\a -> (Nothing, Right a)) . peeker)
                            (return . Left)

-- | Show what happens next, examples:
--
--     "Next event: ReadLine"
--
--     "Done with result: 42"
showNext :: (Show v, ShowP f) => Eff (Converse f r v ': r) String
showNext = do
  p <- peekEvent (return . showP)
  return $ case p of
    Right x -> "Next event: " ++ x
    Left v  -> "Done with result: " ++ show v

inj1 :: t v -> Union (t ': r) v
inj1 = inj

-- | Called by the handling computation, to interact with the 'normal' computation. (See module description for definitions)
--
-- This is the most general way of interacting with the normal computation, reflecting the constructor of the 'Converse' type.
--
converse
  :: (forall x. f x -> Eff r (Maybe x, b)) -- ^ Handle an effect emitted by the normal computation. This may produce other effects in @r@. In order to handle the effect, return a @(Just x, <...>)@. The right hand side of the tuple may be used to return a value to be used later on by the handling computation (@b@ also occurs in the return value)
  -> (v -> Eff r b) -- ^ Handle the case where the normal computation has completed and returned a value of type @v@.
  -> Eff (Converse f r v ': r) b -- ^ A computation that should run in the handling computation.
converse f f' = E (inj1 (Converse f f')) (tsingleton return)

-- | Zips together the two communicating computations, the normal computation
-- that uses effect @f@ and the handling computation that uses effect @Converse f@
--
-- The handling computation gets to run effects (the @r@ parameter) first
-- whenever a 'scheduling' choice presents itself.
--
runConverse
  :: Eff (f ': r) v               -- ^ The normal computation
  -> Eff (Converse f r v ': r) b  -- ^ The handling computation
  -> Eff r b                      -- ^ A runnable combined computation
runConverse _subject _script@(Val b) = return b
runConverse subject script@(E x qScript) = case decomp x of
    Left scriptSideEffect -> E  scriptSideEffect
                                (tsingleton (qComp qScript (runConverse subject)))
    Right (Converse onEvent onResult) -> case subject of
      Val subjectResult -> do
        c <- onResult subjectResult
        runConverse subject (qScript `qApp` c)
      E subjectEffect qSubject -> case decomp subjectEffect of
        Left sideEffect -> E sideEffect (tsingleton (qComp qSubject c))
           where c s = runConverse s script
        Right event -> do
          (maybeReply, spy) <- onEvent event
          case maybeReply of
            Just reply -> runConverse (qSubject `qApp` reply) (qScript `qApp` spy)
            Nothing -> runConverse subject (qScript `qApp` spy)