nix flake

.envrc

@@ -0,0 +1 @@
+use flake -Lv --fallback 

.gitignore

@@ -1,3 +1,5 @@
 /dist-newstyle
 /cabal.project.local
 /stack.yaml
+result*
+.direnv

cabal.project

@@ -10,13 +10,13 @@ repository head.hackage.ghc.haskell.org
     26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
     7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d
 
-allow-newer:
-  primitive-0.7.0.1:base
-  splitmix-0.0.5:base
+-- allow-newer:
+--   primitive-0.7.0.1:base,
+--   splitmix-0.0.5:base
 
-constraints:
-  primitive ==0.7.0.1,
-  QuickCheck ==2.13.2 || ==2.14
+-- constraints:
+--   primitive ==0.7.0.1,
+--   QuickCheck ==2.13.2 || ==2.14
 
 package *
   optimization: 2

eff/src/Control/Effect/Coroutine.hs

@@ -7,16 +7,16 @@ module Control.Effect.Coroutine
 
 import Control.Effect.Base
 
-data Coroutine a b :: Effect where
-  Yield :: a -> Coroutine a b m b
+data Coroutine i o :: Effect where
+  Yield :: o -> Coroutine i o m i
 
-yield :: Coroutine a b :< effs => a -> Eff effs b
+yield :: Coroutine i o :< effs => o -> Eff effs i
 yield = send . Yield
 
