Remove Coroutine and simplify Env operations

effectful.cabal

@@ -71,7 +71,6 @@ library
                      Effectful.Class.Reader
                      Effectful.Class.State
                      Effectful.Class.Writer
-                     Effectful.Coroutine
                      Effectful.Error
                      Effectful.Internal.Env
                      Effectful.Internal.Has

src/Effectful/Coroutine.hs

@@ -1,89 +0,0 @@
--- | Experimental support for coroutines.
-module Effectful.Coroutine
-  ( Coroutine
-  , Status(..)
-  , runCoroutine
-  , yield
-  ) where
-
-import Control.Concurrent.MVar
-import Control.Exception
-import Data.Function
-import qualified Control.Concurrent as C
-
-import Effectful.Internal.Env
-import Effectful.Internal.Has
-import Effectful.Internal.Monad
-
-data Coroutine o i = forall es r. Coroutine
-  { crInput         :: MVar (i, Env es)
-  , crState         :: MVar (State o r)
-  , crCallerEnvSize :: Int
-  }
-
-data Status es o i r
-  = Done r
-  | Yielded o (i -> Eff es (Status es o i r))
-
-runCoroutine :: Eff (Coroutine o i : es) r -> Eff es (Status es o i r)
-runCoroutine (Eff m) = impureEff $ \es -> do
-  size    <- sizeEnv es
-  mvInput <- newEmptyMVar
-  mvState <- newEmptyMVar
-  mask $ \restore -> do
-    -- Create a worker thread and continue execution there.
-    tid <- C.forkIO $ do
-      let cr = Coroutine mvInput mvState size
-      er <- try $ restore . m =<< unsafeConsEnv cr es
-      tryPutMVar mvState (either Failure Success er) >>= \case
-        False -> error "unexpected"
-        True  -> pure ()
-    waitForStatus restore es size tid mvInput mvState
-
-yield :: Coroutine o i :> es => o -> Eff es i
-yield o = impureEff $ \es -> mask $ \restore -> do
-  Coroutine{..} <- getEnv es
-  size <- sizeEnv es
-  -- Save local part of the environment as the caller will discard it.
-  localEs <- takeLastEnv (size - crCallerEnvSize) es
-  -- Pass control to the caller.
-  tryPutMVar crState (Yield o) >>= \case
-    False -> error "unexpected"
-    True  -> do
-      (i, callerEs) <- restore $ takeMVar crInput
-      -- The caller resumed, reconstruct the local environment. The environment
-      -- needs to be replaced since the one we just got might be completely
-      -- different to what we had before suspending the computation, e.g. if the
-      -- computation was resumed in a different thread.
-      unsafeReplaceEnv es =<< unsafeAppendEnv callerEs localEs
-      pure i
-
-----------------------------------------
--- Internal
-
-data State o r where
-  Failure :: SomeException -> State o r
-  Success :: r             -> State o r
-  Yield   :: o             -> State o r
-
-waitForStatus
-  :: (forall a. IO a -> IO a)
-  -> Env es
-  -> Int
-  -> C.ThreadId
-  -> MVar (i, Env es)
-  -> MVar (State o r)
-  -> IO (Status es o i r)
-waitForStatus restore0 es0 size0 tid mvInput mvState = fix $ \loop -> do
-  try @SomeException (restore0 $ takeMVar mvState) >>= \case
-    Left e            -> throwTo tid e >> loop
-    Right (Failure e) -> throwIO e
-    Right (Success r) -> Done r      <$ unsafeTrimEnv size0 es0
-    Right (Yield o)   -> Yielded o k <$ unsafeTrimEnv size0 es0
-  where
-    k i = impureEff $ \es -> mask $ \restore -> do
-      size <- sizeEnv es
-      -- Resume suspended computation with the current environment.
-      tryPutMVar mvInput (i, es) >>= \case
-        False -> error "unexpected"
-        True  -> waitForStatus restore es size tid mvInput mvState

src/Effectful/Error.hs

