Remove lowering functions and forklift (#438)

* Remove forklift

* Remove lowerResource

* Changelog

* changelog

* Remove (@)

* Update documentation

* Remove the ancient benchmarks

* Remove fixpoint lowerings

ChangeLog.md

@@ -6,9 +6,21 @@
 
 - Removed `Polysemy.View`
 - Removed `Polysemy.Law`
+- Removed `(@)` and `(@@)` from `Polysemy`
+- Removed `withLowerToIO` from `Polysemy`. Use `withWeavingToFinal` instead.
+- Removed `asyncToIO` and `lowerAsync` from `Polysemy.Async`. Use
+    `asyncToIOFinal` instead.
+- Removed `lowerEmbedded` from `Polysemy.IO`. Use `embedToMonadIO` instead.
+- Removed `lowerError` from `Polysemy.Error`. Use `errorToIOFinal` instead.
+- Removed `resourceToIO` and `lowerResource` from `Polysemy.Resource`. Use
+    `resourceToIOFinal` instead.
+- Removed `runFixpoint` and `runFixpointM` from `Polysemy.Fixpoint`. Use
+    `fixpointToFinal` instead.
 
 ### Other Changes
 
+- Exposed `send` from `Polysemy`.
+
 ## 1.7.1.0 (2021-11-23)
 
 ### Other Changes

bench/Poly.hs

@@ -1,64 +0,0 @@
-{-# LANGUAGE DataKinds        #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs            #-}
-{-# LANGUAGE TemplateHaskell  #-}
-{-# LANGUAGE TypeApplications #-}
-
-{-# OPTIONS_GHC -fwarn-all-missed-specializations #-}
-
-module Poly where
-
-import Polysemy
-import Polysemy.Error
-import Polysemy.Resource
-import Polysemy.State
-import Polysemy.Input
-import Polysemy.Output
-
-
-slowBeforeSpecialization :: Member (State Int) r => Sem r Int
-slowBeforeSpecialization = do
-  n <- get
-  if n <= 0
-     then pure n
-     else do
-       put $ n - 1
-       slowBeforeSpecialization
-
-{-# SPECIALIZE slowBeforeSpecialization :: Sem '[State Int] Int #-}
-
-
-countDown :: Int -> Int
-countDown s =
-  fst . run . runState s $ slowBeforeSpecialization
-
-prog
-    :: Sem '[ State Bool
-            , Error Bool
-            , Resource
-            , Embed IO
-            ] Bool
-prog = catch @Bool (throw True) (pure . not)
-
-zoinks :: IO (Either Bool Bool)
-zoinks = fmap (fmap snd)
-       . (runM .@ lowerResource .@@ lowerError)
-       . runState False
-       $ prog
-
-data Console m a where
-  ReadLine :: Console m String
-  WriteLine :: String -> Console m ()
-
-makeSem ''Console
-
-runConsoleBoring :: [String] -> Sem (Console ': r) a -> Sem r ([String], a)
-runConsoleBoring inputs
-  = runOutputMonoid (:[])
-  . runInputList inputs
-  . reinterpret2
-  (\case
-      ReadLine -> maybe "" id <$> input
-      WriteLine msg -> output msg
-  )
-

bench/countDown.hs

@@ -1,133 +0,0 @@
-{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, GADTs, TypeOperators #-}
-module Main (main) where
-
-import Control.Monad (replicateM_)
-
-import qualified Control.Monad.Except as MTL
-import qualified Control.Monad.State as MTL
-import qualified Control.Monad.Free as Free
-
-import Criterion (bench, bgroup, whnf)
-import Criterion.Main (defaultMain)
-
-import Control.Monad.Freer (Member, Eff, run, send)
-import Control.Monad.Freer.Internal (Eff(..), decomp, qApp, tsingleton)
-import Control.Monad.Freer.Error (runError, throwError)
-import Control.Monad.Freer.State (get, put, runState)
-
-import qualified Poly as P
-
---------------------------------------------------------------------------------
-                        -- State Benchmarks --
---------------------------------------------------------------------------------
-
-oneGet :: Int -> (Int, Int)
-oneGet n = run (runState n get)
-
-oneGetMTL :: Int -> (Int, Int)
-oneGetMTL = MTL.runState MTL.get
-
-countDown :: Int -> (Int, Int)
-countDown start = run (runState start go)
-  where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)
-
-countDownMTL :: Int -> (Int, Int)
-countDownMTL = MTL.runState go
-  where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go)
-
---------------------------------------------------------------------------------
-                       -- Exception + State --
---------------------------------------------------------------------------------
-countDownExc :: Int -> Either String (Int,Int)
-countDownExc start = run $ runError (runState start go)
-  where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)
-
-countDownExcMTL :: Int -> Either String (Int,Int)
-countDownExcMTL = MTL.runStateT go
-  where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go)
-
---------------------------------------------------------------------------------
-                          -- Freer: Interpreter --
---------------------------------------------------------------------------------
-data Http out where
-  Open :: String -> Http ()
-  Close :: Http ()
-  Post  :: String -> Http String
-  Get   :: Http String
-
-open' :: Member Http r => String -> Eff r ()
-open'  = send . Open
-
-close' :: Member Http r => Eff r ()
-close' = send Close
-
-post' :: Member Http r => String -> Eff r String
-post' = send . Post
-
-get' :: Member Http r => Eff r String
-get' = send Get
-
-runHttp :: Eff (Http ': r) w -> Eff r w
-runHttp (Val x) = pure x
-runHttp (E u q) = case decomp u of
-  Right (Open _) -> runHttp (qApp q ())
-  Right Close    -> runHttp (qApp q ())
-  Right (Post d) -> runHttp (qApp q d)
-  Right Get      -> runHttp (qApp q "")
-  Left u'        -> E u' (tsingleton (runHttp . qApp q ))
-
---------------------------------------------------------------------------------
-                          -- Free: Interpreter --
---------------------------------------------------------------------------------
-data FHttpT x
-  = FOpen String x
-  | FClose x
-  | FPost String (String -> x)
-  | FGet (String -> x)
-    deriving Functor
-
-type FHttp = Free.Free FHttpT
-
-fopen' :: String -> FHttp ()
-fopen' s = Free.liftF $ FOpen s ()
-
-fclose' :: FHttp ()
-fclose' = Free.liftF $ FClose ()
-
-fpost' :: String -> FHttp String
-fpost' s = Free.liftF $ FPost s id
-
-fget' :: FHttp String
-fget' = Free.liftF $ FGet id
-
-runFHttp :: FHttp a -> Maybe a
-runFHttp (Free.Pure x) = pure x
-runFHttp (Free.Free (FOpen _ n)) = runFHttp n
-runFHttp (Free.Free (FClose n))  = runFHttp n
-runFHttp (Free.Free (FPost s n)) = pure s  >>= runFHttp . n
-runFHttp (Free.Free (FGet n))    = pure "" >>= runFHttp . n
-
---------------------------------------------------------------------------------
-                        -- Benchmark Suite --
---------------------------------------------------------------------------------
-prog :: Member Http r => Eff r ()
-prog = open' "cats" >> get' >> post' "cats" >> close'
-
-prog' :: FHttp ()
-prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose'
-
-p :: Member Http r => Int -> Eff r ()
-p count   =  open' "cats" >> replicateM_ count (get' >> post' "cats") >>  close'
-
-p' :: Int -> FHttp ()
-p' count  = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose'
-
-main :: IO ()
-main =
-  defaultMain [
-    bgroup "Countdown Bench" [
-        bench "discount"          $ whnf P.countDown 10000
-      , bench "freer-simple"      $ whnf countDown 10000
-      , bench "mtl"               $ whnf countDownMTL 10000
-    ]
-  ]

package.yaml

@@ -100,13 +100,3 @@ tests:
     generated-other-modules:
     - Build_doctests
 
-benchmarks:
-  polysemy-bench:
-    source-dirs: bench
-    main: countDown.hs
-    dependencies:
-    - criterion
-    - free
-    - freer-simple
-    - mtl
-    - polysemy

polysemy.cabal

@@ -56,7 +56,6 @@ library
       Polysemy.Internal.CustomErrors
       Polysemy.Internal.CustomErrors.Redefined
       Polysemy.Internal.Fixpoint
-      Polysemy.Internal.Forklift
       Polysemy.Internal.Index
       Polysemy.Internal.Kind
       Polysemy.Internal.NonDet
@@ -130,7 +129,6 @@ test-suite polysemy-test
   main-is: Main.hs
   other-modules:
       AlternativeSpec
-      AsyncSpec
       BracketSpec
       DoctestSpec
       ErrorSpec
@@ -139,7 +137,6 @@ test-suite polysemy-test
       FixpointSpec
       FusionSpec
       HigherOrderSpec
-      InspectorSpec
       InterceptSpec
       KnownRowSpec
       OutputSpec
@@ -192,48 +189,3 @@ test-suite polysemy-test
         MonadFailDesugaring
         TypeInType
   default-language: Haskell2010
-
-benchmark polysemy-bench
-  type: exitcode-stdio-1.0
-  main-is: countDown.hs
-  other-modules:
-      Poly
-      Paths_polysemy
-  hs-source-dirs:
-      bench
-  default-extensions:
-      DataKinds
-      DeriveFunctor
-      FlexibleContexts
-      GADTs
-      LambdaCase
-      PolyKinds
-      RankNTypes
-      ScopedTypeVariables
-      StandaloneDeriving
-      TypeApplications
-      TypeOperators
-      TypeFamilies
-      UnicodeSyntax
-  build-depends:
-      async >=2.2 && <3
-    , base >=4.9 && <5
-    , containers >=0.5 && <0.7
-    , criterion
-    , first-class-families >=0.5.0.0 && <0.9
-    , free
-    , freer-simple
-    , mtl
-    , polysemy
-    , stm ==2.*
-    , syb ==0.7.*
-    , template-haskell >=2.12.0.0 && <3
-    , th-abstraction >=0.3.1.0 && <0.5
-    , transformers >=0.5.2.0 && <0.6
-    , type-errors >=0.2.0.0
-    , unagi-chan >=0.4.0.0 && <0.5
-  if impl(ghc < 8.6)
-    default-extensions:
-        MonadFailDesugaring
-        TypeInType
-  default-language: Haskell2010

src/Polysemy.hs

@@ -120,17 +120,10 @@ module Polysemy
   , reinterpret2H
   , reinterpret3H
 
-    -- * Combinators for Interpreting Directly to IO
-  , withLowerToIO
-
     -- * Kind Synonyms
   , Effect
   , EffectRow
 
-    -- * Composing IO-based Interpreters
-  , (.@)
-  , (.@@)
-
     -- * Tactics
     -- | Higher-order effects need to explicitly thread /other effects'/ state
     -- through themselves. Tactics are a domain-specific language for describing
@@ -155,7 +148,6 @@ module Polysemy
 import Polysemy.Final
 import Polysemy.Internal
 import Polysemy.Internal.Combinators
-import Polysemy.Internal.Forklift
 import Polysemy.Internal.Kind
 import Polysemy.Internal.Tactics
 import Polysemy.Internal.TH.Effect

src/Polysemy/Async.hs

@@ -13,9 +13,7 @@ module Polysemy.Async
   , sequenceConcurrently
 
     -- * Interpretations
-  , asyncToIO
   , asyncToIOFinal
-  , lowerAsync
   ) where
 
 import qualified Control.Concurrent.Async as A
@@ -48,43 +46,6 @@ sequenceConcurrently :: forall t r a. (Traversable t, Member Async r) =>
 sequenceConcurrently t = traverse async t >>= traverse await
 {-# INLINABLE sequenceConcurrently #-}
 
-------------------------------------------------------------------------------
--- | A more flexible --- though less performant ---
--- version of 'asyncToIOFinal'.
---
--- This function is capable of running 'Async' effects anywhere within an
--- effect stack, without relying on 'Final' to lower it into 'IO'.
--- Notably, this means that 'Polysemy.State.State' effects will be consistent
--- in the presence of 'Async'.
---
--- 'asyncToIO' is __unsafe__ if you're using 'await' inside higher-order actions
--- of other effects interpreted after 'Async'.
--- See <https://github.com/polysemy-research/polysemy/issues/205 Issue #205>.
---
--- Prefer 'asyncToIOFinal' unless you need to run pure, stateful interpreters
--- after the interpreter for 'Async'.
--- (Pure interpreters are interpreters that aren't expressed in terms of
--- another effect or monad; for example, 'Polysemy.State.runState'.)
---
--- @since 1.0.0.0
-asyncToIO
-    :: Member (Embed IO) r
-    => Sem (Async ': r) a
-    -> Sem r a
-asyncToIO m = withLowerToIO $ \lower _ -> lower $
-  interpretH
-    ( \case
-        Async a -> do
-          ma  <- runT a
-          ins <- getInspectorT
-          fa  <- embed $ A.async $ lower $ asyncToIO ma
-          pureT $ inspect ins <$> fa
-
-        Await a -> pureT =<< embed (A.wait a)
-        Cancel a -> pureT =<< embed (A.cancel a)
-    )  m
-{-# INLINE asyncToIO #-}
-
 ------------------------------------------------------------------------------
 -- | Run an 'Async' effect in terms of 'A.async' through final 'IO'.
 --
@@ -92,16 +53,6 @@ asyncToIO m = withLowerToIO $ \lower _ -> lower $
 -- will have local state semantics in regards to 'Async' effects
 -- interpreted this way. See 'Final'.
 --
--- Notably, unlike 'asyncToIO', this is not consistent with
--- 'Polysemy.State.State' unless 'Polysemy.State.runStateIORef' is used.
--- State that seems like it should be threaded globally throughout 'Async'
--- /will not be./
---
--- Use 'asyncToIO' instead if you need to run
--- pure, stateful interpreters after the interpreter for 'Async'.
--- (Pure interpreters are interpreters that aren't expressed in terms of
--- another effect or monad; for example, 'Polysemy.State.runState'.)
---
 -- @since 1.2.0.0
 asyncToIOFinal :: Member (Final IO) r
                => Sem (Async ': r) a
@@ -115,27 +66,3 @@ asyncToIOFinal = interpretFinal $ \case
   Cancel a -> liftS (A.cancel a)
 {-# INLINE asyncToIOFinal #-}
 
-------------------------------------------------------------------------------
--- | Run an 'Async' effect in terms of 'A.async'.
---
--- @since 1.0.0.0
-lowerAsync
-    :: Member (Embed IO) r
-    => (forall x. Sem r x -> IO x)
-       -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely
-       -- some combination of 'runM' and other interpreters composed via '.@'.
-    -> Sem (Async ': r) a
-    -> Sem r a
-lowerAsync lower m = interpretH
-    ( \case
-        Async a -> do
-          ma  <- runT a
-          ins <- getInspectorT
-          fa  <- embed $ A.async $ lower $ lowerAsync lower ma
-          pureT $ inspect ins <$> fa
-
-        Await a -> pureT =<< embed (A.wait a)
-        Cancel a -> pureT =<< embed (A.cancel a)
-    )  m
-{-# INLINE lowerAsync #-}
-{-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}

src/Polysemy/Error.hs

@@ -23,13 +23,11 @@ module Polysemy.Error
   , runError
   , mapError
   , errorToIOFinal
-  , lowerError
   ) where
 
 import qualified Control.Exception as X
 import           Control.Monad
 import qualified Control.Monad.Trans.Except as E
-import           Data.Bifunctor (first)
 import           Data.Typeable
 import           Polysemy
 import           Polysemy.Final
@@ -295,45 +293,3 @@ runErrorAsExcFinal = interpretFinal $ \case
       h' (unwrapExc se <$ s)
 {-# INLINE runErrorAsExcFinal #-}
 
-------------------------------------------------------------------------------
--- | Run an 'Error' effect as an 'IO' 'X.Exception'. This interpretation is
--- significantly faster than 'runError', at the cost of being less flexible.
---
--- @since 1.0.0.0
-lowerError
-    :: ( Typeable e
-       , Member (Embed IO) r
-       )
-    => (∀ x. Sem r x -> IO x)
-       -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is
-       -- likely some combination of 'runM' and other interpreters composed via
-       -- '.@'.
-    -> Sem (Error e ': r) a
-    -> Sem r (Either e a)
-lowerError lower
-    = embed
-    . fmap (first unwrapExc)
-    . X.try
-    . (lower .@ runErrorAsExc)
-{-# INLINE lowerError #-}
-{-# DEPRECATED lowerError "Use 'errorToIOFinal' instead" #-}
-
-
--- TODO(sandy): Can we use the new withLowerToIO machinery for this?
-runErrorAsExc
-    :: forall e r a. ( Typeable e
-       , Member (Embed IO) r
-       )
-    => (∀ x. Sem r x -> IO x)
-    -> Sem (Error e ': r) a
-    -> Sem r a
-runErrorAsExc lower = interpretH $ \case
-  Throw e -> embed $ X.throwIO $ WrappedExc e
-  Catch main handle -> do
-    is <- getInitialStateT
-    m  <- runT main
-    h  <- bindT handle
-    let runIt = lower . runErrorAsExc lower
-    embed $ X.catch (runIt m) $ \(se :: WrappedExc e) ->
-      runIt $ h $ unwrapExc se <$ is
-{-# INLINE runErrorAsExc #-}

src/Polysemy/Fixpoint.hs

@@ -73,45 +73,3 @@ fixpointToFinal = interpretFinal @m $
       fromMaybe (bomb "fixpointToFinal") (inspect ins fa) <$ s
 {-# INLINE fixpointToFinal #-}
 
-------------------------------------------------------------------------------
--- | Run a 'Fixpoint' effect purely.
---
--- __Note__: 'runFixpoint' is subject to the same caveats as 'fixpointToFinal'.
-runFixpoint
-    :: (∀ x. Sem r x -> x)
-    -> Sem (Fixpoint ': r) a
-    -> Sem r a
-runFixpoint lower = interpretH $ \case
-  Fixpoint mf -> do
-    c   <- bindT mf
-    s   <- getInitialStateT
-    ins <- getInspectorT
-    pure $ fix $ \fa ->
-      lower . runFixpoint lower . c $
-        fromMaybe (bomb "runFixpoint") (inspect ins fa) <$ s
-{-# INLINE runFixpoint #-}
-{-# DEPRECATED runFixpoint "Use 'fixpointToFinal' together with \
-                           \'Data.Functor.Identity.Identity' instead" #-}
-
-
-------------------------------------------------------------------------------
--- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance.
---
--- __Note__: 'runFixpointM' is subject to the same caveats as 'fixpointToFinal'.
-runFixpointM
-    :: ( MonadFix m
-       , Member (Embed m) r
-       )
-    => (∀ x. Sem r x -> m x)
-    -> Sem (Fixpoint ': r) a
-    -> Sem r a
-runFixpointM lower = interpretH $ \case
-  Fixpoint mf -> do
-    c   <- bindT mf
-    s   <- getInitialStateT
-    ins <- getInspectorT
-    embed $ mfix $ \fa ->
-      lower . runFixpointM lower . c $
-        fromMaybe (bomb "runFixpointM") (inspect ins fa) <$ s
-{-# INLINE runFixpointM #-}
-{-# DEPRECATED runFixpointM "Use 'fixpointToFinal' instead" #-}

src/Polysemy/IO.hs

@@ -3,14 +3,11 @@
 module Polysemy.IO
   ( -- * Interpretations
     embedToMonadIO
-  , lowerEmbedded
   ) where
 
 import Control.Monad.IO.Class
 import Polysemy
 import Polysemy.Embed
-import Polysemy.Internal
-import Polysemy.Internal.Union
 
 
 ------------------------------------------------------------------------------
@@ -44,29 +41,3 @@ embedToMonadIO
 embedToMonadIO = runEmbedded $ liftIO @m
 {-# INLINE embedToMonadIO #-}
 
-
-------------------------------------------------------------------------------
--- | Given some @'MonadIO' m@, interpret all @'Embed' m@ actions in that monad
--- at once. This is useful for interpreting effects like databases, which use
--- their own monad for describing actions.
---
--- This function creates a thread, and so should be compiled with @-threaded@.
---
--- @since 1.0.0.0
-lowerEmbedded
-    :: ( MonadIO m
-       , Member (Embed IO) r
-       )
-    => (forall x. m x -> IO x)  -- ^ The means of running this monad.
-    -> Sem (Embed m ': r) a
-    -> Sem r a
-lowerEmbedded run_m (Sem m) = withLowerToIO $ \lower _ ->
-  run_m $ m $ \u ->
-    case decomp u of
-      Left x -> liftIO
-              . lower
-              . liftSem
-              $ hoist (lowerEmbedded run_m) x
-
-      Right (Weaving (Embed wd) s _ y _) ->
-        y <$> ((<$ s) <$> wd)

src/Polysemy/Internal.hs

@@ -37,8 +37,6 @@ module Polysemy.Internal
   , Append
   , InterpreterFor
   , InterpretersFor
-  , (.@)
-  , (.@@)
   ) where
 
 import Control.Applicative
@@ -654,65 +652,3 @@ type InterpreterFor e r = ∀ a. Sem (e ': r) a -> Sem r a
 -- @since 1.5.0.0
 type InterpretersFor es r = ∀ a. Sem (Append es r) a -> Sem r a
 
-
-------------------------------------------------------------------------------
--- | Some interpreters need to be able to lower down to the base monad (often
--- 'IO') in order to function properly --- some good examples of this are
--- 'Polysemy.Error.lowerError' and 'Polysemy.Resource.lowerResource'.
---
--- However, these interpreters don't compose particularly nicely; for example,
--- to run 'Polysemy.Resource.lowerResource', you must write:
---
--- @
--- runM . lowerError runM
--- @
---
--- Notice that 'runM' is duplicated in two places here. The situation gets
--- exponentially worse the more intepreters you have that need to run in this
--- pattern.
---
--- Instead, '.@' performs the composition we'd like. The above can be written as
---
--- @
--- (runM .@ lowerError)
--- @
---
--- The parentheses here are important; without them you'll run into operator
--- precedence errors.
---
--- __Warning:__ This combinator will __duplicate work__ that is intended to be
--- just for initialization. This can result in rather surprising behavior. For
--- a version of '.@' that won't duplicate work, see the @.\@!@ operator in
--- <http://hackage.haskell.org/package/polysemy-zoo/docs/Polysemy-IdempotentLowering.html polysemy-zoo>.
---
--- Interpreters using 'Polysemy.Final' may be composed normally, and
--- avoid the work duplication issue. For that reason, you're encouraged to use
--- @-'Polysemy.Final'@ interpreters instead of @lower-@ interpreters whenever
--- possible.
-(.@)
-    :: Monad m
-    => (∀ x. Sem r x -> m x)
-       -- ^ The lowering function, likely 'runM'.
-    -> (∀ y. (∀ x. Sem r x -> m x)
-          -> Sem (e ': r) y
-          -> Sem r y)
-    -> Sem (e ': r) z
-    -> m z
-f .@ g = f . g f
-infixl 8 .@
-
-
-------------------------------------------------------------------------------
--- | Like '.@', but for interpreters which change the resulting type --- eg.
--- 'Polysemy.Error.lowerError'.
-(.@@)
-    :: Monad m
-    => (∀ x. Sem r x -> m x)
-       -- ^ The lowering function, likely 'runM'.
-    -> (∀ y. (∀ x. Sem r x -> m x)
-          -> Sem (e ': r) y
-          -> Sem r (f y))
-    -> Sem (e ': r) z
-    -> m (f z)
-f .@@ g = f . g f
-infixl 8 .@@

src/Polysemy/Internal/Forklift.hs

@@ -1,87 +0,0 @@
-{-# LANGUAGE NumDecimals     #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies    #-}
-
-{-# OPTIONS_HADDOCK not-home #-}
-
-module Polysemy.Internal.Forklift where
-
-import qualified Control.Concurrent.Async as A
-import           Control.Concurrent.Chan.Unagi
-import           Control.Concurrent.MVar
-import           Control.Exception
-import           Polysemy.Internal
-import           Polysemy.Internal.Union
-
-
-------------------------------------------------------------------------------
--- | A promise for interpreting an effect of the union @r@ in another thread.
---
--- @since 0.5.0.0
-data Forklift r = forall a. Forklift
-  { responseMVar :: MVar a
-  , request      :: Union r (Sem r) a
-  }
-
-
-------------------------------------------------------------------------------
--- | A strategy for automatically interpreting an entire stack of effects by
--- just shipping them off to some other interpretation context.
---
--- @since 0.5.0.0
-runViaForklift
-    :: Member (Embed IO) r
-    => InChan (Forklift r)
-    -> Sem r a
-    -> IO a
-runViaForklift chan = usingSem $ \u -> do
-  case prj u of
-    Just (Weaving (Embed m) s _ ex _) ->
-      ex . (<$ s) <$> m
-    _ -> do
-      mvar <- newEmptyMVar
-      writeChan chan $ Forklift mvar u
-      takeMVar mvar
-{-# INLINE runViaForklift #-}
-
-
-
-------------------------------------------------------------------------------
--- | Run an effect stack all the way down to 'IO' by running it in a new
--- thread, and temporarily turning the current thread into an event poll.
---
--- This function creates a thread, and so should be compiled with @-threaded@.
---
--- @since 0.5.0.0
-withLowerToIO
-    :: Member (Embed IO) r
-    => ((forall x. Sem r x -> IO x) -> IO () -> IO a)
-       -- ^ A lambda that takes the lowering function, and a finalizing 'IO'
-       -- action to mark a the forked thread as being complete. The finalizing
-       -- action need not be called.
-    -> Sem r a
-withLowerToIO action = do
-  (inchan, outchan) <- embed newChan
-  signal <- embed newEmptyMVar
-
-  res <- embed $ A.async $ do
-    a <- action (runViaForklift inchan)
-                (putMVar signal ())
-          `finally` (putMVar signal ())
-    pure a
-
-  let me = do
-        raced <- embed $ A.race (takeMVar signal) $ readChan outchan
-        case raced of
-          Left () -> embed $ A.wait res
-          Right (Forklift mvar req) -> do
-            resp <- liftSem req
-            embed $ putMVar mvar $ resp
-            me_b
-      {-# INLINE me #-}
-
-      me_b = me
-      {-# NOINLINE me_b #-}
-
-  me
-

src/Polysemy/Resource.hs

@@ -14,8 +14,6 @@ module Polysemy.Resource
     -- * Interpretations
   , runResource
   , resourceToIOFinal
-  , resourceToIO
-  , lowerResource
   ) where
 
 import qualified Control.Exception as X
@@ -96,16 +94,6 @@ onException act end = bracketOnError (pure ()) (const end) (const act)
 -- will have local state semantics in regards to 'Resource' effects
 -- interpreted this way. See 'Final'.
 --
--- Notably, unlike 'resourceToIO', this is not consistent with
--- 'Polysemy.State.State' unless 'Polysemy.State.runStateInIORef' is used.
--- State that seems like it should be threaded globally throughout 'bracket's
--- /will not be./
---
--- Use 'resourceToIO' instead if you need to run
--- pure, stateful interpreters after the interpreter for 'Resource'.
--- (Pure interpreters are interpreters that aren't expressed in terms of
--- another effect or monad; for example, 'Polysemy.State.runState'.)
---
 -- @since 1.2.0.0
 resourceToIOFinal :: Member (Final IO) r
                   => Sem (Resource ': r) a
@@ -138,42 +126,6 @@ resourceToIOFinal = interpretFinal $ \case
 {-# INLINE resourceToIOFinal #-}
 
 
-------------------------------------------------------------------------------
--- | Run a 'Resource' effect in terms of 'X.bracket'.
---
--- @since 1.0.0.0
-lowerResource
-    :: ∀ r a
-     . Member (Embed IO) r
-    => (∀ x. Sem r x -> IO x)
-       -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely
-       -- some combination of 'runM' and other interpreters composed via '.@'.
-    -> Sem (Resource ': r) a
-    -> Sem r a
-lowerResource finish = interpretH $ \case
-  Bracket alloc dealloc use -> do
-    a <- runT  alloc
-    d <- bindT dealloc
-    u <- bindT use
-
-    let run_it :: Sem (Resource ': r) x -> IO x
-        run_it = finish .@ lowerResource
-
-    embed $ X.bracket (run_it a) (run_it . d) (run_it . u)
-
-  BracketOnError alloc dealloc use -> do
-    a <- runT  alloc
-    d <- bindT dealloc
-    u <- bindT use
-
-    let run_it :: Sem (Resource ': r) x -> IO x
-        run_it = finish .@ lowerResource
-
-    embed $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)
-{-# INLINE lowerResource #-}
-{-# DEPRECATED lowerResource "Use 'resourceToIOFinal' instead" #-}
-
-
 ------------------------------------------------------------------------------
 -- | Run a 'Resource' effect purely.
 --
@@ -212,62 +164,3 @@ runResource = interpretH $ \case
         pure result
 {-# INLINE runResource #-}
 
-
-------------------------------------------------------------------------------
--- | A more flexible --- though less safe ---  version of 'resourceToIOFinal'
---
--- This function is capable of running 'Resource' effects anywhere within an
--- effect stack, without relying on an explicit function to lower it into 'IO'.
--- Notably, this means that 'Polysemy.State.State' effects will be consistent
--- in the presence of 'Resource'.
---
--- ResourceToIO' is safe whenever you're concerned about exceptions thrown
--- by effects _already handled_ in your effect stack, or in 'IO' code run
--- directly inside of 'bracket'. It is not safe against exceptions thrown
--- explicitly at the main thread. If this is not safe enough for your use-case,
--- use 'resourceToIOFinal' instead.
---
--- This function creates a thread, and so should be compiled with @-threaded@.
---
--- @since 1.0.0.0
-resourceToIO
-    :: forall r a
-     . Member (Embed IO) r
-    => Sem (Resource ': r) a
-    -> Sem r a
-resourceToIO = interpretH $ \case
-  Bracket a b c -> do
-    ma <- runT a
-    mb <- bindT b
-    mc <- bindT c
-
-    withLowerToIO $ \lower finish -> do
-      let done :: Sem (Resource ': r) x -> IO x
-          done = lower . raise . resourceToIO
-      X.bracket
-          (done ma)
-          (\x -> done (mb x) >> finish)
-          (done . mc)
-
-  BracketOnError a b c -> do
-    ins <- getInspectorT
-    ma <- runT a
-    mb <- bindT b
-    mc <- bindT c
-
-    withLowerToIO $ \lower finish -> do
-      let done :: Sem (Resource ': r) x -> IO x
-          done = lower . raise . resourceToIO
-      X.bracketOnError
-          (done ma)
-          (\x -> done (mb x) >> finish)
-          (\x -> do
-            result <- done $ mc x
-            case inspect ins result of
-              Just _ -> pure result
-              Nothing -> do
-                _ <- done $ mb x
-                pure result
-          )
-{-# INLINE resourceToIO #-}
-

test/AsyncSpec.hs

@@ -1,47 +0,0 @@
-{-# LANGUAGE NumDecimals #-}
-
-module AsyncSpec where
-
-import Control.Concurrent.MVar
-import Control.Monad
-import Polysemy
-import Polysemy.Async
-import Polysemy.State
-import Polysemy.Trace
-import Test.Hspec
-
-
-spec :: Spec
-spec = describe "async" $ do
-  it "should thread state and not lock" $ do
-    (ts, (s, r)) <- runM
-                  . runTraceList
-                  . runState "hello"
-                  . asyncToIO $ do
-      let message :: Member Trace r => Int -> String -> Sem r ()
-          message n msg = trace $ mconcat
-            [ show n, "> ", msg ]
-      ~[lock1, lock2] <- embed $
-        replicateM 2 newEmptyMVar
-      a1 <- async $ do
-          v <- get @String
-          message 1 v
-          put $ reverse v
-
-          embed $ putMVar lock1 ()
-          embed $ takeMVar lock2
-          get >>= message 1
-
-          get @String
-
-      void $ async $ do
-          embed $ takeMVar lock1
-          get >>= message 2
-          put "pong"
-          embed $ putMVar lock2 ()
-
-      await a1 <* put "final"
-
-    ts `shouldContain` ["1> hello", "2> olleh", "1> pong"]
-    s `shouldBe` "final"
-    r `shouldBe` Just "pong"

test/BracketSpec.hs

@@ -151,16 +151,6 @@ runTest = pure
         . runResource
         . runError @()
 
-runTest2
-  :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO] a
-  -> IO ([String], ([Char], Either () a))
-runTest2 = runM
-         . ignoreOutput
-         . runTraceList
-         . runState ""
-         . resourceToIO
-         . runError @()
-
 runTest3
   :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO, Final IO] a
   -> IO ([String], ([Char], Either () a))
@@ -185,9 +175,6 @@ testAllThree name k m = do
       k z
     -- NOTE(sandy): These unsafeCoerces are safe, because we're just weakening
     -- the end of the union
-    it "via resourceToIO" $ do
-      z <- runTest2 $ unsafeCoerce m
-      k z
     it "via resourceToIOFinal" $ do
       z <- runTest3 $ unsafeCoerce m
       k z
@@ -200,9 +187,6 @@ testTheIOTwo
     -> Spec
 testTheIOTwo name k m = do
   describe name $ do
-    it "via resourceToIO" $ do
-      z <- runTest2 m
-      k z
     -- NOTE(sandy): This unsafeCoerces are safe, because we're just weakening
     -- the end of the union
     it "via resourceToIOFinal" $ do

test/ErrorSpec.hs

@@ -28,7 +28,7 @@ spec = parallel $ do
 
     it "should happen before Resource" $ do
       a <-
-        runM $ resourceToIO $ runError @MyExc $ do
+        runFinal $ embedToFinal @IO $ resourceToIOFinal $ runError @MyExc $ do
           onException
             (fromException @MyExc $ do
               _ <- X.throwIO $ MyExc "hello"

test/InspectorSpec.hs

@@ -1,77 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module InspectorSpec where
-
-import Control.Monad
-import Data.IORef
-import Polysemy
-import Polysemy.Error
-import Polysemy.State
-import Test.Hspec
-
-
-
-data Callback m a where
-  Callback :: m String -> Callback m ()
-
-makeSem ''Callback
-
-
-
-spec :: Spec
-spec = parallel $ describe "Inspector" $ do
-  it "should inspect State effects" $ do
-    withNewTTY $ \ref -> do
-      void . (runM .@ runCallback ref)
-           . runState False
-           $ do
-        embed $ pretendPrint ref "hello world"
-        callback $ show <$> get @Bool
-        modify not
-        callback $ show <$> get @Bool
-
-      result <- readIORef ref
-      result `shouldContain` ["hello world"]
-      result `shouldContain` ["False", "True"]
-
-  it "should not inspect thrown Error effects" $ do
-    withNewTTY $ \ref -> do
-      void . (runM .@ runCallback ref)
-           . runError @()
-           $ do
-        callback $ throw ()
-        callback $ pure "nice"
-
-      result <- readIORef ref
-      result `shouldContain` [":(", "nice"]
-
-
-runCallback
-    :: Member (Embed IO) r
-    => IORef [String]
-    -> (forall x. Sem r x -> IO x)
-    -> Sem (Callback ': r) a
-    -> Sem r a
-runCallback ref lower = interpretH $ \case
-  Callback cb -> do
-    cb' <- runT cb
-    ins <- getInspectorT
-    embed $ doCB ref $ do
-      v <- lower .@ runCallback ref $ cb'
-      pure $ maybe ":(" id $ inspect ins v
-    getInitialStateT
-
-
-doCB :: IORef [String] -> IO String -> IO ()
-doCB ref m = m >>= pretendPrint ref
-
-
-pretendPrint :: IORef [String] -> String -> IO ()
-pretendPrint ref msg = modifyIORef ref (++ [msg])
-
-
-withNewTTY :: (IORef [String] -> IO a) -> IO a
-withNewTTY f = do
-  ref <- newIORef []
-  f ref
-

test/TypeErrors.hs

@@ -45,18 +45,3 @@ interpretBadFirstOrder = ()
 -- ...
 tooFewArgumentsReinterpret = ()
 
-
---------------------------------------------------------------------------------
--- |
--- >>> :{
--- let foo :: Member Resource r => Sem r ()
---     foo = undefined
---  in runM $ lowerResource foo
--- :}
--- ...
--- ... Couldn't match expected type...
--- ... with actual type...
--- ... Probable cause: ... is applied to too few arguments
--- ...
-missingArgumentToRunResourceInIO = ()
-