-data Status effs a b c
-  = Done c
-  | Yielded a !(b -> Eff (Coroutine a b ': effs) c)
+data Status effs i o a
+  = Done a
+  | Yielded o !(i -> Eff (Coroutine i o ': effs) a)
 
-runCoroutine :: Eff (Coroutine a b ': effs) c -> Eff effs (Status effs a b c)
+runCoroutine :: Eff (Coroutine i o ': effs) a -> Eff effs (Status effs i o a)
 runCoroutine = handle (pure . Done) \case
   Yield a -> control0 \k -> pure $! Yielded a k

eff/src/Control/Effect/Internal.hs

@@ -23,9 +23,9 @@ import Data.IORef
 import Data.Kind (Constraint, Type)
 import Data.Type.Coercion (Coercion(..), gcoerceWith)
 import Data.Type.Equality ((:~:)(..), gcastWith)
-import GHC.Exts (Any, Int(..), Int#, RealWorld, RuntimeRep(..), SmallArray#, State#, TYPE, prompt#, control0#)
+import GHC.Exts (Any, Int(..), Int#, PromptTag#, RealWorld, RuntimeRep(..), SmallArray#, State#, TYPE, control0#, newPromptTag#, prompt#)
 import GHC.Types (IO(..))
-import System.IO.Unsafe (unsafeDupablePerformIO)
+import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO)
 import Unsafe.Coerce (unsafeCoerce)
 
 import Control.Effect.Internal.Debug
@@ -268,6 +268,28 @@ captureVM a = gcoerceWith (Coercion.sym $ anyCo @a) $
   IO.throwIO $! UnwindControl (coerce a)
 {-# INLINE captureVM #-}
 
+data PromptTag a = PromptTag# { getPromptTag# :: PromptTag# a }
+
+-- | The global 'PromptTag#' used for all @eff@ handlers. We don’t use a
+-- separate 'PromptTag#' for each handler because we have to implement our own
+-- prompt tags, anyway, and there’s no easy way to maintain the type safety
+-- benefits of using separate prompt tags.
+--
+-- However, using a single, global prompt tag for everything is, in fact,
+-- astonishingly unsafe. For one, it has a polymorphic type, even though it’s
+-- actually only a single prompt tag—it morally has type
+-- @'PromptTag' ('Result' 'Any')@—which means using it effectively involves an
+-- implicit 'unsafeCoerce'. What’s more, @eff@’s (incredibly unsafe) internal
+-- machinery depends on nothing except its primitives ever actually installing
+-- these prompt tags.
+--
+-- You do not want to use this.
+astonishinglyUnsafeGlobalEffPromptTag :: PromptTag (Result a)
+astonishinglyUnsafeGlobalEffPromptTag = unsafePerformIO $ IO \s ->
+  case newPromptTag# s of
+    (# s', tag #) -> (# s', PromptTag# tag #)
+{-# NOINLINE astonishinglyUnsafeGlobalEffPromptTag #-}
+
 -- | Runs an 'EVM' action with a new prompt installed. The arguments specify
 -- what happens when control exits the action.
 promptVM
@@ -283,9 +305,10 @@ promptVM
 promptVM m onReturn onAbort onControl = IO.handle handleUnwind do
   -- TODO: Explain why it is crucial that the exception handler is installed
   -- outside of the frame where we replace the registers!
-  Result _ a <- IO (prompt# (unIO (packIOResult m)))
+  Result _ a <- IO (prompt# tag# (unIO (packIOResult m)))
   onReturn a
   where
+    tag# = getPromptTag# (astonishinglyUnsafeGlobalEffPromptTag @a)
     handleUnwind (UnwindAbort pid a) = onAbort pid a
     handleUnwind (UnwindControl cap) = gcoerceWith (anyCo @a) $ onControl (coerce cap)
 {-# INLINE promptVM #-}
@@ -306,8 +329,9 @@ promptVM_ m rs onCapture = promptVM m onReturn rethrowAbort onCapture where
   rethrowAbort pid a = IO.throwIO $! UnwindAbort pid a
 {-# INLINE promptVM_ #-}
 
-controlVM :: ((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
-controlVM f = IO (control0# f#) <&> \(Result rs a) -> (BoxRegisters rs, a) where
+controlVM :: forall a b. ((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
+controlVM f = IO (control0# tag# f#) <&> \(Result rs a) -> (BoxRegisters rs, a) where
+  tag# = getPromptTag# (astonishinglyUnsafeGlobalEffPromptTag @b)
   f# k# = unIO (f k <&> \(BoxRegisters rs, a) -> Result rs a) where
     k a = EVM# \rs -> IO $ k# \s -> (# s, Result rs a #)
 {-# INLINE controlVM #-}

eff/test/Control/EffectSpec.hs

@@ -2,7 +2,7 @@ module Control.EffectSpec (spec) where
 
 import Control.Applicative
 import Control.Monad
-import Data.Foldable
+import Data.Bifunctor
 import Data.Functor
 import Data.Monoid (Sum(..))
 import Test.Hspec
@@ -93,14 +93,31 @@ spec = do
           results `shouldBe` (Sum 6, [(Sum 3, True), (Sum 4, False)])
 
   describe "Coroutine" do
-    let feed :: forall a b effs c. [b] -> Eff (Coroutine a b ': effs) c -> Eff effs [a]
+    let feed :: forall i o effs a. [i] -> Eff (Coroutine i o ': effs) a
+             -> Eff effs ([o], Maybe (i -> Eff (Coroutine i o ': effs) a))
         feed as0 m = go as0 =<< runCoroutine m where
-          go (a:as) (Yielded b k) = (b:) <$> (feed as (k a))
-          go []     (Yielded b _) = pure [b]
-          go _      (Done _)      = pure []
+          go (a:as) (Yielded b k) = first (b:) <$> feed as (k a)
+          go []     (Yielded b k) = pure ([b], Just k)
+          go _      (Done _)      = pure ([], Nothing)
+
+        feed_ :: forall i o effs a. [i] -> Eff (Coroutine i o ': effs) a -> Eff effs [o]
+        feed_ xs m = fst <$> feed xs m
 
     it "allows suspending and resuming a computation" do
       let squares :: Coroutine Integer Integer :< effs => Integer -> Eff effs ()
           squares n = yield (n * n) >>= squares
-      run (feed @Integer @Integer [1..5] (squares 0))
+      run (feed_ @Integer @Integer [1..5] (squares 0))
         `shouldBe` [0, 1, 4, 9, 16, 25]
+
+    it "allows resuming a computation with different handlers in scope" do
+      let squares' :: (Reader Integer :< effs, Coroutine () Integer :< effs) => Eff effs a
+          squares' = ask @Integer >>= \n -> yield @() (n * n) *> squares'
+
+          (results, maybeK) = run $ runReader @Integer 2 $
+            feed @() @Integer [(), (), ()] squares'
+      results `shouldBe` [4, 4, 4, 4]
+      case maybeK of
+        Nothing -> expectationFailure "coroutine ended prematurely"
+        Just k ->
+          run (runReader @Integer 5 $ feed_ @() @Integer [(), ()] (k ()))
+            `shouldBe` [25, 25, 25]