@@ -24,11 +24,11 @@ runError
   => Eff (Error e : es) a
   -> Eff es (Either ([String], e) a)
 runError (Eff m) = impureEff $ \es0 -> mask $ \release -> do
-  size <- sizeEnv es0
+  size0 <- sizeEnv es0
   es <- unsafeConsEnv (Error @e) es0
   try (release $ m es) >>= \case
-    Right a           -> Right a      <$ unsafeTrimEnv size es
-    Left (WrapE cs e) -> Left (cs, e) <$ unsafeTrimEnv size es
+    Right a           -> Right a      <$ unsafeTailEnv size0 es
+    Left (WrapE cs e) -> Left (cs, e) <$ unsafeTailEnv size0 es
 
 throwError
   :: (HasCallStack, Exception e, Error e :> es)

src/Effectful/Internal/Env.hs

@@ -10,15 +10,12 @@ module Effectful.Internal.Env
   , emptyEnv
   , cloneEnv
   , sizeEnv
-  , takeLastEnv
   , getEnv
   , checkSizeEnv
 
   -- * Extending and shrinking
-  , unsafeReplaceEnv
   , unsafeConsEnv
-  , unsafeAppendEnv
-  , unsafeTrimEnv
+  , unsafeTailEnv
 
   -- * Data retrieval and update
   , unsafePutEnv
@@ -61,14 +58,6 @@ sizeEnv (Env ref) = do
   EnvRef n _ <- readIORef ref
   pure n
 
--- | Take last @k@ values from the top of the environment.
-takeLastEnv :: HasCallStack => Int -> Env es0 -> IO (Env es)
-takeLastEnv k (Env ref) = do
-  EnvRef n es <- readIORef ref
-  if k > n
-    then error $ "k (" ++ show k ++ ") > n (" ++ show n ++ ")"
-    else fmap Env . newIORef . EnvRef k =<< cloneSmallMutableArray es (n - k) k
-
 -- | Extract a specific data type from the environment.
 getEnv :: forall e es. (HasCallStack, e :> es) => Env es -> IO e
 getEnv (Env ref) = do
@@ -84,11 +73,7 @@ checkSizeEnv k (Env ref) = do
 ----------------------------------------
 -- Extending and shrinking
 
--- | Replace the first argument with the second one in place.
-unsafeReplaceEnv :: HasCallStack => Env es -> Env es -> IO ()
-unsafeReplaceEnv (Env ref0) (Env ref1) = writeIORef ref0 =<< readIORef ref1
-
--- | Extend the environment with a new data type in place.
+-- | Extend the environment with a new data type (in place).
 unsafeConsEnv :: HasCallStack => e -> Env es -> IO (Env (e : es))
 unsafeConsEnv e (Env ref) = do
   EnvRef n es0 <- readIORef ref
