New Workflow monad for Reflex

Control.Monad.ExceptionsToErrors.hs

{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.ExceptionsToErrors where

import Control.Exception
import Control.Monad.Except
import Data.Proxy
import Data.Reflection
import GHC.IO (mkUserError)

-- | This is a monad that translates all IO-style synchronous exceptions into exceptions in ExceptT
newtype ExceptionsToErrors i m a = ExceptionsToErrors { unExceptionsToErrors :: m a }
  deriving (Functor, Applicative, Monad)

deriving instance MonadError e m => MonadError e (ExceptionsToErrors i m)

runExceptionsToErrors :: forall e m a. (SomeException -> e) -> (forall (i :: *). Reifies i (SomeException -> e) => ExceptionsToErrors i m a) -> m a
runExceptionsToErrors injectSomeException a = reify injectSomeException (\(_ :: Proxy i) -> unExceptionsToErrors (a :: ExceptionsToErrors i m a))

instance MonadTrans (ExceptionsToErrors i) where
  lift = ExceptionsToErrors

instance (MonadError e m, Reifies i (SomeException -> e)) => MonadFail (ExceptionsToErrors i m) where
  fail s = ExceptionsToErrors $ throwError $ reflect (Proxy @i) $ mkUserError s

instance (MonadIO m, MonadError e m, Reifies i (SomeException -> e)) => MonadIO (ExceptionsToErrors i m) where
  liftIO a = ExceptionsToErrors $ liftIO (try a) >>= \case
    Left err -> throwError $ reflect (Proxy @i) err
    Right result -> pure result

Reflex.Workflow.Monad.hs

{-# LANGUAGE UndecidableInstances #-}
module Reflex.Workflow.Monad where

import Control.Monad.Except
import Control.Monad.Free
import Control.Monad.Free.Church
import Data.Functor.Compose
import Data.Semigroup
import Data.These
import Data.Void
import Reflex hiding (select)
import Reflex.Workflow qualified as Old

import Control.Monad.ExceptionsToErrors

newtype WorkflowT t m a = WorkflowT { unWorkflow :: F (Compose m (Event t)) a } deriving (Functor, Applicative, Monad)

runWorkflowT
  :: forall t m a
  . ( Adjustable t m
    , MonadHold t m
    , MonadFix m
    , PostBuild t m
    ) => WorkflowT t m a -> m (Event t a)
runWorkflowT (WorkflowT w0) = case fromF w0 of
  Pure a -> (a <$) <$> getPostBuild
  Free (Compose (m0 :: m (Event t (Free (Compose m (Event t)) a)))) -> do
    rec (out0, built) <- runWithReplace m0 next
        let f :: Free (Compose m (Event t)) a
              -> These a (m (Event t (Free (Compose m (Event t)) a)))
            f = \case
              Pure a -> These a $ pure never
              Free (Compose m') -> That m'
        (done, next) <- fanThese . fmapCheap f <$> switchHoldPromptOnly out0 built
    pure done

class (Reflex t, Functor m) => Workflow t m | m -> t where
  type WorkflowStep m :: * -> *
  step :: WorkflowStep m (Event t a) -> m a

instance (Reflex t, Functor m) => Workflow t (WorkflowT t m) where
  type WorkflowStep (WorkflowT t m) = m
  step = WorkflowT . wrap . fmap pure . Compose

instance Workflow t m => Workflow t (ExceptT e m) where
  type WorkflowStep (ExceptT e m) = WorkflowStep m
  step = ExceptT . fmap Right . step

instance Workflow t m => Workflow t (ExceptionsToErrors i m) where
  type WorkflowStep (ExceptionsToErrors i m) = WorkflowStep m
  step = ExceptionsToErrors . step

instance (Reflex t, Functor m, PostBuild t m, PerformEvent t m, MonadIO (Performable m)) => MonadIO (WorkflowT t m) where
  liftIO action = step $ do
    postBuild <- getPostBuild
    performEvent $ liftIO action <$ postBuild

fromOldWorkflow
  :: PostBuild t m
  => Old.Workflow t m a
  -> WorkflowT t (EventWriterT t (First a) m) Void
fromOldWorkflow (Old.Workflow w) = do
  next <- step $ do
    (a, goToNext) <- lift w
    postBuild <- getPostBuild --TODO: Does EventWriterT pass promptly enough through runWithReplace for this?
    tellEvent $ First a <$ postBuild
    pure goToNext
  fromOldWorkflow next