From e0872b4d45d11a8715c206fb2c4c66852665e1d3 Mon Sep 17 00:00:00 2001
From: Jamie Bertram <jamie.bertram@tweag.io>
Date: Tue, 15 Mar 2022 10:07:38 -0600
Subject: [PATCH] Add MonadAff

---
 src/Effect/Aff/Unlift.purs | 56 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 56 insertions(+)
 create mode 100644 src/Effect/Aff/Unlift.purs

diff --git a/src/Effect/Aff/Unlift.purs b/src/Effect/Aff/Unlift.purs
new file mode 100644
index 0000000..191c06b
--- /dev/null
+++ b/src/Effect/Aff/Unlift.purs
@@ -0,0 +1,56 @@
+module Effect.Aff.Unlift where
+
+import Prelude
+
+import Control.Monad.Reader (ReaderT(..))
+import Effect.Aff (Aff)
+import Effect.Aff.Class (class MonadAff)
+
+-- | Monads which allow their actions to be run in `Aff`.
+-- |
+-- | `MonadUnliftAff` captures the opposite notion of `MonadAff` - while
+-- | `MonadAff` allows an `Aff` to be lifted into another monad,
+-- | `MonadUnliftAff` allows a monad other than `Aff` to be run in an
+-- | `Aff` context.
+-- |
+-- | Note that the laws given below require that a monad have no "monadic
+-- | state", which essentially limits instances to `ReaderT` stacks with a
+-- | base of `Aff`.
+-- |
+-- | Instances should satisfy the following laws, which state that
+-- | `unliftAff` is a transformer of monads for any given `u` returned by
+-- | `askUnliftAff`:.
+-- |
+-- | ```purescript
+-- | unliftAff u <<< pure = pure
+-- | unliftAff u (f =<< m) = unliftAff u <<< f =<< unliftAff u m
+-- | ```
+class MonadAff m <= MonadUnliftAff m where
+  -- | Run an `Aff` with access to a runner function that is capable of
+  -- | running a monadic action `m` in `Aff`.
+  withRunInAff :: forall b. ((m ~> Aff) -> Aff b) -> m b
+
+instance MonadUnliftAff Aff where
+  withRunInAff runAction = runAction identity
+
+instance MonadUnliftAff m => MonadUnliftAff (ReaderT r m) where
+  withRunInAff runAction = ReaderT \context ->
+    withRunInAff \runMInAff ->
+      runAction \(ReaderT reader) ->
+        runMInAff $ reader context
+
+newtype UnliftAff m = UnliftAff (m ~> Aff)
+
+askUnliftAff :: forall m. MonadUnliftAff m => m (UnliftAff m)
+askUnliftAff = withRunInAff \run -> pure $ UnliftAff run
+
+askRunInAff :: forall m a. MonadUnliftAff m => m (m a -> Aff a)
+askRunInAff = withRunInAff pure
+
+withUnliftAff
+  :: forall m a. MonadUnliftAff m => (UnliftAff m -> Aff a) -> m a
+withUnliftAff runAction =
+  withRunInAff \run -> runAction $ UnliftAff run
+
+toAff :: forall m a. MonadUnliftAff m => m a -> m (Aff a)
+toAff m = withRunInAff \run -> pure $ run m