@@ -107,47 +92,23 @@ unsafeConsEnv e (Env ref) = do
   pure $ Env ref
 {-# NOINLINE unsafeConsEnv #-}
 
--- | Extend the first environment with the second one in place.
-unsafeAppendEnv :: HasCallStack => Env es0 -> Env es1 -> IO (Env es)
-unsafeAppendEnv (Env ref0) (Env ref1) = do
-  EnvRef n0 es0 <- readIORef ref0
-  EnvRef n1 es1 <- readIORef ref1
-  let n = n0 + n1
-  if n <= sizeofSmallMutableArray es0
-    then do
-      copySmallMutableArray es0 n0 es1 0 n1
-      writeIORef ref0 $! EnvRef n es0
-      pure $ Env ref0
-    else do
-      es <- newSmallArray n (error "undefined field")
-      copySmallMutableArray es 0  es0 0 n0
-      copySmallMutableArray es n0 es1 0 n1
-      writeIORef ref0 $! EnvRef n es
-      pure $ Env ref0
-{-# NOINLINE unsafeAppendEnv #-}
-
--- | Trim the environment to the given size in place.
-unsafeTrimEnv :: HasCallStack => Int -> Env es -> IO (Env es0)
-unsafeTrimEnv k (Env ref) = do
+-- | Shrink the environment by one data type (in place). Makes sure the size of
+-- the environment is as expected.
+unsafeTailEnv :: HasCallStack => Int -> Env (e : es) -> IO (Env es)
+unsafeTailEnv k (Env ref) = do
   EnvRef n es <- readIORef ref
-  if k > n
-    then error $ "k (" ++ show k ++ ") > n (" ++ show n ++ ")"
+  if k /= n - 1
+    then error $ "k (" ++ show k ++ ") /= n - 1 (" ++ show (n - 1) ++ ")"
     else do
-      overwrite es k (n - k)
+      writeSmallArray es k (error "undefined field")
       writeIORef ref $! EnvRef k es
       pure $ Env ref
-  where
-    overwrite es base = \case
-      0 -> pure ()
-      i -> do
-        writeSmallArray es (base + i - 1) (error "undefined field")
-        overwrite es base (i - 1)
-{-# NOINLINE unsafeTrimEnv #-}
+{-# NOINLINE unsafeTailEnv #-}
 
 ----------------------------------------
 -- Data retrieval and update
 
--- | Replace the data type in the environment with a new value in place.
+-- | Replace the data type in the environment with a new value (in place).
 unsafePutEnv
   :: forall e es. (HasCallStack, e :> es)
   => e
@@ -157,7 +118,7 @@ unsafePutEnv e (Env ref) = do
   EnvRef n es <- readIORef ref
   e `seq` writeSmallArray es (ixEnv @e @es n) (toAny e)
 
--- | Modify the data type in the environment in place.
+-- | Modify the data type in the environment (in place).
 unsafeModifyEnv
   :: forall e es. (HasCallStack, e :> es)
   => (e -> e)
@@ -169,7 +130,7 @@ unsafeModifyEnv f (Env ref) = do
   e <- f . fromAny <$> readSmallArray es i
   e `seq` writeSmallArray es i (toAny e)
 
--- | Modify the data type in the enviroment in place and return a value.
+-- | Modify the data type in the enviroment (in place) and return a value.
 unsafeStateEnv
   :: forall e es a. (HasCallStack, e :> es)
   => (e -> (a, e))

src/Effectful/Internal/Monad.hs

@@ -138,23 +138,23 @@ runInIO f = impureEff $ \es -> do
 
 runEffect :: e -> Eff (e : es) a -> Eff es (a, e)
 runEffect e0 (Eff m) = impureEff $ \es0 -> do
-  size <- sizeEnv es0
+  size0 <- sizeEnv es0
   bracket (unsafeConsEnv e0 es0)
-          (unsafeTrimEnv size)
+          (unsafeTailEnv size0)
           (\es -> (,) <$> m es <*> getEnv es)
 
 evalEffect :: e -> Eff (e : es) a -> Eff es a
 evalEffect e (Eff m) = impureEff $ \es0 -> do
-  size <- sizeEnv es0
+  size0 <- sizeEnv es0
   bracket (unsafeConsEnv e es0)
-          (unsafeTrimEnv size)
+          (unsafeTailEnv size0)
           (\es -> m es)
 
 execEffect :: e -> Eff (e : es) a -> Eff es e
 execEffect e0 (Eff m) = impureEff $ \es0 -> do
-  size <- sizeEnv es0
+  size0 <- sizeEnv es0
   bracket (unsafeConsEnv e0 es0)
-          (unsafeTrimEnv size)
+          (unsafeTailEnv size0)
           (\es -> m es *> getEnv es)
 
 getEffect :: e :> es => Eff es e

src/Effectful/Resource.hs

@@ -32,10 +32,10 @@ runResource (Eff m) = impureEff $ \es0 -> do
   mask $ \restore -> do
     es <- unsafeConsEnv (Resource istate) es0
     a <- restore (m es) `catch` \e -> do
-      _ <- unsafeTrimEnv size0 es
+      _ <- unsafeTailEnv size0 es
       RI.stateCleanupChecked (Just e) istate
       throwIO e
-    _ <- unsafeTrimEnv size0 es
+    _ <- unsafeTailEnv size0 es
     RI.stateCleanupChecked Nothing istate
     pure a