diff --git a/src/Control/Monad/Unlift.purs b/src/Control/Monad/Unlift.purs new file mode 100644 index 0000000..80f7e20 --- /dev/null +++ b/src/Control/Monad/Unlift.purs @@ -0,0 +1,94 @@ +module Control.Monad.Unlift where + +import Prelude + +import Control.Monad.Base (class MonadBase) +import Control.Monad.Identity.Trans (IdentityT(..)) +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.ST (ST) +import Data.Either (Either) +import Data.Identity (Identity) +import Data.List (List) +import Data.List.Lazy as LL +import Data.Maybe (Maybe) +import Effect (Effect) +import Effect.Aff (Aff) + +-- | Monads which allow their actions to be run in their base monad. +-- | +-- | `MonadUnlift` captures the opposite notion of `MonadBase` - while +-- | `MonadBase` allows an base monad `b` to be lifted into another monad `m`, +-- | `MonadUnlift` allows a `m` to be run in `b`, as long as contained in an +-- | outer `m` context. +-- | +-- | Note that the laws given below require that a monad have no "monadic +-- | state", which essentially limits instances to `ReaderT` and `IdentityT` +-- | stacks with a base of `b`. +-- | +-- | Instances should satisfy the following laws, which state that +-- | `unlift` is a transformer of monads for any given `u` returned by +-- | `askUnlift`: +-- | +-- | ```purescript +-- | unlift u <<< pure = pure +-- | unlift u (f =<< m) = unlift u <<< f =<< unlift u m +-- | ``` +class MonadBase b m <= MonadUnlift b m | m -> b where + -- | Run a base monad action with access to a runner function that is capable + -- | of running a monadic action `m` in `b` (strictly speaking, a natural + -- | transformation from `m` to `b`). + withRunInBase :: forall x. ((m ~> b) -> b x) -> m x + +instance MonadUnlift Array Array where + withRunInBase runAction = runAction identity + +instance MonadUnlift List List where + withRunInBase runAction = runAction identity + +instance MonadUnlift LL.List LL.List where + withRunInBase runAction = runAction identity + +instance MonadUnlift Maybe Maybe where + withRunInBase runAction = runAction identity + +instance MonadUnlift Effect Effect where + withRunInBase runAction = runAction identity + +instance MonadUnlift Aff Aff where + withRunInBase runAction = runAction identity + +instance MonadUnlift Identity Identity where + withRunInBase runAction = runAction identity + +instance MonadUnlift (Either e) (Either e) where + withRunInBase runAction = runAction identity + +instance MonadUnlift (ST s) (ST s) where + withRunInBase runAction = runAction identity + +instance MonadUnlift b m => MonadUnlift b (ReaderT r m) where + withRunInBase runAction = ReaderT \context -> + withRunInBase \runMInBase -> + runAction \(ReaderT reader) -> + runMInBase $ reader context + +instance MonadUnlift b m => MonadUnlift b (IdentityT m) where + withRunInBase runAction = IdentityT $ + withRunInBase \runMInBase -> + runAction \(IdentityT a) -> + runMInBase a + +newtype Unlift :: forall k. (k -> Type) -> (k -> Type) -> Type +newtype Unlift b m = Unlift (m ~> b) + +askUnlift :: forall b m. MonadUnlift b m => m (Unlift b m) +askUnlift = withRunInBase \run -> pure $ Unlift run + +askRunInBase :: forall b m a. MonadUnlift b m => m (m a -> b a) +askRunInBase = withRunInBase pure + +withUnlift :: forall b m a. MonadUnlift b m => (Unlift b m -> b a) -> m a +withUnlift runAction = withRunInBase \run -> runAction $ Unlift run + +toBase :: forall b m a. MonadUnlift b m => m a -> m (b a) +toBase m = withRunInBase \run -> pure $ run m