Merge pull request #366 from fused-effects/more-transformers-instances

More transformers instances
fused-effects · Mar 13, 2020 · 62caa61 · 62caa61
2 parents 26881e2 + 9440c7b
commit 62caa61
Show file tree

Hide file tree

Showing 9 changed files with 72 additions and 13 deletions.
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -1,3 +1,6 @@
+- Defines `Algebra` instances for `Control.Monad.Trans.Maybe.MaybeT`, `Control.Monad.Trans.RWS.CPS`, and `Control.Monad.Trans.Writer.CPS`. ([#366](https://github.com/fused-effects/fused-effects/pull/366))
+
+
 ## Backwards-incompatible changes
 
 - Changes `alg`’s signature, giving it an initial state, and a distributive law which must be applied to each computation in the signature. This change allows `Algebra` instances to be derived using `GeneralizedNewtypeDeriving` and `DerivingVia`, while also obviating the need for `hmap`, `handleCoercible`, or the `thread` method of `Effect`. This furthermore increases the expressiveness of effects, allowing effects with higher-order positions yielding concrete types, e.g. `m ()`, to be run anywhere in the stack, not just above any `Effect`-requiring algebras. ([#359](https://github.com/fused-effects/fused-effects/pull/359), [#361](https://github.com/fused-effects/fused-effects/pull/361))

diff --git a/src/Control/Algebra.hs b/src/Control/Algebra.hs
@@ -42,18 +42,24 @@ import           Control.Effect.Throw.Internal
 import           Control.Effect.Writer.Internal
 import qualified Control.Monad.Trans.Except as Except
 import qualified Control.Monad.Trans.Identity as Identity
+import qualified Control.Monad.Trans.Maybe as Maybe
 import qualified Control.Monad.Trans.Reader as Reader
+#if MIN_VERSION_transformers(0,5,6)
+import qualified Control.Monad.Trans.RWS.CPS as RWS.CPS
+#endif
 import qualified Control.Monad.Trans.RWS.Lazy as RWS.Lazy
 import qualified Control.Monad.Trans.RWS.Strict as RWS.Strict
 import qualified Control.Monad.Trans.State.Lazy as State.Lazy
 import qualified Control.Monad.Trans.State.Strict as State.Strict
+#if MIN_VERSION_transformers(0,5,6)
+import qualified Control.Monad.Trans.Writer.CPS as Writer.CPS
+#endif
 import qualified Control.Monad.Trans.Writer.Lazy as Writer.Lazy
 import qualified Control.Monad.Trans.Writer.Strict as Writer.Strict
 import           Data.Functor.Compose
 import           Data.Functor.Identity
 import           Data.List.NonEmpty (NonEmpty(..))
 import           Data.Monoid
-import           Data.Tuple (swap)
 
 -- | The class of carriers (results) for algebras (effect handlers) over signatures (effects), whose actions are given by the 'alg' method.
 --
@@ -201,6 +207,11 @@ deriving instance Algebra sig m => Algebra sig (Ap m)
 -- @since 1.0.1.0
 deriving instance Algebra sig m => Algebra sig (Alt m)
 
+instance Algebra sig m => Algebra (Empty :+: sig) (Maybe.MaybeT m) where
+  alg hdl sig ctx = case sig of
+    L Empty -> Maybe.MaybeT (pure Nothing)
+    R other -> Maybe.MaybeT $ thread (maybe (pure Nothing) Maybe.runMaybeT) hdl other (Just ctx)
+
 instance Algebra sig m => Algebra (Reader r :+: sig) (Reader.ReaderT r m) where
   alg hdl sig ctx = case sig of
     L Ask         -> Reader.asks (<$ ctx)
@@ -214,10 +225,26 @@ toRWSTF :: Monoid w => w -> (a, s, w) -> RWSTF w s a
 toRWSTF w (a, s, w') = RWSTF (a, s, mappend w w')
 {-# INLINE toRWSTF #-}
 
+newtype Swap s a = Swap { getSwap :: (a, s) }
+  deriving (Functor)
+
 swapAndLift :: Functor ctx => (ctx a, w) -> ctx (w, a)
 swapAndLift p = (,) (snd p) <$> fst p
 {-# INLINE swapAndLift #-}
 
+#if MIN_VERSION_transformers(0,5,6)
+instance (Algebra sig m, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.CPS.RWST r w s m) where
+  alg hdl sig ctx = case sig of
+    L Ask              -> RWS.CPS.asks (<$ ctx)
+    L (Local f m)      -> RWS.CPS.local f (hdl (m <$ ctx))
+    R (L (Tell w))     -> ctx <$ RWS.CPS.tell w
+    R (L (Listen m))   -> swapAndLift <$> RWS.CPS.listen (hdl (m <$ ctx))
+    R (L (Censor f m)) -> RWS.CPS.censor f (hdl (m <$ ctx))
+    R (R (L Get))      -> RWS.CPS.gets (<$ ctx)
+    R (R (L (Put s)))  -> ctx <$ RWS.CPS.put s
+    R (R (R other))    -> RWS.CPS.rwsT $ \ r s -> unRWSTF <$> thread (\ (RWSTF (x, s, w)) -> toRWSTF w <$> RWS.CPS.runRWST x r s) hdl other (RWSTF (ctx, s, mempty))
+#endif
+
 instance (Algebra sig m, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.Lazy.RWST r w s m) where
   alg hdl sig ctx = case sig of
     L Ask              -> RWS.Lazy.asks (<$ ctx)
@@ -244,24 +271,33 @@ instance Algebra sig m => Algebra (State s :+: sig) (State.Lazy.StateT s m) wher
   alg hdl sig ctx = case sig of
     L Get     -> State.Lazy.gets (<$ ctx)
     L (Put s) -> ctx <$ State.Lazy.put s
-    R other   -> State.Lazy.StateT $ \ s -> swap <$> thread (\ (s, x) -> swap <$> State.Lazy.runStateT x s) hdl other (s, ctx)
+    R other   -> State.Lazy.StateT $ \ s -> getSwap <$> thread (fmap Swap . uncurry State.Lazy.runStateT . getSwap) hdl other (Swap (ctx, s))
 
 instance Algebra sig m => Algebra (State s :+: sig) (State.Strict.StateT s m) where
   alg hdl sig ctx = case sig of
     L Get     -> State.Strict.gets (<$ ctx)
     L (Put s) -> ctx <$ State.Strict.put s
-    R other   -> State.Strict.StateT $ \ s -> swap <$> thread (\ (s, x) -> swap <$> State.Strict.runStateT x s) hdl other (s, ctx)
+    R other   -> State.Strict.StateT $ \ s -> getSwap <$> thread (fmap Swap . uncurry State.Strict.runStateT . getSwap) hdl other (Swap (ctx, s))
+
+#if MIN_VERSION_transformers(0,5,6)
+instance (Algebra sig m, Monoid w) => Algebra (Writer w :+: sig) (Writer.CPS.WriterT w m) where
+  alg hdl sig ctx = case sig of
+    L (Tell w)     -> ctx <$ Writer.CPS.tell w
+    L (Listen m)   -> swapAndLift <$> Writer.CPS.listen (hdl (m <$ ctx))
+    L (Censor f m) -> Writer.CPS.censor f (hdl (m <$ ctx))
+    R other        -> Writer.CPS.writerT $ getSwap <$> thread (\ (Swap (x, s)) -> Swap . fmap (mappend s) <$> Writer.CPS.runWriterT x) hdl other (Swap (ctx, mempty))
+#endif
 
 instance (Algebra sig m, Monoid w) => Algebra (Writer w :+: sig) (Writer.Lazy.WriterT w m) where
   alg hdl sig ctx = case sig of
     L (Tell w)     -> ctx <$ Writer.Lazy.tell w
     L (Listen m)   -> swapAndLift <$> Writer.Lazy.listen (hdl (m <$ ctx))
     L (Censor f m) -> Writer.Lazy.censor f (hdl (m <$ ctx))
-    R other        -> Writer.Lazy.WriterT $ swap <$> thread (\ (s, x) -> swap . fmap (mappend s) <$> Writer.Lazy.runWriterT x) hdl other (mempty, ctx)
+    R other        -> Writer.Lazy.WriterT $ getSwap <$> thread (\ (Swap (x, s)) -> Swap . fmap (mappend s) <$> Writer.Lazy.runWriterT x) hdl other (Swap (ctx, mempty))
 
 instance (Algebra sig m, Monoid w) => Algebra (Writer w :+: sig) (Writer.Strict.WriterT w m) where
   alg hdl sig ctx = case sig of
     L (Tell w)     -> ctx <$ Writer.Strict.tell w
     L (Listen m)   -> swapAndLift <$> Writer.Strict.listen (hdl (m <$ ctx))
     L (Censor f m) -> Writer.Strict.censor f (hdl (m <$ ctx))
-    R other        -> Writer.Strict.WriterT $ swap <$> thread (\ (s, x) -> swap . fmap (mappend s) <$> Writer.Strict.runWriterT x) hdl other (mempty, ctx)
+    R other        -> Writer.Strict.WriterT $ getSwap <$> thread (\ (Swap (x, s)) -> Swap . fmap (mappend s) <$> Writer.Strict.runWriterT x) hdl other (Swap (ctx, mempty))
diff --git a/src/Control/Carrier/Empty/Maybe.hs b/src/Control/Carrier/Empty/Maybe.hs
@@ -43,15 +43,9 @@ runEmpty (EmptyC m) = runMaybeT m
 
 -- | @since 1.0.0.0
 newtype EmptyC m a = EmptyC (MaybeT m a)
-  deriving (Applicative, Functor, Monad, MonadFix, MonadIO, MonadTrans)
+  deriving (Algebra (Empty :+: sig), Applicative, Functor, Monad, MonadFix, MonadIO, MonadTrans)
 
 -- | 'EmptyC' passes 'Fail.MonadFail' operations along to the underlying monad @m@, rather than interpreting it as a synonym for 'empty' à la 'MaybeT'.
 instance Fail.MonadFail m => Fail.MonadFail (EmptyC m) where
   fail = lift . Fail.fail
   {-# INLINE fail #-}
-
-instance Algebra sig m => Algebra (Empty :+: sig) (EmptyC m) where
-  alg hdl sig ctx = case sig of
-    L Empty -> EmptyC (MaybeT (pure Nothing))
-    R other -> EmptyC (MaybeT (thread (maybe (pure Nothing) runEmpty) hdl other (Just ctx)))
-  {-# INLINE alg #-}
diff --git a/src/Control/Effect/Empty.hs b/src/Control/Effect/Empty.hs
@@ -4,7 +4,8 @@ This can be seen as similar to 'Control.Effect.Fail.Fail', but without an error
 
 Predefined carriers:
 
-* "Control.Carrier.Empty.Maybe".
+* @"Control.Carrier.Empty.Maybe".'Control.Carrier.Empty.Maybe.MaybeC'@
+* @"Control.Monad.Trans.Maybe".'Control.Monad.Trans.Maybe.MaybeT'@
 * If 'Empty' is the last effect in a stack, it can be interpreted directly to a 'Maybe'.
 
 @since 1.0.0.0

diff --git a/src/Control/Effect/State.hs b/src/Control/Effect/State.hs
@@ -6,6 +6,7 @@ Predefined carriers:
 
 * "Control.Carrier.State.Strict", which is strict in its updates.
 * "Control.Carrier.State.Lazy", which is lazy in its updates. This enables more programs to terminate, such as cyclic computations expressed with @MonadFix@ or @-XRecursiveDo@, at the cost of efficiency.
+* "Control.Monad.Trans.RWS.CPS"
 * "Control.Monad.Trans.RWS.Lazy"
 * "Control.Monad.Trans.RWS.Strict"
 * "Control.Monad.Trans.State.Lazy"

diff --git a/src/Control/Effect/Writer.hs b/src/Control/Effect/Writer.hs
@@ -6,8 +6,10 @@
 Predefined carriers:
 
 * "Control.Carrier.Writer.Strict". (A lazy carrier is not provided due to the inherent space leaks associated with lazy writer monads.)
+* "Control.Monad.Trans.RWS.CPS"
 * "Control.Monad.Trans.RWS.Lazy"
 * "Control.Monad.Trans.RWS.Strict"
+* "Control.Monad.Trans.Writer.CPS"
 * "Control.Monad.Trans.Writer.Lazy"
 * "Control.Monad.Trans.Writer.Strict"
 * If 'Writer' @w@ is the last effect in a stack, it can be interpreted to a tuple @(w, a)@ given some result type @a@ and the presence of a 'Monoid' instance for @w@.

diff --git a/test/Empty.hs b/test/Empty.hs
@@ -11,6 +11,7 @@ module Empty
 ) where
 
 import qualified Control.Carrier.Empty.Maybe as EmptyC
+import qualified Control.Monad.Trans.Maybe as MaybeT
 import           Control.Effect.Empty
 import           Data.Maybe (maybeToList)
 import           Gen
@@ -26,6 +27,7 @@ tests = testGroup "Empty"
     , testMonadFix
     , testEmpty
     ] >>= ($ runL (fmap maybeToList . EmptyC.runEmpty))
+  , testGroup "MaybeT" $ testEmpty (runL (fmap maybeToList . MaybeT.runMaybeT))
   , testGroup "Maybe"  $ testEmpty (runL (pure . maybeToList))
   ] where
   testMonad    run = Monad.test    (m gen0 (\ _ _ -> [])) a b c initial run

diff --git a/test/State.hs b/test/State.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -13,6 +14,9 @@ module State
 import qualified Control.Carrier.State.Lazy as LazyStateC
 import qualified Control.Carrier.State.Strict as StrictStateC
 import           Control.Effect.State
+#if MIN_VERSION_transformers(0,5,6)
+import qualified Control.Monad.Trans.RWS.CPS as CPSRWST
+#endif
 import qualified Control.Monad.Trans.RWS.Lazy as LazyRWST
 import qualified Control.Monad.Trans.RWS.Strict as StrictRWST
 import qualified Control.Monad.Trans.State.Lazy as LazyStateT
@@ -38,6 +42,9 @@ tests = testGroup "State"
     ] >>= ($ runC StrictStateC.runState)
   , testGroup "StateT (Lazy)"   $ testState (runC (fmap (fmap swap) . flip LazyStateT.runStateT))
   , testGroup "StateT (Strict)" $ testState (runC (fmap (fmap swap) . flip StrictStateT.runStateT))
+#if MIN_VERSION_transformers(0,5,6)
+  , testGroup "RWST (CPS)"      $ testState (runC (runRWST CPSRWST.runRWST))
+#endif
   , testGroup "RWST (Lazy)"     $ testState (runC (runRWST LazyRWST.runRWST))
   , testGroup "RWST (Strict)"   $ testState (runC (runRWST StrictRWST.runRWST))
   ] where

diff --git a/test/Writer.hs b/test/Writer.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -14,8 +15,14 @@ module Writer
 import           Control.Arrow ((&&&))
 import qualified Control.Carrier.Writer.Strict as WriterC
 import           Control.Effect.Writer
+#if MIN_VERSION_transformers(0,5,6)
+import qualified Control.Monad.Trans.RWS.CPS as CPSRWST
+#endif
 import qualified Control.Monad.Trans.RWS.Lazy as LazyRWST
 import qualified Control.Monad.Trans.RWS.Strict as StrictRWST
+#if MIN_VERSION_transformers(0,5,6)
+import qualified Control.Monad.Trans.Writer.CPS as CPSWriterT
+#endif
 import qualified Control.Monad.Trans.Writer.Lazy as LazyWriterT
 import qualified Control.Monad.Trans.Writer.Strict as StrictWriterT
 import           Data.Bifunctor (first)
@@ -34,8 +41,14 @@ tests = testGroup "Writer"
     , testWriter
     ] >>= ($ runL WriterC.runWriter)
   , testGroup "(,)"              $ testWriter (runL pure)
+#if MIN_VERSION_transformers(0,5,6)
+  , testGroup "WriterT (CPS)"    $ testWriter (runL (fmap swap . CPSWriterT.runWriterT))
+#endif
   , testGroup "WriterT (Lazy)"   $ testWriter (runL (fmap swap . LazyWriterT.runWriterT))
   , testGroup "WriterT (Strict)" $ testWriter (runL (fmap swap . StrictWriterT.runWriterT))
+#if MIN_VERSION_transformers(0,5,6)
+  , testGroup "RWST (CPS)"       $ testWriter (runL (runRWST CPSRWST.runRWST))
+#endif
   , testGroup "RWST (Lazy)"      $ testWriter (runL (runRWST LazyRWST.runRWST))
   , testGroup "RWST (Strict)"    $ testWriter (runL (runRWST StrictRWST.runRWST))
   ] where