From c127af48c108b66ca4d56883ae35fde6baeec49e Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Fri, 18 Dec 2020 19:06:06 +0100
Subject: [PATCH 01/21] Core rewrite; new interpretH family

---
 polysemy.cabal                       |   3 +
 src/Polysemy.hs                      |  16 ++
 src/Polysemy/Bundle.hs               |  15 +-
 src/Polysemy/Error.hs                |  41 ++--
 src/Polysemy/Final.hs                |  25 +--
 src/Polysemy/IO.hs                   |   4 +-
 src/Polysemy/Internal.hs             |  39 +++-
 src/Polysemy/Internal/Combinators.hs | 275 ++++++++++++++++++++++-----
 src/Polysemy/Internal/Forklift.hs    |   4 +-
 src/Polysemy/Internal/Tactics.hs     |  31 +--
 src/Polysemy/Internal/Union.hs       |  90 ++++-----
 src/Polysemy/Internal/WeaveClass.hs  | 159 ++++++++++++++++
 src/Polysemy/Internal/Writer.hs      |  20 +-
 src/Polysemy/NonDet.hs               |  43 +++--
 src/Polysemy/Output.hs               |   5 +-
 src/Polysemy/State.hs                |  13 +-
 src/Polysemy/Tagged.hs               |  16 +-
 src/Polysemy/Writer.hs               |  10 +-
 18 files changed, 602 insertions(+), 207 deletions(-)
 create mode 100644 src/Polysemy/Internal/WeaveClass.hs

diff --git a/polysemy.cabal b/polysemy.cabal
index f36f4aca..7ae2545b 100644
--- a/polysemy.cabal
+++ b/polysemy.cabal
@@ -3,6 +3,8 @@ cabal-version: 2.0
 -- This file has been generated from package.yaml by hpack version 0.34.4.
 --
 -- see: https://github.com/sol/hpack
+--
+-- hash: 754ab355722062c11ee014b832c3c95ddeea81fec4242a5938436c0ca64383c8
 
 name:           polysemy
 version:        1.6.0.0
@@ -71,6 +73,7 @@ library
       Polysemy.Internal.TH.Common
       Polysemy.Internal.TH.Effect
       Polysemy.Internal.Union
+      Polysemy.Internal.WeaveClass
       Polysemy.Internal.Writer
       Polysemy.IO
       Polysemy.Law
diff --git a/src/Polysemy.hs b/src/Polysemy.hs
index 6d5d3cab..0a1df354 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -109,6 +109,13 @@ module Polysemy
   , transform
 
     -- * Combinators for Interpreting Higher-Order Effects
+  , interpretNew
+  , interceptNew
+  , reinterpretNew
+  , reinterpret2New
+  , reinterpret3New
+
+    -- * Combinators for Interpreting Higher-Order Effects using the 'Tactical' enviroment
   , interpretH
   , interceptH
   , reinterpretH
@@ -126,6 +133,14 @@ module Polysemy
   , (.@)
   , (.@@)
 
+    -- * 'RunH'
+    -- | When interpreting higher-order effects using 'interpretNew'
+    -- and friends, you can't execute higher-order "thunks" given my
+    -- the interpreted effect directly. Instead, these must be executed
+    -- using 'runH'.
+  , RunH
+  , runH
+
     -- * Tactics
     -- | Higher-order effects need to explicitly thread /other effects'/ state
     -- through themselves. Tactics are a domain-specific language for describing
@@ -145,6 +160,7 @@ module Polysemy
   , bindT
   , getInspectorT
   , Inspector (..)
+
   ) where
 
 import Polysemy.Final
diff --git a/src/Polysemy/Bundle.hs b/src/Polysemy/Bundle.hs
index a419b69a..c431a1c8 100644
--- a/src/Polysemy/Bundle.hs
+++ b/src/Polysemy/Bundle.hs
@@ -43,9 +43,12 @@ sendBundle
   => Sem (e ': r) a
   -> Sem r a
 sendBundle = hoistSem $ \u -> case decomp u of
-  Right (Weaving e s wv ex ins) ->
+  Right (Weaving e mkT lwr ex) ->
     injWeaving $
-      Weaving (Bundle (membership @e @r') e) s (sendBundle @e @r' . wv) ex ins
+      Weaving (Bundle (membership @e @r') e)
+              (\n -> mkT (n . sendBundle @e @r'))
+              lwr
+              ex
   Left g -> hoist (sendBundle @e @r') g
 {-# INLINE sendBundle #-}
 
@@ -57,8 +60,8 @@ runBundle
   => Sem (Bundle r' ': r) a
   -> Sem (Append r' r) a
 runBundle = hoistSem $ \u -> hoist runBundle $ case decomp u of
-  Right (Weaving (Bundle pr e) s wv ex ins) ->
-    Union (extendMembershipRight @r' @r pr) $ Weaving e s wv ex ins
+  Right (Weaving (Bundle pr e) mkT lwr ex) ->
+    Union (extendMembershipRight @r' @r pr) $ Weaving e mkT lwr ex
   Left g -> weakenList @r' @r (singList @r') g
 {-# INLINE runBundle #-}
 
@@ -70,7 +73,7 @@ subsumeBundle
   => Sem (Bundle r' ': r) a
   -> Sem r a
 subsumeBundle = hoistSem $ \u -> hoist subsumeBundle $ case decomp u of
-  Right (Weaving (Bundle pr e) s wv ex ins) ->
-    Union (subsumeMembership pr) (Weaving e s wv ex ins)
+  Right (Weaving (Bundle pr e) mkT lwr ex) ->
+    Union (subsumeMembership pr) (Weaving e mkT lwr ex)
   Left g -> g
 {-# INLINE subsumeBundle #-}
diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs
index de27c5e2..2cbc6ae1 100644
--- a/src/Polysemy/Error.hs
+++ b/src/Polysemy/Error.hs
@@ -43,12 +43,6 @@ data Error e m a where
 
 makeSem ''Error
 
-
-hush :: Either e a -> Maybe a
-hush (Right a) = Just a
-hush (Left _) = Nothing
-
-
 ------------------------------------------------------------------------------
 -- | Upgrade an 'Either' into an 'Error' effect.
 --
@@ -152,16 +146,16 @@ note _ (Just a) = pure a
 {-# INLINABLE note #-}
 
 ------------------------------------------------------------------------------
--- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@) 
--- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type 
--- @e@ was @'throw'@n and its value is @ex@. 
+-- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@)
+-- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type
+-- @e@ was @'throw'@n and its value is @ex@.
 try :: Member (Error e) r => Sem r a -> Sem r (Either e a)
 try m = catch (Right <$> m) (return . Left)
 {-# INLINABLE try #-}
 
 ------------------------------------------------------------------------------
 -- | A variant of @'try'@ that takes an exception predicate to select which exceptions
--- are caught (c.f. @'catchJust'@). If the exception does not match the predicate, 
+-- are caught (c.f. @'catchJust'@). If the exception does not match the predicate,
 -- it is re-@'throw'@n.
 tryJust :: Member (Error e) r => (e -> Maybe b) -> Sem r a -> Sem r (Either b a)
 tryJust f m = do
@@ -174,10 +168,10 @@ tryJust f m = do
 {-# INLINABLE tryJust #-}
 
 ------------------------------------------------------------------------------
--- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument 
--- which is an exception predicate, a function which selects which type of exceptions 
+-- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument
+-- which is an exception predicate, a function which selects which type of exceptions
 -- we're interested in.
-catchJust :: Member (Error e) r 
+catchJust :: Member (Error e) r
           => (e -> Maybe b) -- ^ Predicate to select exceptions
           -> Sem r a  -- ^ Computation to run
           -> (b -> Sem r a) -- ^ Handler
@@ -197,22 +191,19 @@ runError
     -> Sem r (Either e a)
 runError (Sem m) = Sem $ \k -> E.runExceptT $ m $ \u ->
   case decomp u of
-    Left x -> E.ExceptT $ k $
-      weave (Right ())
-            (either (pure . Left) runError)
-            hush
-            x
-    Right (Weaving (Throw e) _ _ _ _) -> E.throwE e
-    Right (Weaving (Catch main handle) s d y _) ->
+    Left x ->
+      liftHandlerWithNat (E.ExceptT . runError) k x
+    Right (Weaving (Throw e) _ _ _) -> E.throwE e
+    Right (Weaving (Catch main handle) mkT lwr ex) ->
       E.ExceptT $ usingSem k $ do
-        ma <- runError $ d $ main <$ s
-        case ma of
-          Right a -> pure . Right $ y a
+        ea <- runError $ lwr $ mkT id main
+        case ea of
+          Right a -> pure . Right $ ex a
           Left e -> do
-            ma' <- runError $ d $ (<$ s) $ handle e
+            ma' <- runError $ lwr $ mkT id $ handle e
             case ma' of
               Left e' -> pure $ Left e'
-              Right a -> pure . Right $ y a
+              Right a -> pure . Right $ ex a
 {-# INLINE runError #-}
 
 ------------------------------------------------------------------------------
diff --git a/src/Polysemy/Final.hs b/src/Polysemy/Final.hs
index c393701f..af60580a 100644
--- a/src/Polysemy/Final.hs
+++ b/src/Polysemy/Final.hs
@@ -68,7 +68,7 @@ import Polysemy.Internal.TH.Effect
 -- @since 1.2.0.0
 type ThroughWeavingToFinal m z a =
      forall f
-   . Functor f
+   . Traversable f
   => f ()
   -> (forall x. f (z x) -> m (f x))
   -> (forall x. f x -> Maybe x)
@@ -186,18 +186,17 @@ interpretFinal
        -- ^ A natural transformation from the handled effect to the final monad.
     -> Sem (e ': r) a
     -> Sem r a
-interpretFinal n =
+interpretFinal h =
   let
     go :: Sem (e ': r) x -> Sem r x
     go = hoistSem $ \u -> case decomp u of
-      Right (Weaving e s wv ex ins) ->
+      Right (Weaving e mkT lwr ex) ->
         injWeaving $
           Weaving
-            (WithWeavingToFinal (runStrategy (n e)))
-            s
-            (go . wv)
+            (WithWeavingToFinal (runStrategy (h e)))
+            (\n -> mkT (n . go))
+            lwr
             ex
-            ins
       Left g -> hoist go g
     {-# INLINE go #-}
   in
@@ -214,7 +213,10 @@ interpretFinal n =
 -- @since 1.2.0.0
 runFinal :: Monad m => Sem '[Final m] a -> m a
 runFinal = usingSem $ \u -> case extract u of
-  Weaving (WithWeavingToFinal wav) s wv ex ins ->
+  Weaving (WithWeavingToFinal wav) mkT lwr ex -> do
+    let s = mkInitState lwr
+        Distrib wv = mkDistrib mkT lwr
+        ins = mkInspector
     ex <$> wav s (runFinal . wv) ins
 {-# INLINE runFinal #-}
 
@@ -233,16 +235,15 @@ finalToFinal to from =
   let
     go :: Sem (Final m1 ': r) x -> Sem r x
     go = hoistSem $ \u -> case decomp u of
-      Right (Weaving (WithWeavingToFinal wav) s wv ex ins) ->
+      Right (Weaving (WithWeavingToFinal wav) mkT lwr ex) ->
         injWeaving $
           Weaving
             (WithWeavingToFinal $ \s' wv' ins' ->
               to $ wav s' (from . wv') ins'
             )
-            s
-            (go . wv)
+            (\n -> mkT (n . go))
+            lwr
             ex
-            ins
       Left g -> hoist go g
     {-# INLINE go #-}
   in
diff --git a/src/Polysemy/IO.hs b/src/Polysemy/IO.hs
index da6200a6..bac7486c 100644
--- a/src/Polysemy/IO.hs
+++ b/src/Polysemy/IO.hs
@@ -68,5 +68,5 @@ lowerEmbedded run_m (Sem m) = withLowerToIO $ \lower _ ->
               . liftSem
               $ hoist (lowerEmbedded run_m) x
 
-      Right (Weaving (Embed wd) s _ y _) ->
-        y <$> ((<$ s) <$> wd)
+      Right (Weaving (Embed wd) _ lwr ex) ->
+        ex <$> ((<$ mkInitState lwr) <$> wd)
diff --git a/src/Polysemy/Internal.hs b/src/Polysemy/Internal.hs
index de0f08c3..6066f2e5 100644
--- a/src/Polysemy/Internal.hs
+++ b/src/Polysemy/Internal.hs
@@ -31,6 +31,8 @@ module Polysemy.Internal
   , subsume
   , subsumeUsing
   , insertAt
+  , expose
+  , exposeUsing
   , Embed (..)
   , usingSem
   , liftSem
@@ -53,6 +55,7 @@ import Control.Monad.Fix
 import Control.Monad.IO.Class
 import Data.Functor.Identity
 import Data.Kind
+import Data.Type.Equality
 import Polysemy.Embed.Type
 import Polysemy.Fail.Type
 import Polysemy.Internal.Fixpoint
@@ -545,6 +548,22 @@ subsumeUsing pr =
   in
     go
 {-# INLINE subsumeUsing #-}
+------------------------------------------------------------------------------
+-- | Moves all uses of an effect @e@ within the argument computation
+-- to a new @e@ placed on top of the effect stack. Note that this does not
+-- consume the inner @e@.
+--
+-- This can be used to create interceptors out of interpreters.
+-- For example:
+--
+-- @
+-- 'Polysemy.intercept' k = 'Polysemy.interpret' k . 'expose'
+-- @
+--
+-- @since TODO
+expose :: Member e r => Sem r a -> Sem (e ': r) a
+expose = exposeUsing membership
+{-# INLINE expose #-}
 
 ------------------------------------------------------------------------------
 -- | Introduce a set of effects into 'Sem' at the index @i@, before the effect
@@ -572,6 +591,21 @@ insertAt = hoistSem $ \u -> hoist (insertAt @index @inserted @head @oldTail) $
   weakenMid @oldTail (listOfLength @index @head) (insertAtIndex @Effect @index @head @tail @oldTail @full @inserted) u
 {-# INLINE insertAt #-}
 
+-- | Given an explicit proof that @e@ exists in @r@, moves all uses of e@
+-- within the argument computation to a new @e@ placed on top of the effect
+-- stack. Note that this does not consume the inner @e@.
+--
+-- This is useful in conjunction with 'Polysemy.Internal.Union.tryMembership'
+-- and 'interpret'\/'interpretH' in order to conditionally perform
+-- 'intercept'-like operations.
+--
+-- @since TODO
+exposeUsing :: forall e r a. ElemOf e r -> Sem r a -> Sem (e ': r) a
+exposeUsing pr = hoistSem $ \(Union pr' wav) -> hoist (exposeUsing pr) $
+  case sameMember pr pr' of
+    Just Refl -> Union Here wav
+    _         -> Union (There pr') wav
+{-# INLINE exposeUsing #-}
 
 ------------------------------------------------------------------------------
 -- | Embed an effect into a 'Sem'. This is used primarily via
@@ -614,9 +648,10 @@ run (Sem m) = runIdentity $ m absurdU
 runM :: Monad m => Sem '[Embed m] a -> m a
 runM (Sem m) = m $ \z ->
   case extract z of
-    Weaving e s _ f _ -> do
+    Weaving e _ lwr ex -> do
+      let s = mkInitState lwr
       a <- unEmbed e
-      pure $ f $ a <$ s
+      pure $ ex $ a <$ s
 {-# INLINE runM #-}
 
 
diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs
index b67751c8..e4d072b1 100644
--- a/src/Polysemy/Internal/Combinators.hs
+++ b/src/Polysemy/Internal/Combinators.hs
@@ -13,6 +13,16 @@ module Polysemy.Internal.Combinators
   , transform
 
     -- * Higher order
+  , RunH(..)
+  , runH
+
+  , interpretNew
+  , interceptNew
+  , reinterpretNew
+  , reinterpret2New
+  , reinterpret3New
+
+    -- * Higher order with 'Tactical'
   , interpretH
   , interceptH
   , reinterpretH
@@ -22,6 +32,7 @@ module Polysemy.Internal.Combinators
   -- * Conditional
   , interceptUsing
   , interceptUsingH
+  , interceptUsingNew
 
     -- * Statefulness
   , stateful
@@ -73,6 +84,10 @@ interpret = firstOrder interpretH
 -- | Like 'interpret', but for higher-order effects (ie. those which make use of
 -- the @m@ parameter.)
 --
+-- 'interpretNew' is /heavily recommended/ over this. Only use 'interpretH'
+-- if you need the additional power of the 'Tactical' environment -- that is,
+-- the ability to inspect and manipulate the underlying effectful state.
+--
 -- See the notes on 'Tactical' for how to use this function.
 interpretH
     :: (∀ rInitial x . e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
@@ -83,8 +98,10 @@ interpretH
 interpretH f (Sem m) = Sem $ \k -> m $ \u ->
   case decomp u of
     Left  x -> k $ hoist (interpretH f) x
-    Right (Weaving e s d y v) -> do
-      fmap y $ usingSem k $ runTactics s d v (interpretH f . d) $ f e
+    Right (Weaving e mkT lwr ex) -> do
+      let s = mkInitState lwr
+          Distrib d = mkDistrib mkT lwr
+      fmap ex $ usingSem k $ runTactics s d (interpretH f . d) $ f e
 {-# INLINE interpretH #-}
 
 ------------------------------------------------------------------------------
@@ -95,18 +112,16 @@ interpretInStateT
     -> s
     -> Sem (e ': r) a
     -> Sem r (s, a)
-interpretInStateT f s (Sem m) = Sem $ \k ->
-  (S.swap <$!>) $ flip S.runStateT s $ m $ \u ->
+interpretInStateT f s (Sem sem) = Sem $ \k ->
+  (S.swap <$!>) $ flip S.runStateT s $ sem $ \u ->
     case decomp u of
-        Left x -> S.StateT $ \s' ->
-              (S.swap <$!>)
-            . k
-            . weave (s', ())
-                    (uncurry $ interpretInStateT f)
-                    (Just . snd)
-            $ x
-        Right (Weaving e z _ y _) ->
-          y . (<$ z) <$> S.mapStateT (usingSem k) (f e)
+        Left x ->
+          liftHandlerWithNat
+            (\m -> S.StateT $ \s' -> swap <$!> interpretInStateT f s' m)
+            k x
+        Right (Weaving e _ lwr ex) -> do
+          let z = mkInitState lwr
+          ex . (<$ z) <$> S.mapStateT (usingSem k) (f e)
 {-# INLINE interpretInStateT #-}
 
 
@@ -118,17 +133,16 @@ interpretInLazyStateT
     -> s
     -> Sem (e ': r) a
     -> Sem r (s, a)
-interpretInLazyStateT f s (Sem m) = Sem $ \k ->
-  fmap swap $ flip LS.runStateT s $ m $ \u ->
+interpretInLazyStateT f s (Sem sem) = Sem $ \k ->
+  fmap swap $ flip LS.runStateT s $ sem $ \u ->
     case decomp u of
-        Left x -> LS.StateT $ \s' ->
-          k . fmap swap
-            . weave (s', ())
-                    (uncurry $ interpretInLazyStateT f)
-                    (Just . snd)
-            $ x
-        Right (Weaving e z _ y _) ->
-          y . (<$ z) <$> LS.mapStateT (usingSem k) (f e)
+        Left x ->
+          liftHandlerWithNat
+            (\m -> LS.StateT $ \s' -> swap <$> interpretInLazyStateT f s' m)
+            k x
+        Right (Weaving e _ lwr ex) -> do
+          let z = mkInitState lwr
+          ex . (<$ z) <$> LS.mapStateT (usingSem k) (f e)
 {-# INLINE interpretInLazyStateT #-}
 
 
@@ -157,6 +171,10 @@ lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap swap . f e
 ------------------------------------------------------------------------------
 -- | Like 'reinterpret', but for higher-order effects.
 --
+-- 'reinterpretNew' is /heavily recommended/ over this. Only use 'reinterpretH'
+-- if you need the additional power of the 'Tactical' environment -- that is,
+-- the ability to inspect and manipulate the underlying effectful state.
+--
 -- See the notes on 'Tactical' for how to use this function.
 reinterpretH
     :: forall e1 e2 r a
@@ -168,10 +186,12 @@ reinterpretH
 reinterpretH f sem = Sem $ \k -> runSem sem $ \u ->
   case decompCoerce u of
     Left x  -> k $ hoist (reinterpretH f) $ x
-    Right (Weaving e s d y v) -> do
-      fmap y $ usingSem k
-             $ runTactics s (raiseUnder . d) v (reinterpretH f . d)
-             $ f e
+    Right (Weaving e mkT lwr ex) -> do
+      let s = mkInitState lwr
+          Distrib d = mkDistrib mkT lwr
+      fmap ex $ usingSem k
+              $ runTactics s (raiseUnder . d) (reinterpretH f . d)
+              $ f e
 {-# INLINE[3] reinterpretH #-}
 -- TODO(sandy): Make this fuse in with 'stateful' directly.
 
@@ -196,6 +216,10 @@ reinterpret = firstOrder reinterpretH
 ------------------------------------------------------------------------------
 -- | Like 'reinterpret2', but for higher-order effects.
 --
+-- 'reinterpret2New' is /heavily recommended/ over this. Only use 'reinterpret2H'
+-- if you need the additional power of the 'Tactical' environment -- that is,
+-- the ability to inspect and manipulate the underlying effectful state.
+--
 -- See the notes on 'Tactical' for how to use this function.
 reinterpret2H
     :: forall e1 e2 e3 r a
@@ -207,10 +231,12 @@ reinterpret2H
 reinterpret2H f (Sem m) = Sem $ \k -> m $ \u ->
   case decompCoerce u of
     Left x  -> k $ weaken $ hoist (reinterpret2H f) $ x
-    Right (Weaving e s d y v) -> do
-      fmap y $ usingSem k
-             $ runTactics s (raiseUnder2 . d) v (reinterpret2H f . d)
-             $ f e
+    Right (Weaving e mkT lwr ex) -> do
+      let s = mkInitState lwr
+          Distrib d = mkDistrib mkT lwr
+      fmap ex $ usingSem k
+              $ runTactics s (raiseUnder2 . d) (reinterpret2H f . d)
+              $ f e
 {-# INLINE[3] reinterpret2H #-}
 
 
@@ -231,6 +257,10 @@ reinterpret2 = firstOrder reinterpret2H
 ------------------------------------------------------------------------------
 -- | Like 'reinterpret3', but for higher-order effects.
 --
+-- 'reinterpret3New' is /heavily recommended/ over this. Only use 'reinterpret3H'
+-- if you need the additional power of the 'Tactical' environment -- that is,
+-- the ability to inspect and manipulate the underlying effectful state.
+--
 -- See the notes on 'Tactical' for how to use this function.
 reinterpret3H
     :: forall e1 e2 e3 e4 r a
@@ -242,10 +272,12 @@ reinterpret3H
 reinterpret3H f (Sem m) = Sem $ \k -> m $ \u ->
   case decompCoerce u of
     Left x  -> k . weaken . weaken . hoist (reinterpret3H f) $ x
-    Right (Weaving e s d y v) ->
-      fmap y $ usingSem k
-             $ runTactics s (raiseUnder3 . d) v (reinterpret3H f . d)
-             $ f e
+    Right (Weaving e mkT lwr ex) -> do
+      let s = mkInitState lwr
+          Distrib d = mkDistrib mkT lwr
+      fmap ex $ usingSem k
+              $ runTactics s (raiseUnder3 . d) (reinterpret3H f . d)
+              $ f e
 {-# INLINE[3] reinterpret3H #-}
 
 
@@ -284,6 +316,10 @@ intercept f = interceptH $ \(e :: e (Sem rInitial) x) ->
 ------------------------------------------------------------------------------
 -- | Like 'intercept', but for higher-order effects.
 --
+-- 'interceptNew' is /heavily recommended/ over this. Only use 'interceptH'
+-- if you need the additional power of the 'Tactical' environment -- that is,
+-- the ability to inspect and manipulate the underlying effectful state.
+--
 -- See the notes on 'Tactical' for how to use this function.
 interceptH
     :: Member e r
@@ -327,6 +363,11 @@ interceptUsing pr f = interceptUsingH pr $ \(e :: e (Sem rInitial) x) ->
 -- This is useful in conjunction with 'Polysemy.Membership.tryMembership'
 -- in order to conditionally perform 'interceptH'.
 --
+-- 'interceptUsingNew' is /heavily recommended/ over this. Only use
+-- 'interceptUsingH' if you need the additional power of the 'Tactical'
+-- environment -- that is, the ability to inspect and manipulate the underlying
+-- effectful state.
+--
 -- See the notes on 'Tactical' for how to use this function.
 --
 -- @since 1.3.0.0
@@ -343,10 +384,12 @@ interceptUsingH
     -> Sem r a
 interceptUsingH pr f (Sem m) = Sem $ \k -> m $ \u ->
   case prjUsing pr u of
-    Just (Weaving e s d y v) ->
-      fmap y $ usingSem k
-             $ runTactics s (raise . d) v (interceptUsingH pr f . d)
-             $ f e
+    Just (Weaving e mkT lwr ex) -> do
+      let s = mkInitState lwr
+          Distrib d = mkDistrib mkT lwr
+      fmap ex $ usingSem k
+              $ runTactics s (raise . d) (interceptUsingH pr f . d)
+              $ f e
     Nothing -> k $ hoist (interceptUsingH pr f) u
 {-# INLINE interceptUsingH #-}
 
@@ -363,8 +406,8 @@ rewrite
 rewrite f (Sem m) = Sem $ \k -> m $ \u ->
   k $ hoist (rewrite f) $ case decompCoerce u of
     Left x -> x
-    Right (Weaving e s d n y) ->
-      Union Here $ Weaving (f e) s d n y
+    Right (Weaving e mkT lwr ex) ->
+      Union Here $ Weaving (f e) mkT lwr ex
 
 
 ------------------------------------------------------------------------------
@@ -381,5 +424,151 @@ transform
 transform f (Sem m) = Sem $ \k -> m $ \u ->
   k $ hoist (transform f) $ case decomp u of
     Left g -> g
-    Right (Weaving e s wv ex ins) ->
-      injWeaving (Weaving (f e) s wv ex ins)
+    Right (Weaving e mkT lwr ex) ->
+      injWeaving (Weaving (f e) mkT lwr ex)
+
+
+-- | An effect for running monadic actions within a higher-order effect
+-- currently being interpreted.
+newtype RunH z (m :: * -> *) a where
+  RunH :: z a -> RunH z m a
+
+-- | Run a monadic action given by a higher-order effect that is currently
+-- being interpreted.
+--
+-- @since TODO
+runH :: Member (RunH z) r => z a -> Sem r a
+runH = send . RunH
+
+------------------------------------------------------------------------------
+-- | Like 'interpret', but for higher-order effects (i.e. those which make use
+-- of the @m@ parameter.)
+--
+-- This is significantly easier to use than 'interpretH' and its corresponding
+-- 'Tactical' environment.
+-- Because of this, 'interpretNew' and friends are /heavily recommended/ over
+-- 'interpretH' and friends /unless/ you need the extra power that the 'Tactical'
+-- environment provides -- the ability to inspect and manipulate the underlying
+-- effectful state.
+--
+-- Higher-order thunks within the effect to be interpreted can be run using
+-- 'runH'. For example:
+--
+-- @
+-- data Bind m a where
+--   Bind :: m a -> (a -> m b) -> Bind m b
+--
+-- runBind :: Sem (Bind ': r) a -> Sem r a
+-- runBind = 'interpretNew' \\case
+--   Bind ma f -> do
+--     a <- 'runH' ma
+--     b <- 'runH' (f a)
+--     return b
+-- @
+--
+-- @since TODO
+interpretNew :: forall e r a
+              . (forall z x. e z x -> Sem (RunH z ': r) x)
+             -> Sem (e ': r) a
+             -> Sem r a
+interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
+  sem $ \u -> case decomp (hoist (interpretNew h) u) of
+    Left g -> k g
+    Right (Weaving e
+                 (mkT :: forall n x
+                       . Monad n
+                      => (forall y. Sem r y -> n y)
+                      -> z x -> t n x
+                 )
+                 lwr
+                 ex
+          ) ->
+      let
+          go1 :: forall x. Sem (RunH z ': r) x -> t m x
+          go1 = usingSem $ \u' -> case decomp u' of
+            Right (Weaving (RunH z) _ lwr' ex') ->
+              (ex' . (<$ mkInitState lwr')) <$> mkT (usingSem k) z
+            Left g -> liftHandlerWithNat go2 k g
+
+          go2 :: forall x. Sem (RunH z ': r) x -> t (Sem r) x
+          go2 = usingSem $ \u' -> case decomp (hoist go2 u') of
+            Right (Weaving (RunH z) _ lwr' ex') ->
+              (ex' . (<$ mkInitState lwr')) <$> mkT id z
+            Left g -> liftHandler liftSem g
+        in
+          fmap ex $ lwr $ go1 (h e)
+
+-- TODO (KingoftheHomeless): If performance matter, optimize the definitions
+-- below
+
+------------------------------------------------------------------------------
+-- | Like 'reinterpret', but for higher-order effects.
+--
+-- This is /heavily recommended/ over 'reinterpretH' unless you need
+-- the extra power that the 'Tactical' environment provides.
+--
+-- @since TODO
+reinterpretNew :: forall e1 e2 r a
+                . (forall z x. e1 z x -> Sem (RunH z ': e2 ': r) x)
+               -> Sem (e1 ': r) a
+               -> Sem (e2 ': r) a
+reinterpretNew h = interpretNew h . raiseUnder
+{-# INLINE reinterpretNew #-}
+
+------------------------------------------------------------------------------
+-- | Like 'reinterpret2', but for higher-order effects.
+--
+-- This is /heavily recommended/ over 'reinterpret2H' unless you need
+-- the extra power that the 'Tactical' environment provides.
+--
+-- @since TODO
+reinterpret2New :: forall e1 e2 e3 r a
+                 . (forall z x. e1 z x -> Sem (RunH z ': e2 ': e3 ': r) x)
+                -> Sem (e1 ': r) a
+                -> Sem (e2 ': e3 ': r) a
+reinterpret2New h = interpretNew h . raiseUnder2
+{-# INLINE reinterpret2New #-}
+
+------------------------------------------------------------------------------
+-- | Like 'reinterpret3', but for higher-order effects.
+--
+-- This is /heavily recommended/ over 'reinterpret3H' unless you need
+-- the extra power that the 'Tactical' environment provides.
+--
+-- @since TODO
+reinterpret3New :: forall e1 e2 e3 e4 r a
+                 . (forall z x. e1 z x -> Sem (RunH z ': e2 ': e3 ': e4 ': r) x)
+                -> Sem (e1 ': r) a
+                -> Sem (e2 ': e3 ': e4 ': r) a
+reinterpret3New h = interpretNew h . raiseUnder3 
+{-# INLINE reinterpret3New #-}
+
+------------------------------------------------------------------------------
+-- | Like 'intercept', but for higher-order effects.
+--
+-- This is /heavily recommended/ over 'interceptH' unless you need
+-- the extra power that the 'Tactical' environment provides.
+--
+-- @since TODO
+interceptNew :: forall e r a
+              . Member e r
+             => (forall z x. e z x -> Sem (RunH z ': r) x)
+             -> Sem r a
+             -> Sem r a
+interceptNew h = interpretNew h . expose
+{-# INLINE interceptNew #-}
+
+------------------------------------------------------------------------------
+-- | Like 'interceptUsing', but for higher-order effects.
+--
+-- This is /heavily recommended/ over 'interceptUsingH' unless you need
+-- the extra power that the 'Tactical' environment provides.
+--
+-- @since TODO
+interceptUsingNew :: forall e r a
+                   . ElemOf e r
+                  -> (forall z x. e z x -> Sem (RunH z ': r) x)
+                  -> Sem r a
+                  -> Sem r a
+interceptUsingNew pr h = interpretNew h . exposeUsing pr
+{-# INLINE interceptUsingNew #-}
diff --git a/src/Polysemy/Internal/Forklift.hs b/src/Polysemy/Internal/Forklift.hs
index 51c943ad..52bc15c0 100644
--- a/src/Polysemy/Internal/Forklift.hs
+++ b/src/Polysemy/Internal/Forklift.hs
@@ -36,8 +36,8 @@ runViaForklift
     -> IO a
 runViaForklift chan = usingSem $ \u -> do
   case prj u of
-    Just (Weaving (Embed m) s _ ex _) ->
-      ex . (<$ s) <$> m
+    Just (Weaving (Embed m) _ lwr ex) ->
+      ex . (<$ mkInitState lwr) <$> m
     _ -> do
       mvar <- newEmptyMVar
       writeChan chan $ Forklift mvar u
diff --git a/src/Polysemy/Internal/Tactics.hs b/src/Polysemy/Internal/Tactics.hs
index 5c46cddb..eee397a6 100644
--- a/src/Polysemy/Internal/Tactics.hs
+++ b/src/Polysemy/Internal/Tactics.hs
@@ -73,7 +73,7 @@ import Polysemy.Internal.Union
 --
 -- Power users may explicitly use 'getInitialStateT' and 'bindT' to construct
 -- whatever data flow they'd like; although this is usually unnecessary.
-type Tactical e m r x = ∀ f. Functor f
+type Tactical e m r x = ∀ f. Traversable f
                           => Sem (WithTactics e f m r) (f x)
 
 type WithTactics e f m r = Tactics f m (e ': r) ': r
@@ -216,7 +216,7 @@ bindTSimple f s = send @(Tactics _ _ (e ': r)) $ HoistInterpretationH f s
 -- higher-order ones.
 liftT
     :: forall m f r e a
-     . Functor f
+     . Traversable f
     => Sem r a
     -> Sem (WithTactics e f m r) (f a)
 liftT m = do
@@ -228,23 +228,24 @@ liftT m = do
 ------------------------------------------------------------------------------
 -- | Run the 'Tactics' effect.
 runTactics
-   :: Functor f
+   :: Traversable f
    => f ()
    -> (∀ x. f (m x) -> Sem r2 (f x))
-   -> (∀ x. f x -> Maybe x)
    -> (∀ x. f (m x) -> Sem r (f x))
    -> Sem (Tactics f m r2 ': r) a
    -> Sem r a
-runTactics s d v d' (Sem m) = Sem $ \k -> m $ \u ->
+runTactics s d d' (Sem m) = Sem $ \k -> m $ \u ->
   case decomp u of
-    Left x -> k $ hoist (runTactics s d v d') x
-    Right (Weaving GetInitialState s' _ y _) ->
-      pure $ y $ s <$ s'
-    Right (Weaving (HoistInterpretation na) s' _ y _) -> do
-      pure $ y $ (d . fmap na) <$ s'
-    Right (Weaving (HoistInterpretationH na fa) s' _ y _) -> do
-      (y . (<$ s')) <$> runSem (d' (fmap na fa)) k
-    Right (Weaving GetInspector s' _ y _) -> do
-      pure $ y $ Inspector v <$ s'
+    Left x -> k $ hoist (runTactics s d d') x
+    Right (Weaving e _ lwr ex) -> do
+      let s' = mkInitState lwr
+      case e of
+        GetInitialState ->
+          pure $ ex $ s <$ s'
+        HoistInterpretation na ->
+          pure $ ex $ (d . fmap na) <$ s'
+        HoistInterpretationH na fa ->
+          (ex . (<$ s')) <$> runSem (d' (fmap na fa)) k
+        GetInspector ->
+          pure $ ex $ Inspector mkInspector <$ s'
 {-# INLINE runTactics #-}
-
diff --git a/src/Polysemy/Internal/Union.hs b/src/Polysemy/Internal/Union.hs
index 3da8da27..046ba963 100644
--- a/src/Polysemy/Internal/Union.hs
+++ b/src/Polysemy/Internal/Union.hs
@@ -20,11 +20,15 @@ module Polysemy.Internal.Union
   , MemberWithError
   , weave
   , hoist
+  , liftHandler
+  , liftHandlerWithNat
+
   -- * Building Unions
   , inj
   , injUsing
   , injWeaving
   , weaken
+
   -- * Using Unions
   , decomp
   , prj
@@ -43,14 +47,20 @@ module Polysemy.Internal.Union
   , extendMembershipRight
   , injectMembership
   , weakenList
-  , weakenMid) where
+  , weakenMid
+
+  , module Polysemy.Internal.WeaveClass
+
+  ) where
 
-import Control.Monad
+import Control.Monad.Trans.Identity
+import Data.Coerce
 import Data.Functor.Compose
 import Data.Functor.Identity
 import Data.Kind
 import Data.Typeable
 import Polysemy.Internal.Kind
+import Polysemy.Internal.WeaveClass
 import {-# SOURCE #-} Polysemy.Internal
 import Polysemy.Internal.Sing (SList (SEnd, SCons))
 
@@ -78,59 +88,55 @@ instance Functor (Union r mWoven) where
 
 data Weaving e mAfter resultType where
   Weaving
-    :: forall f e rInitial a resultType mAfter. (Functor f)
+    :: forall t e rInitial a resultType mAfter. (MonadTransControl t)
     => {
-      weaveEffect :: e (Sem rInitial) a
+        weaveEffect :: e (Sem rInitial) a
       -- ^ The original effect GADT originally lifted via
       -- 'Polysemy.Internal.send'.
       -- ^ @rInitial@ is the effect row that was in scope when this 'Weaving'
       -- was originally created.
-      , weaveState :: f ()
-      -- ^ A piece of state that other effects' interpreters have already
-      -- woven through this 'Weaving'. @f@ is a 'Functor', so you can always
-      -- 'fmap' into this thing.
-      , weaveDistrib :: forall x. f (Sem rInitial x) -> mAfter (f x)
-      -- ^ Distribute @f@ by transforming @Sem rInitial@ into @mAfter@. This is
-      -- usually of the form @f ('Polysemy.Sem' (Some ': Effects ': r) x) ->
-      --   Sem r (f x)@
-      , weaveResult :: f a -> resultType
-      -- ^ Even though @f a@ is the moral resulting type of 'Weaving', we
-      -- can't expose that fact; such a thing would prevent 'Polysemy.Sem'
-      -- from being a 'Monad'.
-      , weaveInspect :: forall x. f x -> Maybe x
-      -- ^ A function for attempting to see inside an @f@. This is no
-      -- guarantees that such a thing will succeed (for example,
-      -- 'Polysemy.Error.Error' might have 'Polysemy.Error.throw'n.)
+      , weaveTrans :: forall n x. Monad n => (forall y. mAfter y -> n y) -> Sem rInitial x -> t n x
+      , weaveLowering :: forall z x. Monad z => t z x -> z (StT t x)
+      , weaveResult :: StT t a -> resultType
       } -> Weaving e mAfter resultType
 
 instance Functor (Weaving e m) where
-  fmap f (Weaving e s d f' v) = Weaving e s d (f . f') v
+  fmap f (Weaving e mkT lwr ex) = Weaving e mkT lwr (f . ex)
   {-# INLINE fmap #-}
 
 
 
-weave
-    :: (Functor s, Functor n)
-    => s ()
-    -> (∀ x. s (m x) -> n (s x))
-    -> (∀ x. s x -> Maybe x)
-    -> Union r m a
-    -> Union r n (s a)
-weave s' d v' (Union w (Weaving e s nt f v)) =
-  Union w $ Weaving
-              e (Compose $ s <$ s')
-              (fmap Compose . d . fmap nt . getCompose)
-              (fmap f . getCompose)
-              (v <=< v' . getCompose)
+weave :: (MonadTransControl t, Monad n)
+      => (forall x. m x -> t n x)
+      -> (forall z x. Monad z => t z x -> z (StT t x))
+      -> Union r m a
+      -> Union r n (StT t a)
+weave mkT' lwr' (Union pr (Weaving e mkT lwr ex)) =
+  Union pr $ Weaving e
+                     (\n sem0 -> ComposeT $ mkT (hoistT n . mkT') sem0)
+                     (fmap Compose . lwr' . lwr . getComposeT)
+                     (fmap ex . getCompose)
 {-# INLINE weave #-}
 
+liftHandler :: (MonadTransControl t, Monad m, Monad n)
+            => (forall x. Union r m x -> n x)
+            -> Union r (t m) a -> t n a
+liftHandler = liftHandlerWithNat id
+{-# INLINE liftHandler #-}
+
+liftHandlerWithNat :: (MonadTransControl t, Monad m, Monad n)
+                   => (forall x. q x -> t m x)
+                   -> (forall x. Union r m x -> n x)
+                   -> Union r q a -> t n a
+liftHandlerWithNat n handler u = controlT $ \lower -> handler (weave n lower u)
+{-# INLINE liftHandlerWithNat #-}
 
 hoist
     :: (∀ x. m x -> n x)
     -> Union r m a
     -> Union r n a
-hoist f' (Union w (Weaving e s nt f v)) =
-  Union w $ Weaving e s (f' . nt) f v
+hoist n' (Union w (Weaving e mkT lwr ex)) =
+  Union w $ Weaving e (\n -> mkT (n . n')) lwr ex
 {-# INLINE hoist #-}
 
 
@@ -351,13 +357,12 @@ weakenMid sl sm (Union pr e) = Union (injectMembership @right sl sm pr) e
 
 ------------------------------------------------------------------------------
 -- | Lift an effect @e@ into a 'Union' capable of holding it.
-inj :: forall e r rInitial a. (Member e r) => e (Sem rInitial) a -> Union r (Sem rInitial) a
+inj :: forall e r rInitial a. Member e r => e (Sem rInitial) a -> Union r (Sem rInitial) a
 inj e = injWeaving $ Weaving
   e
-  (Identity ())
-  (fmap Identity . runIdentity)
+  (coerce :: (Sem rInitial x -> n x) -> Sem rInitial x -> IdentityT n x)
+  (fmap Identity . runIdentityT)
   runIdentity
-  (Just . runIdentity)
 {-# INLINE inj #-}
 
 
@@ -368,10 +373,9 @@ injUsing :: forall e r rInitial a.
   ElemOf e r -> e (Sem rInitial) a -> Union r (Sem rInitial) a
 injUsing pr e = Union pr $ Weaving
   e
-  (Identity ())
-  (fmap Identity . runIdentity)
+  (coerce :: (Sem rInitial x -> n x) -> Sem rInitial x -> IdentityT n x)
+  (fmap Identity . runIdentityT)
   runIdentity
-  (Just . runIdentity)
 {-# INLINE injUsing #-}
 
 ------------------------------------------------------------------------------
diff --git a/src/Polysemy/Internal/WeaveClass.hs b/src/Polysemy/Internal/WeaveClass.hs
new file mode 100644
index 00000000..5d500f89
--- /dev/null
+++ b/src/Polysemy/Internal/WeaveClass.hs
@@ -0,0 +1,159 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, QuantifiedConstraints, TupleSections #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module Polysemy.Internal.WeaveClass
+  ( MonadTransControl(..)
+  , controlT
+
+  , mkInitState
+  , mkDistrib
+  , Distrib(..)
+  , mkInspector
+
+  , ComposeT(..)
+  ) where
+
+import Control.Monad
+import Data.Coerce
+import Data.Functor.Identity
+import Data.Functor.Compose
+import Data.Tuple
+import Control.Monad.Trans
+import Control.Monad.Trans.Identity
+import Control.Monad.Trans.Maybe
+
+import qualified Control.Monad.Trans.Except as E
+import qualified Control.Monad.Trans.State.Lazy as LSt
+import qualified Control.Monad.Trans.State.Strict as SSt
+import qualified Control.Monad.Trans.Writer.Lazy as LWr
+
+-- | A variant of the classic @MonadTransControl@ class from @monad-control@,
+-- but with a small number of changes to make it more suitable with Polysemy's
+-- internals.
+class ( MonadTrans t
+      , forall z. Monad z => Monad (t z)
+      , Traversable (StT t)
+      )
+   => MonadTransControl t where
+  type StT t :: * -> *
+
+  hoistT :: (Monad m, Monad n)
+         => (forall x. m x -> n x)
+         -> t m a -> t n a
+  hoistT n m = controlT $ \lower -> n (lower m)
+  {-# INLINE hoistT #-}
+
+  liftWith :: Monad m
+           => ((forall z x. Monad z => t z x -> z (StT t x)) -> m a)
+           -> t m a
+
+  restoreT :: Monad m => m (StT t a) -> t m a
+
+controlT :: (MonadTransControl t, Monad m)
+         => ((forall z x. Monad z => t z x -> z (StT t x)) -> m (StT t a))
+         -> t m a
+controlT main = liftWith main >>= restoreT . pure
+{-# INLINE controlT #-}
+
+newtype ComposeT t (u :: (* -> *) -> * -> *) m a = ComposeT {
+    getComposeT :: t (u m) a
+  }
+  deriving (Functor, Applicative, Monad)
+
+instance ( MonadTrans t
+         , MonadTrans u
+         , forall m. Monad m => Monad (u m)
+         )
+      => MonadTrans (ComposeT t u) where
+  lift m = ComposeT (lift (lift m))
+
+instance ( MonadTransControl t
+         , MonadTransControl u
+         )
+      => MonadTransControl (ComposeT t u) where
+  type StT (ComposeT t u) = Compose (StT u) (StT t)
+
+  hoistT n (ComposeT m) = ComposeT (hoistT (hoistT n) m)
+
+  liftWith main = ComposeT $
+    liftWith $ \lowerT ->
+    liftWith $ \lowerU ->
+    main (\(ComposeT m) -> Compose <$> lowerU (lowerT m))
+
+  restoreT m = ComposeT (restoreT (restoreT (fmap getCompose m)))
+
+newtype Distrib f q m = Distrib (forall x. f (q x) -> m (f x))
+
+mkInitState :: Monad (t Identity)
+            => (t Identity () -> Identity (StT t ()))
+            -> StT t ()
+mkInitState lwr = runIdentity $ lwr (pure ())
+{-# INLINE mkInitState #-}
+
+mkDistrib :: (MonadTransControl t, Monad m)
+          => (forall n x. Monad n => (forall y. m y -> n y) -> q x -> t n x)
+          -> (forall z x. Monad z => t z x -> z (StT t x))
+          -> Distrib (StT t) q m
+mkDistrib mkT lwr = Distrib $ lwr . join . restoreT . return . fmap (mkT id)
+{-# INLINE mkDistrib #-}
+
+mkInspector :: Foldable f => f a -> Maybe a
+mkInspector = foldr (const . Just) Nothing
+{-# INLINE mkInspector #-}
+
+instance MonadTransControl IdentityT where
+  type StT IdentityT = Identity
+  hoistT = (coerce :: (m x -> n x) -> IdentityT m x -> IdentityT n x)
+
+  liftWith main = IdentityT (main (fmap Identity . runIdentityT))
+
+  restoreT = IdentityT . fmap runIdentity
+
+instance MonadTransControl (LSt.StateT s) where
+  type StT (LSt.StateT s) = (,) s
+
+  hoistT = LSt.mapStateT
+
+  liftWith main = LSt.StateT $ \s ->
+        (, s)
+    <$> main (\m -> swap <$> LSt.runStateT m s)
+
+  restoreT m = LSt.StateT $ \_ -> swap <$> m
+
+instance MonadTransControl (SSt.StateT s) where
+  type StT (SSt.StateT s) = (,) s
+
+  hoistT = SSt.mapStateT
+
+  liftWith main = SSt.StateT $ \s ->
+        (, s)
+    <$> main (\m -> swap <$!> SSt.runStateT m s)
+
+  restoreT m = SSt.StateT $ \_ -> swap <$!> m
+
+instance MonadTransControl (E.ExceptT e) where
+  type StT (E.ExceptT e) = Either e
+
+  hoistT = E.mapExceptT
+
+  liftWith main = lift $ main E.runExceptT
+
+  restoreT = E.ExceptT
+
+instance Monoid w => MonadTransControl (LWr.WriterT w) where
+  type StT (LWr.WriterT w) = (,) w
+
+  hoistT = LWr.mapWriterT
+
+  liftWith main = lift $ main (fmap swap . LWr.runWriterT)
+
+  restoreT m = LWr.WriterT (swap <$> m)
+
+
+instance MonadTransControl MaybeT where
+  type StT MaybeT = Maybe
+
+  hoistT = mapMaybeT
+
+  liftWith main = lift $ main runMaybeT
+
+  restoreT = MaybeT
diff --git a/src/Polysemy/Internal/Writer.hs b/src/Polysemy/Internal/Writer.hs
index f83d4c90..73482034 100644
--- a/src/Polysemy/Internal/Writer.hs
+++ b/src/Polysemy/Internal/Writer.hs
@@ -7,7 +7,7 @@ import Control.Exception
 import Control.Monad
 import qualified Control.Monad.Trans.Writer.Lazy as Lazy
 
-import Data.Bifunctor (first)
+import Data.Tuple (swap)
 import Data.Semigroup
 
 import Polysemy
@@ -205,17 +205,11 @@ interpretViaLazyWriter f sem = Sem $ \(k :: forall x. Union r (Sem r) x -> m x)
   let
     go :: forall x. Sem (e ': r) x -> Lazy.WriterT o m x
     go = usingSem $ \u -> case decomp u of
-      Right (Weaving e s wv ex ins) -> f $ Weaving e s (go . wv) ex ins
-      Left g -> Lazy.WriterT $ do
-        ~(o, a) <- k $
-          weave
-            (mempty, ())
-            (\ ~(o, m) -> (fmap . first) (o <>) (interpretViaLazyWriter f m))
-            (Just . snd)
-            g
-        return (a, o)
+      Right (Weaving e mkT lwr ex) -> f $ Weaving e (\n -> mkT (n . go)) lwr ex
+      Left g ->
+        liftHandlerWithNat
+          (Lazy.WriterT . fmap swap . interpretViaLazyWriter f)
+          k g
     {-# INLINE go #-}
-  in do
-    ~(a,s) <- Lazy.runWriterT (go sem)
-    return (s, a)
+  in swap <$> Lazy.runWriterT (go sem)
 {-# INLINE interpretViaLazyWriter #-}
diff --git a/src/Polysemy/NonDet.hs b/src/Polysemy/NonDet.hs
index d2664dd4..564eb6ab 100644
--- a/src/Polysemy/NonDet.hs
+++ b/src/Polysemy/NonDet.hs
@@ -12,8 +12,9 @@ module Polysemy.NonDet
   ) where
 
 import Control.Applicative
+import Control.Monad
 import Control.Monad.Trans.Maybe
-import Data.Maybe
+import Control.Monad.Trans
 
 import Polysemy
 import Polysemy.Error
@@ -37,18 +38,14 @@ runNonDet = runNonDetC . runNonDetInC
 runNonDetMaybe :: Sem (NonDet ': r) a -> Sem r (Maybe a)
 runNonDetMaybe (Sem sem) = Sem $ \k -> runMaybeT $ sem $ \u ->
   case decomp u of
-    Right (Weaving e s wv ex _) ->
+    Right (Weaving e mkT lwr ex) ->
       case e of
         Empty -> empty
         Choose left right ->
           MaybeT $ usingSem k $ runMaybeT $ fmap ex $
-              MaybeT (runNonDetMaybe (wv (left <$ s)))
-          <|> MaybeT (runNonDetMaybe (wv (right <$ s)))
-    Left x -> MaybeT $
-      k $ weave (Just ())
-          (maybe (pure Nothing) runNonDetMaybe)
-          id
-          x
+              MaybeT (runNonDetMaybe (lwr (mkT id left)))
+          <|> MaybeT (runNonDetMaybe (lwr (mkT id right)))
+    Left x -> liftHandlerWithNat (MaybeT . runNonDetMaybe) k x
 {-# INLINE runNonDetMaybe #-}
 
 ------------------------------------------------------------------------------
@@ -106,18 +103,24 @@ instance Monad (NonDetC m) where
     a (\ a' -> unNonDetC (f a') cons)
   {-# INLINE (>>=) #-}
 
+instance MonadTrans NonDetC where
+  lift m = NonDetC $ \c b -> m >>= (`c` b)
+
+instance MonadTransControl NonDetC where
+  type StT NonDetC = []
+
+  hoistT n nd = NonDetC $ \c b ->
+    join $ n $ unNonDetC nd (\a r -> return $ c a (join (n r))) (return b)
+
+  liftWith main = lift $ main (\m -> unNonDetC m (\a -> fmap (a:)) (return []))
+
+  restoreT m = NonDetC $ \c b -> m >>= foldr c b
+
 runNonDetInC :: Sem (NonDet ': r) a -> NonDetC (Sem r) a
 runNonDetInC = usingSem $ \u ->
   case decomp u of
-    Left x  -> NonDetC $ \c b -> do
-      l <- liftSem $ weave [()]
-                  -- KingoftheHomeless: This is NOT the right semantics, but
-                  -- the known alternatives are worse. See Issue #246.
-                  (fmap concat . traverse runNonDet)
-                  listToMaybe
-                  x
-      foldr c b l
-    Right (Weaving Empty _ _ _ _) -> empty
-    Right (Weaving (Choose left right) s wv ex _) -> fmap ex $
-      runNonDetInC (wv (left <$ s)) <|> runNonDetInC (wv (right <$ s))
+    Left x  -> liftHandlerWithNat runNonDetInC liftSem x
+    Right (Weaving Empty _ _ _)-> empty
+    Right (Weaving (Choose left right) mkT lwr ex) -> fmap ex $
+      runNonDetInC (lwr (mkT id left)) <|> runNonDetInC (lwr (mkT id right))
 {-# INLINE runNonDetInC #-}
diff --git a/src/Polysemy/Output.hs b/src/Polysemy/Output.hs
index ae64de24..1913b7e4 100644
--- a/src/Polysemy/Output.hs
+++ b/src/Polysemy/Output.hs
@@ -32,6 +32,7 @@ import Data.Bifunctor (first)
 import Polysemy
 import Polysemy.State
 import Control.Monad (when)
+import Control.Monad.Trans
 
 import Polysemy.Internal.Union
 import Polysemy.Internal.Writer
@@ -107,9 +108,9 @@ runLazyOutputMonoid
     => (o -> m)
     -> Sem (Output o ': r) a
     -> Sem r (m, a)
-runLazyOutputMonoid f = interpretViaLazyWriter $ \(Weaving e s _ ex _) ->
+runLazyOutputMonoid f = interpretViaLazyWriter $ \(Weaving e _ lwr ex) ->
   case e of
-    Output o -> ex s <$ Lazy.tell (f o)
+    Output o -> fmap ex $ lwr $ lift $ Lazy.tell (f o)
 
 ------------------------------------------------------------------------------
 -- | Like 'runOutputMonoid', but right-associates uses of '<>'.
diff --git a/src/Polysemy/State.hs b/src/Polysemy/State.hs
index e06e0ed9..a87ff5e8 100644
--- a/src/Polysemy/State.hs
+++ b/src/Polysemy/State.hs
@@ -32,7 +32,6 @@ import           Control.Monad.ST
 import qualified Control.Monad.Trans.State as S
 import           Data.IORef
 import           Data.STRef
-import           Data.Tuple (swap)
 import           Polysemy
 import           Polysemy.Internal
 import           Polysemy.Internal.Combinators
@@ -248,14 +247,10 @@ hoistStateIntoStateT
     -> S.StateT s (Sem r) a
 hoistStateIntoStateT (Sem m) = m $ \u ->
   case decomp u of
-    Left x -> S.StateT $ \s ->
-      liftSem . fmap swap
-              . weave (s, ())
-                      (\(s', m') -> swap <$> S.runStateT m' s')
-                      (Just . snd)
-              $ hoist hoistStateIntoStateT x
-    Right (Weaving Get z _ y _)     -> y . (<$ z) <$> S.get
-    Right (Weaving (Put s) z _ y _) -> y . (<$ z) <$> S.put s
+    Left x ->
+      liftHandlerWithNat hoistStateIntoStateT liftSem x
+    Right (Weaving Get _ lwr ex)     -> ex . (<$ mkInitState lwr) <$> S.get
+    Right (Weaving (Put s) _ lwr ex) -> ex . (<$ mkInitState lwr) <$> S.put s
 {-# INLINE hoistStateIntoStateT #-}
 
 
diff --git a/src/Polysemy/Tagged.hs b/src/Polysemy/Tagged.hs
index 4273197f..e351241d 100644
--- a/src/Polysemy/Tagged.hs
+++ b/src/Polysemy/Tagged.hs
@@ -48,8 +48,8 @@ tag
     => Sem (e ': r) a
     -> Sem r a
 tag = hoistSem $ \u -> case decomp u of
-  Right (Weaving e s wv ex ins) ->
-    injWeaving $ Weaving (Tagged @k e) s (tag @k . wv) ex ins
+  Right (Weaving e mkT lwr ex) ->
+    injWeaving $ Weaving (Tagged @k e) (\n -> mkT (n . tag @k)) lwr ex
   Left g -> hoist (tag @k) g
 {-# INLINE tag #-}
 
@@ -62,8 +62,8 @@ tagged
     -> Sem (Tagged k e ': r) a
 tagged = hoistSem $ \u ->
   case decompCoerce u of
-    Right (Weaving e s wv ex ins) ->
-      injWeaving $ Weaving (Tagged @k e) s (tagged @k . wv) ex ins
+    Right (Weaving e mkT lwr ex) ->
+      injWeaving $ Weaving (Tagged @k e) (\n -> mkT (n . tagged @k)) lwr ex
     Left g -> hoist (tagged @k) g
 {-# INLINE tagged #-}
 
@@ -79,8 +79,8 @@ untag
 -- but doing so probably worsens performance, as it hampers optimizations.
 -- Once GHC 8.10 rolls out, I will benchmark and compare.
 untag = hoistSem $ \u -> case decompCoerce u of
-  Right (Weaving (Tagged e) s wv ex ins) ->
-    Union Here (Weaving e s (untag . wv) ex ins)
+  Right (Weaving (Tagged e) mkT lwr ex) ->
+    Union Here (Weaving e (\n -> mkT (n . untag)) lwr ex)
   Left g -> hoist untag g
 {-# INLINE untag #-}
 
@@ -93,8 +93,8 @@ retag
     => Sem (Tagged k1 e ': r) a
     -> Sem r a
 retag = hoistSem $ \u -> case decomp u of
-  Right (Weaving (Tagged e) s wv ex ins) ->
-    injWeaving $ Weaving (Tagged @k2 e) s (retag @_ @k2 . wv) ex ins
+  Right (Weaving (Tagged e) mkT lwr ex) ->
+    injWeaving $ Weaving (Tagged @k2 e) (\n -> mkT $ n . retag @_ @k2) lwr ex
   Left g -> hoist (retag @_ @k2) g
 {-# INLINE retag #-}
 
diff --git a/src/Polysemy/Writer.hs b/src/Polysemy/Writer.hs
index 78f95c2a..885a2bab 100644
--- a/src/Polysemy/Writer.hs
+++ b/src/Polysemy/Writer.hs
@@ -100,18 +100,18 @@ runLazyWriter
      . Monoid o
     => Sem (Writer o ': r) a
     -> Sem r (o, a)
-runLazyWriter = interpretViaLazyWriter $ \(Weaving e s wv ex ins) ->
+runLazyWriter = interpretViaLazyWriter $ \(Weaving e mkT lwr ex) ->
   case e of
-    Tell o   -> ex s <$ Lazy.tell o
+    Tell o   -> ex (mkInitState lwr) <$ Lazy.tell o
     Listen m -> do
-      let m' = wv (m <$ s)
+      let m' = lwr $ mkT id m
       ~(fa, o) <- Lazy.listen m'
       return $ ex $ (,) o <$> fa
     Pass m -> do
-      let m' = wv (m <$ s)
+      let m' = lwr $ mkT id m
       Lazy.pass $ do
         ft <- m'
-        let f = maybe id fst (ins ft)
+        let f = maybe id fst (mkInspector ft)
         return (ex $ snd <$> ft, f)
 {-# INLINE runLazyWriter #-}
 

From a0c9d6c73ad51b6a0ae9021c46bab4681647bda1 Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Sat, 19 Dec 2020 10:45:35 +0100
Subject: [PATCH 02/21] Export interceptUsingNew in Polysemy.Membership, fix
 some docs and typos

---
 src/Polysemy.hs                      | 2 +-
 src/Polysemy/Internal/Combinators.hs | 2 +-
 src/Polysemy/Internal/Tactics.hs     | 2 +-
 src/Polysemy/Membership.hs           | 1 +
 4 files changed, 4 insertions(+), 3 deletions(-)

diff --git a/src/Polysemy.hs b/src/Polysemy.hs
index 0a1df354..96a21666 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -135,7 +135,7 @@ module Polysemy
 
     -- * 'RunH'
     -- | When interpreting higher-order effects using 'interpretNew'
-    -- and friends, you can't execute higher-order "thunks" given my
+    -- and friends, you can't execute higher-order "thunks" given by
     -- the interpreted effect directly. Instead, these must be executed
     -- using 'runH'.
   , RunH
diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs
index e4d072b1..68082b13 100644
--- a/src/Polysemy/Internal/Combinators.hs
+++ b/src/Polysemy/Internal/Combinators.hs
@@ -498,7 +498,7 @@ interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
         in
           fmap ex $ lwr $ go1 (h e)
 
--- TODO (KingoftheHomeless): If performance matter, optimize the definitions
+-- TODO (KingoftheHomeless): If it matters, optimize the definitions
 -- below
 
 ------------------------------------------------------------------------------
diff --git a/src/Polysemy/Internal/Tactics.hs b/src/Polysemy/Internal/Tactics.hs
index eee397a6..8088e95c 100644
--- a/src/Polysemy/Internal/Tactics.hs
+++ b/src/Polysemy/Internal/Tactics.hs
@@ -60,7 +60,7 @@ import Polysemy.Internal.Union
 --
 -- The @f@ type here is existential and corresponds to "whatever
 -- state the other effects want to keep track of." @f@ is always
--- a 'Functor'.
+-- a 'Traversable'.
 --
 -- @alloc'@, @dealloc'@ and @use'@ are now in a form that can be
 -- easily consumed by your interpreter. At this point, simply bind
diff --git a/src/Polysemy/Membership.hs b/src/Polysemy/Membership.hs
index 0b45c3b1..fb6c4f49 100644
--- a/src/Polysemy/Membership.hs
+++ b/src/Polysemy/Membership.hs
@@ -9,6 +9,7 @@ module Polysemy.Membership
   -- * Using membership
   , subsumeUsing
   , interceptUsing
+  , interceptUsingNew
   , interceptUsingH
   ) where
 

From 50897d06057ed74802b44ff7eb413ca6b1f0824f Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Sat, 19 Dec 2020 10:59:02 +0100
Subject: [PATCH 03/21] Update Strategic environment to know f is Traversable

---
 src/Polysemy/Internal/Strategy.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Polysemy/Internal/Strategy.hs b/src/Polysemy/Internal/Strategy.hs
index 1ee7182f..ad2d441a 100644
--- a/src/Polysemy/Internal/Strategy.hs
+++ b/src/Polysemy/Internal/Strategy.hs
@@ -21,7 +21,7 @@ data Strategy m f n z a where
 -- is extremely similar.
 --
 -- @since 1.2.0.0
-type Strategic m n a = forall f. Functor f => Sem (WithStrategy m f n) (m (f a))
+type Strategic m n a = forall f. Traversable f => Sem (WithStrategy m f n) (m (f a))
 
 
 ------------------------------------------------------------------------------
@@ -34,7 +34,7 @@ type WithStrategy m f n = '[Strategy m f n]
 -- 'Polysemy.Final.withWeavingToFinal'.
 --
 -- @since 1.2.0.0
-runStrategy :: Functor f
+runStrategy :: Traversable f
             => Sem '[Strategy m f n] a
             -> f ()
             -> (forall x. f (n x) -> m (f x))

From b020330706a8b1d379ba422de95eac8d0ce4642d Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Sat, 19 Dec 2020 14:09:45 +0100
Subject: [PATCH 04/21] Escape quotes in docs, remove last artifacts of lazy
 swaps

---
 src/Polysemy.hs                      |  2 +-
 src/Polysemy/Internal/Combinators.hs | 19 ++++++-------------
 2 files changed, 7 insertions(+), 14 deletions(-)

diff --git a/src/Polysemy.hs b/src/Polysemy.hs
index 96a21666..796a400d 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -135,7 +135,7 @@ module Polysemy
 
     -- * 'RunH'
     -- | When interpreting higher-order effects using 'interpretNew'
-    -- and friends, you can't execute higher-order "thunks" given by
+    -- and friends, you can't execute higher-order \"thunks\" given by
     -- the interpreted effect directly. Instead, these must be executed
     -- using 'runH'.
   , RunH
diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs
index 68082b13..71555ed3 100644
--- a/src/Polysemy/Internal/Combinators.hs
+++ b/src/Polysemy/Internal/Combinators.hs
@@ -48,13 +48,6 @@ import           Polysemy.Internal.CustomErrors
 import           Polysemy.Internal.Tactics
 import           Polysemy.Internal.Union
 
-
-------------------------------------------------------------------------------
--- | A lazier version of 'Data.Tuple.swap'.
-swap :: (a, b) -> (b, a)
-swap ~(a, b) = (b, a)
-
-
 firstOrder
     :: ((forall rInitial x. e (Sem rInitial) x ->
          Tactical e (Sem rInitial) r x) -> t)
@@ -117,7 +110,7 @@ interpretInStateT f s (Sem sem) = Sem $ \k ->
     case decomp u of
         Left x ->
           liftHandlerWithNat
-            (\m -> S.StateT $ \s' -> swap <$!> interpretInStateT f s' m)
+            (\m -> S.StateT $ \s' -> S.swap <$!> interpretInStateT f s' m)
             k x
         Right (Weaving e _ lwr ex) -> do
           let z = mkInitState lwr
@@ -134,11 +127,11 @@ interpretInLazyStateT
     -> Sem (e ': r) a
     -> Sem r (s, a)
 interpretInLazyStateT f s (Sem sem) = Sem $ \k ->
-  fmap swap $ flip LS.runStateT s $ sem $ \u ->
+  fmap S.swap $ flip LS.runStateT s $ sem $ \u ->
     case decomp u of
         Left x ->
           liftHandlerWithNat
-            (\m -> LS.StateT $ \s' -> swap <$> interpretInLazyStateT f s' m)
+            (\m -> LS.StateT $ \s' -> S.swap <$> interpretInLazyStateT f s' m)
             k x
         Right (Weaving e _ lwr ex) -> do
           let z = mkInitState lwr
@@ -164,7 +157,7 @@ lazilyStateful
     -> s
     -> Sem (e ': r) a
     -> Sem r (s, a)
-lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap swap . f e
+lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap S.swap . f e
 {-# INLINE[3] lazilyStateful #-}
 
 
@@ -495,8 +488,8 @@ interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
             Right (Weaving (RunH z) _ lwr' ex') ->
               (ex' . (<$ mkInitState lwr')) <$> mkT id z
             Left g -> liftHandler liftSem g
-        in
-          fmap ex $ lwr $ go1 (h e)
+      in
+        fmap ex $ lwr $ go1 (h e)
 
 -- TODO (KingoftheHomeless): If it matters, optimize the definitions
 -- below

From b1a93038626d79b02ab9c50db6419341ba341155 Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Mon, 4 Jan 2021 15:08:50 +0100
Subject: [PATCH 05/21] Powerful interpretNew

---
 polysemy.cabal                        |   3 +-
 src/Polysemy.hs                       |   6 +
 src/Polysemy/Error.hs                 |  17 +-
 src/Polysemy/Internal/Combinators.hs  | 147 +--------------
 src/Polysemy/Internal/InterpretNew.hs | 255 ++++++++++++++++++++++++++
 src/Polysemy/Internal/Union.hs        |   8 +-
 src/Polysemy/Internal/WeaveClass.hs   |  56 ++++--
 src/Polysemy/Internal/Writer.hs       |  50 ++---
 src/Polysemy/NonDet.hs                |   8 +-
 src/Polysemy/Reader.hs                |   8 +-
 src/Polysemy/Resource.hs              |  46 +++--
 src/Polysemy/Writer.hs                |  24 +--
 test/TacticsSpec.hs                   |   2 +-
 13 files changed, 365 insertions(+), 265 deletions(-)
 create mode 100644 src/Polysemy/Internal/InterpretNew.hs

diff --git a/polysemy.cabal b/polysemy.cabal
index 7ae2545b..f418b559 100644
--- a/polysemy.cabal
+++ b/polysemy.cabal
@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 754ab355722062c11ee014b832c3c95ddeea81fec4242a5938436c0ca64383c8
+-- hash: 53283f3e0706b3474ab26a2b75fc509c9ef2332c6580662107613bcf3dbecaf5
 
 name:           polysemy
 version:        1.6.0.0
@@ -65,6 +65,7 @@ library
       Polysemy.Internal.Fixpoint
       Polysemy.Internal.Forklift
       Polysemy.Internal.Index
+      Polysemy.Internal.InterpretNew
       Polysemy.Internal.Kind
       Polysemy.Internal.NonDet
       Polysemy.Internal.Sing
diff --git a/src/Polysemy.hs b/src/Polysemy.hs
index 796a400d..453a10b7 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -109,6 +109,7 @@ module Polysemy
   , transform
 
     -- * Combinators for Interpreting Higher-Order Effects
+  , EffHandlerH
   , interpretNew
   , interceptNew
   , reinterpretNew
@@ -140,6 +141,10 @@ module Polysemy
     -- using 'runH'.
   , RunH
   , runH
+  , runH'
+  , runExposeH
+  , runExposeH'
+  , restoreH
 
     -- * Tactics
     -- | Higher-order effects need to explicitly thread /other effects'/ state
@@ -166,6 +171,7 @@ module Polysemy
 import Polysemy.Final
 import Polysemy.Internal
 import Polysemy.Internal.Combinators
+import Polysemy.Internal.InterpretNew
 import Polysemy.Internal.Forklift
 import Polysemy.Internal.Kind
 import Polysemy.Internal.Tactics
diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs
index 2cbc6ae1..d4ca40f3 100644
--- a/src/Polysemy/Error.hs
+++ b/src/Polysemy/Error.hs
@@ -217,21 +217,12 @@ mapError
   => (e1 -> e2)
   -> Sem (Error e1 ': r) a
   -> Sem r a
-mapError f = interpretH $ \case
+mapError f = interpretNew $ \case
   Throw e -> throw $ f e
-  Catch action handler -> do
-    a  <- runT action
-    h  <- bindT handler
-
-    mx <- raise $ runError a
-    case mx of
+  Catch action handler ->
+    runError (runH' action) >>= \case
       Right x -> pure x
-      Left e -> do
-        istate <- getInitialStateT
-        mx' <- raise $ runError $ h $ e <$ istate
-        case mx' of
-          Right x -> pure x
-          Left e' -> throw $ f e'
+      Left e  -> runH (handler e)
 {-# INLINE mapError #-}
 
 
diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs
index 71555ed3..94a6430a 100644
--- a/src/Polysemy/Internal/Combinators.hs
+++ b/src/Polysemy/Internal/Combinators.hs
@@ -47,6 +47,7 @@ import           Polysemy.Internal
 import           Polysemy.Internal.CustomErrors
 import           Polysemy.Internal.Tactics
 import           Polysemy.Internal.Union
+import           Polysemy.Internal.InterpretNew
 
 firstOrder
     :: ((forall rInitial x. e (Sem rInitial) x ->
@@ -419,149 +420,3 @@ transform f (Sem m) = Sem $ \k -> m $ \u ->
     Left g -> g
     Right (Weaving e mkT lwr ex) ->
       injWeaving (Weaving (f e) mkT lwr ex)
-
-
--- | An effect for running monadic actions within a higher-order effect
--- currently being interpreted.
-newtype RunH z (m :: * -> *) a where
-  RunH :: z a -> RunH z m a
-
--- | Run a monadic action given by a higher-order effect that is currently
--- being interpreted.
---
--- @since TODO
-runH :: Member (RunH z) r => z a -> Sem r a
-runH = send . RunH
-
-------------------------------------------------------------------------------
--- | Like 'interpret', but for higher-order effects (i.e. those which make use
--- of the @m@ parameter.)
---
--- This is significantly easier to use than 'interpretH' and its corresponding
--- 'Tactical' environment.
--- Because of this, 'interpretNew' and friends are /heavily recommended/ over
--- 'interpretH' and friends /unless/ you need the extra power that the 'Tactical'
--- environment provides -- the ability to inspect and manipulate the underlying
--- effectful state.
---
--- Higher-order thunks within the effect to be interpreted can be run using
--- 'runH'. For example:
---
--- @
--- data Bind m a where
---   Bind :: m a -> (a -> m b) -> Bind m b
---
--- runBind :: Sem (Bind ': r) a -> Sem r a
--- runBind = 'interpretNew' \\case
---   Bind ma f -> do
---     a <- 'runH' ma
---     b <- 'runH' (f a)
---     return b
--- @
---
--- @since TODO
-interpretNew :: forall e r a
-              . (forall z x. e z x -> Sem (RunH z ': r) x)
-             -> Sem (e ': r) a
-             -> Sem r a
-interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
-  sem $ \u -> case decomp (hoist (interpretNew h) u) of
-    Left g -> k g
-    Right (Weaving e
-                 (mkT :: forall n x
-                       . Monad n
-                      => (forall y. Sem r y -> n y)
-                      -> z x -> t n x
-                 )
-                 lwr
-                 ex
-          ) ->
-      let
-          go1 :: forall x. Sem (RunH z ': r) x -> t m x
-          go1 = usingSem $ \u' -> case decomp u' of
-            Right (Weaving (RunH z) _ lwr' ex') ->
-              (ex' . (<$ mkInitState lwr')) <$> mkT (usingSem k) z
-            Left g -> liftHandlerWithNat go2 k g
-
-          go2 :: forall x. Sem (RunH z ': r) x -> t (Sem r) x
-          go2 = usingSem $ \u' -> case decomp (hoist go2 u') of
-            Right (Weaving (RunH z) _ lwr' ex') ->
-              (ex' . (<$ mkInitState lwr')) <$> mkT id z
-            Left g -> liftHandler liftSem g
-      in
-        fmap ex $ lwr $ go1 (h e)
-
--- TODO (KingoftheHomeless): If it matters, optimize the definitions
--- below
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret', but for higher-order effects.
---
--- This is /heavily recommended/ over 'reinterpretH' unless you need
--- the extra power that the 'Tactical' environment provides.
---
--- @since TODO
-reinterpretNew :: forall e1 e2 r a
-                . (forall z x. e1 z x -> Sem (RunH z ': e2 ': r) x)
-               -> Sem (e1 ': r) a
-               -> Sem (e2 ': r) a
-reinterpretNew h = interpretNew h . raiseUnder
-{-# INLINE reinterpretNew #-}
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret2', but for higher-order effects.
---
--- This is /heavily recommended/ over 'reinterpret2H' unless you need
--- the extra power that the 'Tactical' environment provides.
---
--- @since TODO
-reinterpret2New :: forall e1 e2 e3 r a
-                 . (forall z x. e1 z x -> Sem (RunH z ': e2 ': e3 ': r) x)
-                -> Sem (e1 ': r) a
-                -> Sem (e2 ': e3 ': r) a
-reinterpret2New h = interpretNew h . raiseUnder2
-{-# INLINE reinterpret2New #-}
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret3', but for higher-order effects.
---
--- This is /heavily recommended/ over 'reinterpret3H' unless you need
--- the extra power that the 'Tactical' environment provides.
---
--- @since TODO
-reinterpret3New :: forall e1 e2 e3 e4 r a
-                 . (forall z x. e1 z x -> Sem (RunH z ': e2 ': e3 ': e4 ': r) x)
-                -> Sem (e1 ': r) a
-                -> Sem (e2 ': e3 ': e4 ': r) a
-reinterpret3New h = interpretNew h . raiseUnder3 
-{-# INLINE reinterpret3New #-}
-
-------------------------------------------------------------------------------
--- | Like 'intercept', but for higher-order effects.
---
--- This is /heavily recommended/ over 'interceptH' unless you need
--- the extra power that the 'Tactical' environment provides.
---
--- @since TODO
-interceptNew :: forall e r a
-              . Member e r
-             => (forall z x. e z x -> Sem (RunH z ': r) x)
-             -> Sem r a
-             -> Sem r a
-interceptNew h = interpretNew h . expose
-{-# INLINE interceptNew #-}
-
-------------------------------------------------------------------------------
--- | Like 'interceptUsing', but for higher-order effects.
---
--- This is /heavily recommended/ over 'interceptUsingH' unless you need
--- the extra power that the 'Tactical' environment provides.
---
--- @since TODO
-interceptUsingNew :: forall e r a
-                   . ElemOf e r
-                  -> (forall z x. e z x -> Sem (RunH z ': r) x)
-                  -> Sem r a
-                  -> Sem r a
-interceptUsingNew pr h = interpretNew h . exposeUsing pr
-{-# INLINE interceptUsingNew #-}
diff --git a/src/Polysemy/Internal/InterpretNew.hs b/src/Polysemy/Internal/InterpretNew.hs
new file mode 100644
index 00000000..2552dffc
--- /dev/null
+++ b/src/Polysemy/Internal/InterpretNew.hs
@@ -0,0 +1,255 @@
+module Polysemy.Internal.InterpretNew where
+
+import           Polysemy.Internal
+import           Polysemy.Internal.WeaveClass
+import           Polysemy.Internal.Union
+import           Polysemy.Internal.Kind
+
+
+-- | An effect for running monadic actions within a higher-order effect
+-- currently being interpreted.
+data RunH z t r :: Effect where
+  RunH        :: forall z t r m a. z a -> RunH z t r m a
+  RunExposeH  :: forall z t r m a. z a -> RunH z t r m (t a)
+  RunExposeH' :: forall z t r m a. z a -> RunH z t r m (Sem r (t a))
+  RestoreH    :: forall z t r m a. t a -> RunH z t r m a
+
+-- | Run a monadic action given by a higher-order effect that is currently
+-- being interpreted, and recursively apply the current interpreter on it.
+--
+-- This is the standard tool for interpreting higher-order effects.
+--
+-- @since TODO
+runH :: forall z t r r' a. z a -> Sem (RunH z t r ': r') a
+runH = send . RunH @z @t @r
+{-# INLINE runH #-}
+
+-- | Run a monadic action given by a higher-order effect that is currently
+-- being interpreted.
+--
+-- Unlike 'runH', this doesn't recursively apply the current interpreter
+-- to the monadic action -- allowing you to run a different interpreter
+-- on it instead.
+--
+-- @since TODO
+runH' :: forall z t e r a. z a -> Sem (e ': RunH z t (e ': r) ': r) a
+runH' z = runExposeH' z >>= raise . restoreH
+{-# INLINE runH' #-}
+
+-- | Run a monadic action given by a higher-order effect that is currently
+-- being interpreted, recursively apply the current interpreter on it,
+-- and reify the effectful state of all local effects
+-- as part of the result.
+--
+-- By reifying the effectful state, you may do one or more of the following:
+--
+-- * Guarantee that the handler won't be interrupted by a local effect failing,
+--   since that failure will instead be reified into the state.
+-- * Check if the action run has failed because of a local effect by using 'Data.Foldable.null'.
+-- * Discard any impact the monadic action has on local effects by never restoring the
+--   efectful state.
+--
+-- Once an effectful state has been reified, you may restore it using 'restoreH'.
+--
+-- @since TODO
+runExposeH :: forall z t r r' a. z a -> Sem (RunH z t r ': r') (t a)
+runExposeH = send . RunExposeH @z @t @r
+{-# INLINE runExposeH #-}
+
+-- | Run a monadic action given by a higher-order effect that is currently
+-- being interpreted, and reify the effectful state of all local effects
+-- as part of the result.
+--
+-- See 'runExposeH' for more information.
+--
+-- Unlike 'runH', this doesn't recursively apply the current interpreter
+-- to the monadic action -- allowing you to run a different interpreter
+-- on it instead.
+--
+-- @since TODO
+runExposeH' :: forall z t e r a. z a -> Sem (e ': RunH z t (e ': r) ': r) (t a)
+runExposeH' z = raise (send (RunExposeH' @_ @t z)) >>= raiseUnder
+{-# INLINE runExposeH' #-}
+
+-- Restore a reified effectful state, bringing its changes into scope, and returning
+-- the result of the computation.
+--
+-- /Note/: this overrides the local effectful state of any previously restored effectful state.
+--
+-- For example, consider:
+--
+-- @
+-- 'ta' <- runExposeH ma
+-- 'tb' <- runExposeH mb
+-- 'restoreH' ta
+-- 'restoreH' tb
+-- @
+-- Unless @'restoreH' ta@ causes the handler to fail (because @ma@ failed due to a local effect),
+-- the changes it brings into scope will be overridden by @'restoreH' tb@.
+--
+-- If you want to integrate the results of both actions, you need to restore the state
+-- in between uses of 'runExposeH', so that @'runExposeH' mb@ works with the changes of @ta@
+-- in scope.
+-- @
+-- 'ta' <- runExposeH ma
+-- 'restoreH' ta
+-- 'tb' <- runExposeH mb
+-- 'restoreH' tb
+-- @
+restoreH :: forall z t r r' a. t a -> Sem (RunH z t r ': r') a
+restoreH = send . RestoreH @z @t @r
+{-# INLINE restoreH #-}
+
+type EffHandlerH e r =
+     forall z t x
+   . Traversable t
+  => e z x -> Sem (RunH z t (e ': r) ': r) x
+
+------------------------------------------------------------------------------
+-- | Like 'interpret', but for higher-order effects (i.e. those which make use
+-- of the @m@ parameter.)
+--
+-- This is significantly easier to use than 'interpretH' and its corresponding
+-- 'Tactical' environment.
+-- Because of this, 'interpretNew' and friends are /heavily recommended/ over
+-- 'interpretH' and friends /unless/ you need the extra power that the 'Tactical'
+-- environment provides -- the ability to inspect and manipulate the underlying
+-- effectful state.
+--
+-- Higher-order thunks within the effect to be interpreted can be run using
+-- 'runH'. For example:
+--
+-- @
+-- data Bind m a where
+--   Bind :: m a -> (a -> m b) -> Bind m b
+--
+-- runBind :: Sem (Bind ': r) a -> Sem r a
+-- runBind = 'interpretNew' \\case
+--   Bind ma f -> do
+--     a <- 'runH' ma
+--     b <- 'runH' (f a)
+--     return b
+-- @
+--
+-- @since TODO
+interpretNew :: forall e r a
+              . EffHandlerH e r
+             -> Sem (e ': r) a
+             -> Sem r a
+interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
+  sem $ \u -> case decomp u of
+    Left g -> k $ hoist (interpretNew h) g
+    Right (Weaving e
+                 (mkT :: forall n x
+                       . Monad n
+                      => (forall y. Sem (e ': r) y -> n y)
+                      -> z x -> t n x
+                 )
+                 lwr
+                 ex
+          ) ->
+      let
+          go1 :: forall x. Sem (RunH z (StT t) (e ': r) ': r) x -> t m x
+          go1 = usingSem $ \u' -> case decomp u' of
+            Left g -> liftHandlerWithNat go2 k g
+            Right (Weaving eff _ lwr' ex') -> do
+              (ex' . (<$ mkInitState lwr')) <$> case eff of
+                RunH z ->
+                  mkT (usingSem k . interpretNew h) z
+                RunExposeH z ->
+                  liftWith $ \lower -> lower (mkT (usingSem k . interpretNew h) z)
+                RunExposeH' z ->
+                  liftWith $ \lower -> return (lower (mkT id z))
+                RestoreH t ->
+                  restoreT (return t)
+
+          go2 :: forall x. Sem (RunH z (StT t) (e ': r) ': r) x -> t (Sem r) x
+          go2 = usingSem $ \u' -> case decomp u' of
+            Left g -> liftHandlerWithNat go2 liftSem g
+            Right (Weaving eff _ lwr' ex') -> do
+              (ex' . (<$ mkInitState lwr')) <$> case eff of
+                RunH z ->
+                  mkT (interpretNew h) z
+                RunExposeH z ->
+                  liftWith $ \lower -> lower (mkT (interpretNew h) z)
+                RunExposeH' z ->
+                  liftWith $ \lower -> return (lower (mkT id z))
+                RestoreH t ->
+                  restoreT (return t)
+      in
+        fmap ex $ lwr $ go1 (h e)
+
+-- TODO (KingoftheHomeless): If it matters, optimize the definitions
+-- below
+
+------------------------------------------------------------------------------
+-- | Like 'reinterpret', but for higher-order effects.
+--
+-- This is /heavily recommended/ over 'reinterpretH' unless you need
+-- the extra power that the 'Tactical' environment provides.
+--
+-- @since TODO
+reinterpretNew :: forall e1 e2 r a
+                . EffHandlerH e1 (e2 ': r)
+               -> Sem (e1 ': r) a
+               -> Sem (e2 ': r) a
+reinterpretNew h = interpretNew h . raiseUnder
+{-# INLINE reinterpretNew #-}
+
+------------------------------------------------------------------------------
+-- | Like 'reinterpret2', but for higher-order effects.
+--
+-- This is /heavily recommended/ over 'reinterpret2H' unless you need
+-- the extra power that the 'Tactical' environment provides.
+--
+-- @since TODO
+reinterpret2New :: forall e1 e2 e3 r a
+                 . EffHandlerH e1 (e2 ': e3 ': r)
+                -> Sem (e1 ': r) a
+                -> Sem (e2 ': e3 ': r) a
+reinterpret2New h = interpretNew h . raiseUnder2
+{-# INLINE reinterpret2New #-}
+
+------------------------------------------------------------------------------
+-- | Like 'reinterpret3', but for higher-order effects.
+--
+-- This is /heavily recommended/ over 'reinterpret3H' unless you need
+-- the extra power that the 'Tactical' environment provides.
+--
+-- @since TODO
+reinterpret3New :: forall e1 e2 e3 e4 r a
+                 . EffHandlerH e1 (e2 ': e3 ': e4 ': r)
+                -> Sem (e1 ': r) a
+                -> Sem (e2 ': e3 ': e4 ': r) a
+reinterpret3New h = interpretNew h . raiseUnder3
+{-# INLINE reinterpret3New #-}
+
+------------------------------------------------------------------------------
+-- | Like 'intercept', but for higher-order effects.
+--
+-- This is /heavily recommended/ over 'interceptH' unless you need
+-- the extra power that the 'Tactical' environment provides.
+--
+-- @since TODO
+interceptNew :: forall e r a
+              . Member e r
+             => EffHandlerH e r
+             -> Sem r a
+             -> Sem r a
+interceptNew h = interpretNew h . expose
+{-# INLINE interceptNew #-}
+
+------------------------------------------------------------------------------
+-- | Like 'interceptUsing', but for higher-order effects.
+--
+-- This is /heavily recommended/ over 'interceptUsingH' unless you need
+-- the extra power that the 'Tactical' environment provides.
+--
+-- @since TODO
+interceptUsingNew :: forall e r a
+                   . ElemOf e r
+                  -> EffHandlerH e r
+                  -> Sem r a
+                  -> Sem r a
+interceptUsingNew pr h = interpretNew h . exposeUsing pr
+{-# INLINE interceptUsingNew #-}
diff --git a/src/Polysemy/Internal/Union.hs b/src/Polysemy/Internal/Union.hs
index 046ba963..27e3a0b5 100644
--- a/src/Polysemy/Internal/Union.hs
+++ b/src/Polysemy/Internal/Union.hs
@@ -88,7 +88,7 @@ instance Functor (Union r mWoven) where
 
 data Weaving e mAfter resultType where
   Weaving
-    :: forall t e rInitial a resultType mAfter. (MonadTransControl t)
+    :: forall t e rInitial a resultType mAfter. (MonadTransWeave t)
     => {
         weaveEffect :: e (Sem rInitial) a
       -- ^ The original effect GADT originally lifted via
@@ -106,7 +106,7 @@ instance Functor (Weaving e m) where
 
 
 
-weave :: (MonadTransControl t, Monad n)
+weave :: (MonadTransWeave t, Monad n)
       => (forall x. m x -> t n x)
       -> (forall z x. Monad z => t z x -> z (StT t x))
       -> Union r m a
@@ -118,13 +118,13 @@ weave mkT' lwr' (Union pr (Weaving e mkT lwr ex)) =
                      (fmap ex . getCompose)
 {-# INLINE weave #-}
 
-liftHandler :: (MonadTransControl t, Monad m, Monad n)
+liftHandler :: (MonadTransWeave t, Monad m, Monad n)
             => (forall x. Union r m x -> n x)
             -> Union r (t m) a -> t n a
 liftHandler = liftHandlerWithNat id
 {-# INLINE liftHandler #-}
 
-liftHandlerWithNat :: (MonadTransControl t, Monad m, Monad n)
+liftHandlerWithNat :: (MonadTransWeave t, Monad m, Monad n)
                    => (forall x. q x -> t m x)
                    -> (forall x. Union r m x -> n x)
                    -> Union r q a -> t n a
diff --git a/src/Polysemy/Internal/WeaveClass.hs b/src/Polysemy/Internal/WeaveClass.hs
index 5d500f89..e636540f 100644
--- a/src/Polysemy/Internal/WeaveClass.hs
+++ b/src/Polysemy/Internal/WeaveClass.hs
@@ -1,8 +1,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, QuantifiedConstraints, TupleSections #-}
 {-# OPTIONS_HADDOCK not-home #-}
 module Polysemy.Internal.WeaveClass
-  ( MonadTransControl(..)
-  , controlT
+  ( MonadTransWeave(..)
 
   , mkInitState
   , mkDistrib
@@ -26,14 +25,14 @@ import qualified Control.Monad.Trans.State.Lazy as LSt
 import qualified Control.Monad.Trans.State.Strict as SSt
 import qualified Control.Monad.Trans.Writer.Lazy as LWr
 
--- | A variant of the classic @MonadTransControl@ class from @monad-control@,
+-- | A variant of the classic @MonadTransWeave@ class from @monad-control@,
 -- but with a small number of changes to make it more suitable with Polysemy's
 -- internals.
 class ( MonadTrans t
       , forall z. Monad z => Monad (t z)
       , Traversable (StT t)
       )
-   => MonadTransControl t where
+   => MonadTransWeave t where
   type StT t :: * -> *
 
   hoistT :: (Monad m, Monad n)
@@ -42,18 +41,18 @@ class ( MonadTrans t
   hoistT n m = controlT $ \lower -> n (lower m)
   {-# INLINE hoistT #-}
 
+  controlT :: Monad m
+           => ((forall z x. Monad z => t z x -> z (StT t x)) -> m (StT t a))
+           -> t m a
+  controlT main = liftWith main >>= restoreT . pure
+  {-# INLINE controlT #-}
+
   liftWith :: Monad m
            => ((forall z x. Monad z => t z x -> z (StT t x)) -> m a)
            -> t m a
 
   restoreT :: Monad m => m (StT t a) -> t m a
 
-controlT :: (MonadTransControl t, Monad m)
-         => ((forall z x. Monad z => t z x -> z (StT t x)) -> m (StT t a))
-         -> t m a
-controlT main = liftWith main >>= restoreT . pure
-{-# INLINE controlT #-}
-
 newtype ComposeT t (u :: (* -> *) -> * -> *) m a = ComposeT {
     getComposeT :: t (u m) a
   }
@@ -66,14 +65,19 @@ instance ( MonadTrans t
       => MonadTrans (ComposeT t u) where
   lift m = ComposeT (lift (lift m))
 
-instance ( MonadTransControl t
-         , MonadTransControl u
+instance ( MonadTransWeave t
+         , MonadTransWeave u
          )
-      => MonadTransControl (ComposeT t u) where
+      => MonadTransWeave (ComposeT t u) where
   type StT (ComposeT t u) = Compose (StT u) (StT t)
 
   hoistT n (ComposeT m) = ComposeT (hoistT (hoistT n) m)
 
+  controlT main = ComposeT $
+    controlT $ \lowerT ->
+    controlT $ \lowerU ->
+    getCompose <$> main (\(ComposeT m) -> Compose <$> lowerU (lowerT m))
+
   liftWith main = ComposeT $
     liftWith $ \lowerT ->
     liftWith $ \lowerU ->
@@ -89,7 +93,7 @@ mkInitState :: Monad (t Identity)
 mkInitState lwr = runIdentity $ lwr (pure ())
 {-# INLINE mkInitState #-}
 
-mkDistrib :: (MonadTransControl t, Monad m)
+mkDistrib :: (MonadTransWeave t, Monad m)
           => (forall n x. Monad n => (forall y. m y -> n y) -> q x -> t n x)
           -> (forall z x. Monad z => t z x -> z (StT t x))
           -> Distrib (StT t) q m
@@ -100,7 +104,7 @@ mkInspector :: Foldable f => f a -> Maybe a
 mkInspector = foldr (const . Just) Nothing
 {-# INLINE mkInspector #-}
 
-instance MonadTransControl IdentityT where
+instance MonadTransWeave IdentityT where
   type StT IdentityT = Identity
   hoistT = (coerce :: (m x -> n x) -> IdentityT m x -> IdentityT n x)
 
@@ -108,52 +112,64 @@ instance MonadTransControl IdentityT where
 
   restoreT = IdentityT . fmap runIdentity
 
-instance MonadTransControl (LSt.StateT s) where
+instance MonadTransWeave (LSt.StateT s) where
   type StT (LSt.StateT s) = (,) s
 
   hoistT = LSt.mapStateT
 
+  controlT main = LSt.StateT $ \s ->
+    swap <$> main (\m -> swap <$> LSt.runStateT m s)
+
   liftWith main = LSt.StateT $ \s ->
         (, s)
     <$> main (\m -> swap <$> LSt.runStateT m s)
 
   restoreT m = LSt.StateT $ \_ -> swap <$> m
 
-instance MonadTransControl (SSt.StateT s) where
+instance MonadTransWeave (SSt.StateT s) where
   type StT (SSt.StateT s) = (,) s
 
   hoistT = SSt.mapStateT
 
+  controlT main = SSt.StateT $ \s ->
+    swap <$!> main (\m -> swap <$!> SSt.runStateT m s)
+
   liftWith main = SSt.StateT $ \s ->
         (, s)
     <$> main (\m -> swap <$!> SSt.runStateT m s)
 
   restoreT m = SSt.StateT $ \_ -> swap <$!> m
 
-instance MonadTransControl (E.ExceptT e) where
+instance MonadTransWeave (E.ExceptT e) where
   type StT (E.ExceptT e) = Either e
 
   hoistT = E.mapExceptT
 
+  controlT main = E.ExceptT (main E.runExceptT)
+
   liftWith main = lift $ main E.runExceptT
 
   restoreT = E.ExceptT
 
-instance Monoid w => MonadTransControl (LWr.WriterT w) where
+instance Monoid w => MonadTransWeave (LWr.WriterT w) where
   type StT (LWr.WriterT w) = (,) w
 
   hoistT = LWr.mapWriterT
 
+  controlT main = LWr.WriterT (swap <$> main (fmap swap . LWr.runWriterT))
+
   liftWith main = lift $ main (fmap swap . LWr.runWriterT)
 
   restoreT m = LWr.WriterT (swap <$> m)
 
 
-instance MonadTransControl MaybeT where
+instance MonadTransWeave MaybeT where
   type StT MaybeT = Maybe
 
   hoistT = mapMaybeT
 
+  controlT main = MaybeT (main runMaybeT)
+
   liftWith main = lift $ main runMaybeT
 
   restoreT = MaybeT
diff --git a/src/Polysemy/Internal/Writer.hs b/src/Polysemy/Internal/Writer.hs
index 73482034..c80f6ea2 100644
--- a/src/Polysemy/Internal/Writer.hs
+++ b/src/Polysemy/Internal/Writer.hs
@@ -41,25 +41,15 @@ writerToEndoWriter
     :: (Monoid o, Member (Writer (Endo o)) r)
     => Sem (Writer o ': r) a
     -> Sem r a
-writerToEndoWriter = interpretH $ \case
-      Tell o   -> tell (Endo (o <>)) >>= pureT
+writerToEndoWriter = interpretNew $ \case
+      Tell o   -> tell (Endo (o <>))
       Listen m -> do
-        m' <- writerToEndoWriter <$> runT m
-        raise $ do
-          (o, fa) <- listen m'
-          return $ (,) (appEndo o mempty) <$> fa
-      Pass m -> do
-        ins <- getInspectorT
-        m'  <- writerToEndoWriter <$> runT m
-        raise $ pass $ do
-          t <- m'
-          let
-            f' =
-              maybe
-                id
-                (\(f, _) (Endo oo) -> let !o' = f (oo mempty) in Endo (o' <>))
-                (inspect ins t)
-          return (f', snd <$> t)
+        (o, a) <- listen (runH m)
+        return (appEndo o mempty, a)
+      Pass m -> pass $ do
+        (f, a) <- runH m
+        let f' (Endo oo) = let !o' = f (oo mempty) in Endo (o' <>)
+        return (f', a)
 {-# INLINE writerToEndoWriter #-}
 
 
@@ -76,37 +66,31 @@ runWriterSTMAction :: forall o r a
                          => (o -> STM ())
                          -> Sem (Writer o ': r) a
                          -> Sem r a
-runWriterSTMAction write = interpretH $ \case
-  Tell o -> do
-    t <- embedFinal $ atomically (write o)
-    pureT t
+runWriterSTMAction write = interpretNew $ \case
+  Tell o -> embedFinal $ atomically (write o)
   Listen m -> do
-    m' <- runT m
     -- Using 'withWeavingToFinal' instead of 'withStrategicToFinal'
     -- here allows us to avoid using two additional 'embedFinal's in
     -- order to create the TVars.
-    raise $ withWeavingToFinal $ \s wv _ -> mask $ \restore -> do
+    withWeavingToFinal $ \s wv _ -> mask $ \restore -> do
       -- See below to understand how this works
       tvar   <- newTVarIO mempty
       switch <- newTVarIO False
       fa     <-
-        restore (wv (runWriterSTMAction (writeListen tvar switch) m' <$ s))
+        restore (wv (runWriterSTMAction (writeListen tvar switch) (runH' m) <$ s))
           `onException` commitListen tvar switch
       o      <- commitListen tvar switch
-      return $ (fmap . fmap) (o, ) fa
+      return $ fmap (o, ) fa
   Pass m -> do
-    m'  <- runT m
-    ins <- getInspectorT
-    raise $ withWeavingToFinal $ \s wv ins' -> mask $ \restore -> do
+    withWeavingToFinal $ \s wv ins' -> mask $ \restore -> do
       -- See below to understand how this works
       tvar   <- newTVarIO mempty
       switch <- newTVarIO False
       t      <-
-        restore (wv (runWriterSTMAction (writePass tvar switch) m' <$ s))
+        restore (wv (runWriterSTMAction (writePass tvar switch) (runH' m) <$ s))
           `onException` commitPass tvar switch id
-      commitPass tvar switch
-        (maybe id fst $ ins' t >>= inspect ins)
-      return $ (fmap . fmap) snd t
+      commitPass tvar switch $ maybe id fst (ins' t)
+      return $ fmap snd t
 
   where
     {- KingoftheHomeless:
diff --git a/src/Polysemy/NonDet.hs b/src/Polysemy/NonDet.hs
index 564eb6ab..24cad6c9 100644
--- a/src/Polysemy/NonDet.hs
+++ b/src/Polysemy/NonDet.hs
@@ -59,12 +59,10 @@ nonDetToError :: Member (Error e) r
               => e
               -> Sem (NonDet ': r) a
               -> Sem r a
-nonDetToError (e :: e) = interpretH $ \case
+nonDetToError (e :: e) = interpretNew $ \case
   Empty -> throw e
   Choose left right -> do
-    left'  <- nonDetToError e <$> runT left
-    right' <- nonDetToError e <$> runT right
-    raise (left' `catch` \(_ :: e) -> right')
+    runH left `catch` \(_ :: e) -> runH right
 {-# INLINE nonDetToError #-}
 
 
@@ -106,7 +104,7 @@ instance Monad (NonDetC m) where
 instance MonadTrans NonDetC where
   lift m = NonDetC $ \c b -> m >>= (`c` b)
 
-instance MonadTransControl NonDetC where
+instance MonadTransWeave NonDetC where
   type StT NonDetC = []
 
   hoistT n nd = NonDetC $ \c b ->
diff --git a/src/Polysemy/Reader.hs b/src/Polysemy/Reader.hs
index 615f4925..18829ac1 100644
--- a/src/Polysemy/Reader.hs
+++ b/src/Polysemy/Reader.hs
@@ -37,11 +37,9 @@ asks f = f <$> ask
 ------------------------------------------------------------------------------
 -- | Run a 'Reader' effect with a constant value.
 runReader :: i -> Sem (Reader i ': r) a -> Sem r a
-runReader i = interpretH $ \case
-  Ask -> pureT i
-  Local f m -> do
-    mm <- runT m
-    raise $ runReader (f i) mm
+runReader i = interpretNew $ \case
+  Ask -> return i
+  Local f m -> runReader (f i) (runH' m)
 {-# INLINE runReader #-}
 
 
diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs
index 4291f94f..a46217ba 100644
--- a/src/Polysemy/Resource.hs
+++ b/src/Polysemy/Resource.hs
@@ -19,6 +19,7 @@ module Polysemy.Resource
   ) where
 
 import qualified Control.Exception as X
+import           Control.Monad
 import           Polysemy
 import           Polysemy.Final
 
@@ -182,34 +183,29 @@ runResource
     :: ∀ r a
      . Sem (Resource ': r) a
     -> Sem r a
-runResource = interpretH $ \case
+runResource = interpretNew $ \case
   Bracket alloc dealloc use -> do
-    a <- runT  alloc
-    d <- bindT dealloc
-    u <- bindT use
-
-    let run_it = raise . runResource
-    resource <- run_it a
-    result <- run_it $ u resource
-    _ <- run_it $ d resource
-    pure result
+    r  <- runH alloc
+    ta <- runExposeH (use r)
+    -- If "use" failed locally -- which we determine by inspecting
+    -- the effectful state -- then we run 'dealloc', discarding any
+    -- changes it does to the local state.
+    if null ta then do
+      _ <- runExposeH (dealloc r)
+      restoreH ta
+    else do
+    -- If "use" suceceeded, the we restore it and simply run dealloc as normal.
+      a <- restoreH ta
+      _ <- runH (dealloc r)
+      return a
 
   BracketOnError alloc dealloc use -> do
-    a <- runT  alloc
-    d <- bindT dealloc
-    u <- bindT use
-
-    let run_it = raise . runResource
-
-    resource <- run_it a
-    result <- run_it $ u resource
-
-    ins <- getInspectorT
-    case inspect ins result of
-      Just _ -> pure result
-      Nothing -> do
-        _ <- run_it $ d resource
-        pure result
+    r  <- runH  alloc
+    ta <- runExposeH (use r)
+    when (null ta) $ do
+      _ <- runExposeH (dealloc r)
+      return ()
+    restoreH ta
 {-# INLINE runResource #-}
 
 
diff --git a/src/Polysemy/Writer.hs b/src/Polysemy/Writer.hs
index 885a2bab..da985b1a 100644
--- a/src/Polysemy/Writer.hs
+++ b/src/Polysemy/Writer.hs
@@ -66,23 +66,23 @@ runWriter
     :: Monoid o
     => Sem (Writer o ': r) a
     -> Sem r (o, a)
-runWriter = runState mempty . reinterpretH
+runWriter = runState mempty . reinterpretNew
   (\case
-      Tell o -> do
-        modify' (<> o) >>= pureT
+      Tell o -> modify' (<> o)
       Listen m -> do
-        mm <- runT m
-        -- TODO(sandy): this is stupid
-        (o, fa) <- raise $ runWriter mm
+        -- runExposeH' to prevent local failures from ruining our day
+        (o, ta) <- runWriter (runExposeH' m)
         modify' (<> o)
-        pure $ (o, ) <$> fa
+        a <- restoreH ta
+        return (o, a)
       Pass m -> do
-        mm <- runT m
-        (o, t) <- raise $ runWriter mm
-        ins <- getInspectorT
-        let f = maybe id fst (inspect ins t)
+        (o, t) <- runWriter (runExposeH' m)
+        -- Try to extract the modification function from the t.
+        -- If "m" failed, default to id.
+        let f = foldr (const . fst) id t
         modify' (<> f o)
-        pure $ snd <$> t
+        (_, a) <- restoreH t
+        return a
   )
 {-# INLINE runWriter #-}
 
diff --git a/test/TacticsSpec.hs b/test/TacticsSpec.hs
index 91da8934..726be3cc 100644
--- a/test/TacticsSpec.hs
+++ b/test/TacticsSpec.hs
@@ -15,7 +15,7 @@ interpretTestE =
       bindTSimple f a
 
 spec :: Spec
-spec = parallel $ describe "runTH and bindTH" $ do
+spec = parallel $ describe "runTSimple and bindTSimple" $ do
   it "should act as expected" $ do
     r <- runM (interpretTestE (send (TestE (pure 5) (pure . (9 +)))))
     print r

From 60f06359604ffbe896567fa6fa422e3876d5cd7c Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Mon, 4 Jan 2021 17:54:25 +0100
Subject: [PATCH 06/21] exposeH, getProcessorH

---
 polysemy.cabal                                |   5 +-
 src/Polysemy.hs                               |  12 +-
 src/Polysemy/Async.hs                         |  37 ++---
 src/Polysemy/Error.hs                         |  14 +-
 src/Polysemy/Internal/Combinators.hs          |  12 --
 .../{InterpretNew.hs => Interpretation.hs}    | 128 +++++++++++++-----
 src/Polysemy/Interpretation.hs                |  15 ++
 src/Polysemy/Membership.hs                    |   1 +
 src/Polysemy/Resource.hs                      |   1 +
 src/Polysemy/Writer.hs                        |   1 +
 10 files changed, 147 insertions(+), 79 deletions(-)
 rename src/Polysemy/Internal/{InterpretNew.hs => Interpretation.hs} (63%)
 create mode 100644 src/Polysemy/Interpretation.hs

diff --git a/polysemy.cabal b/polysemy.cabal
index f418b559..c93bfd53 100644
--- a/polysemy.cabal
+++ b/polysemy.cabal
@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 53283f3e0706b3474ab26a2b75fc509c9ef2332c6580662107613bcf3dbecaf5
+-- hash: d7bfeced9fb04f06fed1d7d70c5ba8bbb99be9e4bf37c0b6e514fca6891a1405
 
 name:           polysemy
 version:        1.6.0.0
@@ -65,7 +65,7 @@ library
       Polysemy.Internal.Fixpoint
       Polysemy.Internal.Forklift
       Polysemy.Internal.Index
-      Polysemy.Internal.InterpretNew
+      Polysemy.Internal.Interpretation
       Polysemy.Internal.Kind
       Polysemy.Internal.NonDet
       Polysemy.Internal.Sing
@@ -76,6 +76,7 @@ library
       Polysemy.Internal.Union
       Polysemy.Internal.WeaveClass
       Polysemy.Internal.Writer
+      Polysemy.Interpretation
       Polysemy.IO
       Polysemy.Law
       Polysemy.Membership
diff --git a/src/Polysemy.hs b/src/Polysemy.hs
index 453a10b7..210a567d 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -138,13 +138,15 @@ module Polysemy
     -- | When interpreting higher-order effects using 'interpretNew'
     -- and friends, you can't execute higher-order \"thunks\" given by
     -- the interpreted effect directly. Instead, these must be executed
-    -- using 'runH'.
+    -- using 'runH' or 'runH''.
+    --
+    -- These functions are enough for most purposes when using
+    -- 'interpretNew'. However, "Polysemy.Interpretation" offers
+    -- additional, more complicated features which are occassionally
+    -- needed.
   , RunH
   , runH
   , runH'
-  , runExposeH
-  , runExposeH'
-  , restoreH
 
     -- * Tactics
     -- | Higher-order effects need to explicitly thread /other effects'/ state
@@ -171,7 +173,7 @@ module Polysemy
 import Polysemy.Final
 import Polysemy.Internal
 import Polysemy.Internal.Combinators
-import Polysemy.Internal.InterpretNew
+import Polysemy.Internal.Interpretation
 import Polysemy.Internal.Forklift
 import Polysemy.Internal.Kind
 import Polysemy.Internal.Tactics
diff --git a/src/Polysemy/Async.hs b/src/Polysemy/Async.hs
index e1aa2b66..c5e40e7c 100644
--- a/src/Polysemy/Async.hs
+++ b/src/Polysemy/Async.hs
@@ -21,6 +21,7 @@ module Polysemy.Async
 import qualified Control.Concurrent.Async as A
 import           Polysemy
 import           Polysemy.Final
+import           Polysemy.Interpretation
 
 
 
@@ -72,16 +73,16 @@ asyncToIO
     => Sem (Async ': r) a
     -> Sem r a
 asyncToIO m = withLowerToIO $ \lower _ -> lower $
-  interpretH
+  interpretNew
     ( \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)
+        Async ma -> do
+          Processor pr  <- getProcessorH'
+          fa  <- embed $ A.async $ lower $ asyncToIO (pr ma)
+          let ins = foldr (const . Just) Nothing
+          return (fmap ins fa)
+
+        Await a -> embed (A.wait a)
+        Cancel a -> embed (A.cancel a)
     )  m
 {-# INLINE asyncToIO #-}
 
@@ -126,16 +127,16 @@ lowerAsync
        -- some combination of 'runM' and other interpreters composed via '.@'.
     -> Sem (Async ': r) a
     -> Sem r a
-lowerAsync lower m = interpretH
+lowerAsync lower m = interpretNew
     ( \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)
+        Async ma -> do
+          Processor pr  <- getProcessorH
+          let ins = foldr (const . Just) Nothing
+          fa  <- embed $ A.async $ lower $ pr ma
+          return $ ins <$> fa
+
+        Await a -> embed (A.wait a)
+        Cancel a -> embed (A.cancel a)
     )  m
 {-# INLINE lowerAsync #-}
 {-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}
diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs
index d4ca40f3..eb742cfe 100644
--- a/src/Polysemy/Error.hs
+++ b/src/Polysemy/Error.hs
@@ -33,6 +33,7 @@ import           Data.Bifunctor (first)
 import           Data.Typeable
 import           Polysemy
 import           Polysemy.Final
+import           Polysemy.Interpretation
 import           Polysemy.Internal
 import           Polysemy.Internal.Union
 
@@ -309,13 +310,12 @@ runErrorAsExc
     => (∀ x. Sem r x -> IO x)
     -> Sem (Error e ': r) a
     -> Sem r a
-runErrorAsExc lower = interpretH $ \case
+runErrorAsExc lower = interpretNew $ \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
+    Processor pr  <- getProcessorH
+    let runIt = lower . pr
+    ta <- embed $ X.catch (runIt main) $ \(se :: WrappedExc e) ->
+      runIt $ handle $ unwrapExc se
+    restoreH ta
 {-# INLINE runErrorAsExc #-}
diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs
index 94a6430a..a697fbaa 100644
--- a/src/Polysemy/Internal/Combinators.hs
+++ b/src/Polysemy/Internal/Combinators.hs
@@ -12,16 +12,6 @@ module Polysemy.Internal.Combinators
   , rewrite
   , transform
 
-    -- * Higher order
-  , RunH(..)
-  , runH
-
-  , interpretNew
-  , interceptNew
-  , reinterpretNew
-  , reinterpret2New
-  , reinterpret3New
-
     -- * Higher order with 'Tactical'
   , interpretH
   , interceptH
@@ -32,7 +22,6 @@ module Polysemy.Internal.Combinators
   -- * Conditional
   , interceptUsing
   , interceptUsingH
-  , interceptUsingNew
 
     -- * Statefulness
   , stateful
@@ -47,7 +36,6 @@ import           Polysemy.Internal
 import           Polysemy.Internal.CustomErrors
 import           Polysemy.Internal.Tactics
 import           Polysemy.Internal.Union
-import           Polysemy.Internal.InterpretNew
 
 firstOrder
     :: ((forall rInitial x. e (Sem rInitial) x ->
diff --git a/src/Polysemy/Internal/InterpretNew.hs b/src/Polysemy/Internal/Interpretation.hs
similarity index 63%
rename from src/Polysemy/Internal/InterpretNew.hs
rename to src/Polysemy/Internal/Interpretation.hs
index 2552dffc..729aa096 100644
--- a/src/Polysemy/Internal/InterpretNew.hs
+++ b/src/Polysemy/Internal/Interpretation.hs
@@ -1,4 +1,6 @@
-module Polysemy.Internal.InterpretNew where
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module Polysemy.Internal.Interpretation where
 
 import           Polysemy.Internal
 import           Polysemy.Internal.WeaveClass
@@ -6,13 +8,16 @@ import           Polysemy.Internal.Union
 import           Polysemy.Internal.Kind
 
 
+newtype Processor z t r = Processor { getProcessor :: forall x. z x -> Sem r (t x) }
+
 -- | An effect for running monadic actions within a higher-order effect
 -- currently being interpreted.
-data RunH z t r :: Effect where
-  RunH        :: forall z t r m a. z a -> RunH z t r m a
-  RunExposeH  :: forall z t r m a. z a -> RunH z t r m (t a)
-  RunExposeH' :: forall z t r m a. z a -> RunH z t r m (Sem r (t a))
-  RestoreH    :: forall z t r m a. t a -> RunH z t r m a
+data RunH z t e r :: Effect where
+  RunH           :: forall z t e r m a. z a -> RunH z t e r m a
+  GetProcessorH  :: forall z t e r m. RunH z t e r m (Processor z t r)
+  GetProcessorH' :: forall z t e r m. RunH z t e r m (Processor z t (e ': r))
+  ExposeH        :: forall z t e r m a. m a -> RunH z t e r m (t a)
+  RestoreH       :: forall z t e r m a. t a -> RunH z t e r m a
 
 -- | Run a monadic action given by a higher-order effect that is currently
 -- being interpreted, and recursively apply the current interpreter on it.
@@ -20,8 +25,8 @@ data RunH z t r :: Effect where
 -- This is the standard tool for interpreting higher-order effects.
 --
 -- @since TODO
-runH :: forall z t r r' a. z a -> Sem (RunH z t r ': r') a
-runH = send . RunH @z @t @r
+runH :: forall z t e r r' a. z a -> Sem (RunH z t e r ': r') a
+runH = send . RunH @z @t @e @r
 {-# INLINE runH #-}
 
 -- | Run a monadic action given by a higher-order effect that is currently
@@ -32,7 +37,7 @@ runH = send . RunH @z @t @r
 -- on it instead.
 --
 -- @since TODO
-runH' :: forall z t e r a. z a -> Sem (e ': RunH z t (e ': r) ': r) a
+runH' :: forall z t e r a. z a -> Sem (e ': RunH z t e r ': r) a
 runH' z = runExposeH' z >>= raise . restoreH
 {-# INLINE runH' #-}
 
@@ -52,8 +57,10 @@ runH' z = runExposeH' z >>= raise . restoreH
 -- Once an effectful state has been reified, you may restore it using 'restoreH'.
 --
 -- @since TODO
-runExposeH :: forall z t r r' a. z a -> Sem (RunH z t r ': r') (t a)
-runExposeH = send . RunExposeH @z @t @r
+runExposeH :: forall z t e r a. z a -> Sem (RunH z t e r ': r) (t a)
+runExposeH z = do
+  Processor pr <- getProcessorH
+  raise (pr z)
 {-# INLINE runExposeH #-}
 
 -- | Run a monadic action given by a higher-order effect that is currently
@@ -67,11 +74,15 @@ runExposeH = send . RunExposeH @z @t @r
 -- on it instead.
 --
 -- @since TODO
-runExposeH' :: forall z t e r a. z a -> Sem (e ': RunH z t (e ': r) ': r) (t a)
-runExposeH' z = raise (send (RunExposeH' @_ @t z)) >>= raiseUnder
+runExposeH' :: forall z t e r a. z a -> Sem (e ': RunH z t e r ': r) (t a)
+runExposeH' z = do
+  Processor pr <- raise getProcessorH'
+  raiseUnder (pr z)
 {-# INLINE runExposeH' #-}
 
--- Restore a reified effectful state, bringing its changes into scope, and returning
+
+
+-- | Restore a reified effectful state, bringing its changes into scope, and returning
 -- the result of the computation.
 --
 -- /Note/: this overrides the local effectful state of any previously restored effectful state.
@@ -96,14 +107,49 @@ runExposeH' z = raise (send (RunExposeH' @_ @t z)) >>= raiseUnder
 -- 'tb' <- runExposeH mb
 -- 'restoreH' tb
 -- @
-restoreH :: forall z t r r' a. t a -> Sem (RunH z t r ': r') a
-restoreH = send . RestoreH @z @t @r
+--
+-- @since TODO
+restoreH :: forall z t e r r' a. t a -> Sem (RunH z t e r ': r') a
+restoreH = send . RestoreH @z @_ @e @r
 {-# INLINE restoreH #-}
 
+
+-- | Reify the effectful state of the local effects of the argument.
+--
+-- @'runExposeH' m = 'exposeH' ('runH' m)@
+--
+-- /Note/: `polysemy-plugin` is heavily recommended when using this function
+-- to avoid type ambiguous types. If `polysemy-plugin` isn't available, consider
+-- using 'runExposeH' and `runExposeH'` instead.
+--
+-- @since TODO
+exposeH :: forall z t e r r' a. Member (RunH z t e r) r' => Sem r' a -> Sem r' (t a)
+exposeH = send . ExposeH @z @_ @e @r
+{-# INLINE exposeH #-}
+
+-- | Retrieve a 'Processor': a function which can be used
+-- to process a monadic action given by a higher-order effect that is currently
+-- being interpreted without immediately running it, turning it into a @'Sem' r@ action
+-- that returns a reified effectful state.
+--
+-- The processor automatically recursively applies the current interpreter on
+-- monadic actions processed.
+getProcessorH :: forall z t e r r'. Sem (RunH z t e r ': r') (Processor z t r)
+getProcessorH = send (GetProcessorH @_ @_ @e)
+{-# INLINE getProcessorH #-}
+
+-- | Retrieve a 'Processor': a function which can be used
+-- to process a monadic action given by a higher-order effect that is currently
+-- being interpreted without immediately running it, turning it into a @'Sem' (e ': r)@ action
+-- that returns a reified effectful state.
+getProcessorH' :: forall z t e r r'. Sem (RunH z t e r ': r') (Processor z t (e ': r))
+getProcessorH' = send GetProcessorH'
+{-# INLINE getProcessorH' #-}
+
 type EffHandlerH e r =
      forall z t x
    . Traversable t
-  => e z x -> Sem (RunH z t (e ': r) ': r) x
+  => e z x -> Sem (RunH z t e r ': r) x
 
 ------------------------------------------------------------------------------
 -- | Like 'interpret', but for higher-order effects (i.e. those which make use
@@ -149,33 +195,45 @@ interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
                  ex
           ) ->
       let
-          go1 :: forall x. Sem (RunH z (StT t) (e ': r) ': r) x -> t m x
+          go1 :: forall x. Sem (RunH z (StT t) e r ': r) x -> t m x
           go1 = usingSem $ \u' -> case decomp u' of
             Left g -> liftHandlerWithNat go2 k g
-            Right (Weaving eff _ lwr' ex') -> do
-              (ex' . (<$ mkInitState lwr')) <$> case eff of
-                RunH z ->
+            Right (Weaving eff mkT' lwr' ex') -> do
+              let run_it = fmap (ex' . (<$ mkInitState lwr'))
+              case eff of
+                RunH z -> run_it $
                   mkT (usingSem k . interpretNew h) z
-                RunExposeH z ->
-                  liftWith $ \lower -> lower (mkT (usingSem k . interpretNew h) z)
-                RunExposeH' z ->
-                  liftWith $ \lower -> return (lower (mkT id z))
-                RestoreH t ->
+                GetProcessorH -> run_it $
+                  liftWith $ \lower -> return $ Processor (lower . mkT (interpretNew h))
+                GetProcessorH' -> run_it $
+                  liftWith $ \lower -> return $ Processor (lower . mkT id)
+                RestoreH t -> run_it $
                   restoreT (return t)
+                ExposeH m -> fmap ex' $ lwr' $ controlT $ \lower' -> do
+                  let m' = lower' (mkT' go1 m)
+                  liftWith $ \lower -> do
+                    t  <- lower m'
+                    lower' $ traverse (restoreT . return) t
 
-          go2 :: forall x. Sem (RunH z (StT t) (e ': r) ': r) x -> t (Sem r) x
+          go2 :: forall x. Sem (RunH z (StT t) e r ': r) x -> t (Sem r) x
           go2 = usingSem $ \u' -> case decomp u' of
             Left g -> liftHandlerWithNat go2 liftSem g
-            Right (Weaving eff _ lwr' ex') -> do
-              (ex' . (<$ mkInitState lwr')) <$> case eff of
-                RunH z ->
+            Right (Weaving eff mkT' lwr' ex') -> do
+              let run_it = fmap (ex' . (<$ mkInitState lwr'))
+              case eff of
+                RunH z -> run_it $
                   mkT (interpretNew h) z
-                RunExposeH z ->
-                  liftWith $ \lower -> lower (mkT (interpretNew h) z)
-                RunExposeH' z ->
-                  liftWith $ \lower -> return (lower (mkT id z))
-                RestoreH t ->
+                GetProcessorH -> run_it $
+                  liftWith $ \lower -> return $ Processor (lower . mkT (interpretNew h))
+                GetProcessorH' -> run_it $
+                  liftWith $ \lower -> return $ Processor (lower . mkT id)
+                RestoreH t -> run_it $
                   restoreT (return t)
+                ExposeH m -> fmap ex' $ lwr' $ controlT $ \lower' -> do
+                  let m' = lower' (mkT' go2 m)
+                  liftWith $ \lower -> do
+                    t  <- lower m'
+                    lower' $ traverse (restoreT . return) t
       in
         fmap ex $ lwr $ go1 (h e)
 
diff --git a/src/Polysemy/Interpretation.hs b/src/Polysemy/Interpretation.hs
new file mode 100644
index 00000000..22437356
--- /dev/null
+++ b/src/Polysemy/Interpretation.hs
@@ -0,0 +1,15 @@
+-- | Tools for more advanced usages of 'Polysemy.interpretNew'
+module Polysemy.Interpretation
+  ( -- * Manipuluating effectful state
+    runExposeH
+  , runExposeH'
+  , exposeH
+  , restoreH
+
+  -- * Lowering Higher-Order thunks to actions of @'Sem' r@.
+  , Processor(..)
+  , getProcessorH
+  , getProcessorH'
+  ) where
+
+import Polysemy.Internal.Interpretation
diff --git a/src/Polysemy/Membership.hs b/src/Polysemy/Membership.hs
index fb6c4f49..c5472082 100644
--- a/src/Polysemy/Membership.hs
+++ b/src/Polysemy/Membership.hs
@@ -15,4 +15,5 @@ module Polysemy.Membership
 
 import Polysemy.Internal
 import Polysemy.Internal.Combinators
+import Polysemy.Internal.Interpretation
 import Polysemy.Internal.Union
diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs
index a46217ba..0d9c5aba 100644
--- a/src/Polysemy/Resource.hs
+++ b/src/Polysemy/Resource.hs
@@ -22,6 +22,7 @@ import qualified Control.Exception as X
 import           Control.Monad
 import           Polysemy
 import           Polysemy.Final
+import           Polysemy.Interpretation
 
 
 ------------------------------------------------------------------------------
diff --git a/src/Polysemy/Writer.hs b/src/Polysemy/Writer.hs
index da985b1a..ee5e3037 100644
--- a/src/Polysemy/Writer.hs
+++ b/src/Polysemy/Writer.hs
@@ -33,6 +33,7 @@ import Data.Semigroup
 import Polysemy
 import Polysemy.Output
 import Polysemy.State
+import Polysemy.Interpretation
 
 import Polysemy.Internal.Union
 import Polysemy.Internal.Writer

From 477089ca9ce118ba6a27dac169bdcd0f36c8055b Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Mon, 23 Aug 2021 17:54:16 +0200
Subject: [PATCH 07/21] LiftWithH

---
 polysemy.cabal                          |   3 +-
 src/Polysemy.hs                         |   1 -
 src/Polysemy/Async.hs                   |  22 +-
 src/Polysemy/Error.hs                   |  38 ++-
 src/Polysemy/Final.hs                   | 237 +------------------
 src/Polysemy/Fixpoint.hs                |  10 +-
 src/Polysemy/Internal.hs                |   7 +-
 src/Polysemy/Internal/Combinators.hs    |   2 +
 src/Polysemy/Internal/Final.hs          | 294 ++++++++++++++++++++++++
 src/Polysemy/Internal/Interpretation.hs | 127 ++++++----
 src/Polysemy/Internal/Union.hs          |  10 +-
 src/Polysemy/Internal/WeaveClass.hs     |   6 +-
 src/Polysemy/Internal/Writer.hs         |  67 +++---
 src/Polysemy/Interpretation.hs          |   4 +-
 src/Polysemy/Law.hs                     |   2 +-
 src/Polysemy/Resource.hs                | 101 ++++----
 src/Polysemy/Writer.hs                  |   2 +-
 17 files changed, 519 insertions(+), 414 deletions(-)
 create mode 100644 src/Polysemy/Internal/Final.hs

diff --git a/polysemy.cabal b/polysemy.cabal
index c93bfd53..eeaaad74 100644
--- a/polysemy.cabal
+++ b/polysemy.cabal
@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: d7bfeced9fb04f06fed1d7d70c5ba8bbb99be9e4bf37c0b6e514fca6891a1405
+-- hash: cee4a3c928927f8880db3e8eafce7ebcb55523469c67c211e8deb2b6586d79b4
 
 name:           polysemy
 version:        1.6.0.0
@@ -62,6 +62,7 @@ library
       Polysemy.Internal.Combinators
       Polysemy.Internal.CustomErrors
       Polysemy.Internal.CustomErrors.Redefined
+      Polysemy.Internal.Final
       Polysemy.Internal.Fixpoint
       Polysemy.Internal.Forklift
       Polysemy.Internal.Index
diff --git a/src/Polysemy.hs b/src/Polysemy.hs
index 210a567d..ff0fc5dd 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -8,7 +8,6 @@ module Polysemy
     -- * Running Sem
   , run
   , runM
-  , runFinal
 
     -- * Type synonyms for user convenience
   , InterpreterFor
diff --git a/src/Polysemy/Async.hs b/src/Polysemy/Async.hs
index c5e40e7c..973c9ebb 100644
--- a/src/Polysemy/Async.hs
+++ b/src/Polysemy/Async.hs
@@ -75,9 +75,8 @@ asyncToIO
 asyncToIO m = withLowerToIO $ \lower _ -> lower $
   interpretNew
     ( \case
-        Async ma -> do
-          Processor pr  <- getProcessorH'
-          fa  <- embed $ A.async $ lower $ asyncToIO (pr ma)
+        Async ma -> liftWithH $ \lowerZ -> do
+          fa  <- embed $ A.async $ lower $ lowerZ $ asyncToIO $ runH' ma
           let ins = foldr (const . Just) Nothing
           return (fmap ins fa)
 
@@ -107,13 +106,11 @@ asyncToIO m = withLowerToIO $ \lower _ -> lower $
 asyncToIOFinal :: Member (Final IO) r
                => Sem (Async ': r) a
                -> Sem r a
-asyncToIOFinal = interpretFinal $ \case
-  Async m -> do
-    ins <- getInspectorS
-    m'  <- runS m
-    liftS $ A.async (inspect ins <$> m')
-  Await a -> liftS (A.wait a)
-  Cancel a -> liftS (A.cancel a)
+asyncToIOFinal = interpretFinal @IO $ \case
+  Async m -> liftWithS $ \lower -> do
+    fmap (foldr (const . Just) Nothing) <$> A.async (lower m)
+  Await a -> embed (A.wait a)
+  Cancel a -> embed (A.cancel a)
 {-# INLINE asyncToIOFinal #-}
 
 ------------------------------------------------------------------------------
@@ -129,10 +126,9 @@ lowerAsync
     -> Sem r a
 lowerAsync lower m = interpretNew
     ( \case
-        Async ma -> do
-          Processor pr  <- getProcessorH
+        Async ma -> liftWithH $ \lowerZ -> do
           let ins = foldr (const . Just) Nothing
-          fa  <- embed $ A.async $ lower $ pr ma
+          fa  <- embed $ A.async $ lower $ lowerZ $ runH ma
           return $ ins <$> fa
 
         Await a -> embed (A.wait a)
diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs
index eb742cfe..eb719116 100644
--- a/src/Polysemy/Error.hs
+++ b/src/Polysemy/Error.hs
@@ -129,10 +129,8 @@ fromExceptionSemVia
     -> Sem r a
     -> Sem r a
 fromExceptionSemVia f m = do
-  r <- withStrategicToFinal $ do
-    m' <- runS m
-    s  <- getInitialStateS
-    pure $ (fmap . fmap) Right m' `X.catch` \e -> (pure (Left e <$ s))
+  r <- controlF $ \lower ->
+    lower (fmap Right m) `X.catch` (lower . return . Left)
   case r of
     Left e -> throw $ f e
     Right a -> pure a
@@ -251,14 +249,10 @@ errorToIOFinal
        )
     => Sem (Error e ': r) a
     -> Sem r (Either e a)
-errorToIOFinal sem = withStrategicToFinal @IO $ do
-  m' <- runS (runErrorAsExcFinal sem)
-  s  <- getInitialStateS
-  pure $
-    either
-      ((<$ s) . Left . unwrapExc)
-      (fmap Right)
-    <$> X.try m'
+errorToIOFinal sem = controlF $ \lower -> do
+    lower (Right <$> runErrorAsExcFinal sem)
+  `X.catch` \(WrappedExc e) ->
+    lower $ return $ Left e
 {-# INLINE errorToIOFinal #-}
 
 runErrorAsExcFinal
@@ -269,13 +263,11 @@ runErrorAsExcFinal
     => Sem (Error e ': r) a
     -> Sem r a
 runErrorAsExcFinal = interpretFinal $ \case
-  Throw e   -> pure $ X.throwIO $ WrappedExc e
-  Catch m h -> do
-    m' <- runS m
-    h' <- bindS h
-    s  <- getInitialStateS
-    pure $ X.catch m' $ \(se :: WrappedExc e) ->
-      h' (unwrapExc se <$ s)
+  Throw e   -> embed $ X.throwIO $ WrappedExc e
+  Catch m h -> controlS $ \lower ->
+      lower m
+    `X.catch` \(WrappedExc e) ->
+      lower (h e)
 {-# INLINE runErrorAsExcFinal #-}
 
 ------------------------------------------------------------------------------
@@ -312,10 +304,8 @@ runErrorAsExc
     -> Sem r a
 runErrorAsExc lower = interpretNew $ \case
   Throw e -> embed $ X.throwIO $ WrappedExc e
-  Catch main handle -> do
-    Processor pr  <- getProcessorH
-    let runIt = lower . pr
-    ta <- embed $ X.catch (runIt main) $ \(se :: WrappedExc e) ->
+  Catch main handle -> controlH $ \lowerZ -> do
+    let runIt = lower . lowerZ . runH
+    embed $ X.catch (runIt main) $ \(se :: WrappedExc e) ->
       runIt $ handle $ unwrapExc se
-    restoreH ta
 {-# INLINE runErrorAsExc #-}
diff --git a/src/Polysemy/Final.hs b/src/Polysemy/Final.hs
index af60580a..50748187 100644
--- a/src/Polysemy/Final.hs
+++ b/src/Polysemy/Final.hs
@@ -1,13 +1,12 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, PatternGuards #-}
 module Polysemy.Final
   (
     -- * Effect
-    Final(..)
-  , ThroughWeavingToFinal
+    Final
 
     -- * Actions
-  , withWeavingToFinal
   , withStrategicToFinal
+  , controlF
   , embedFinal
 
     -- * Combinators for Interpreting to the Final Monad
@@ -27,235 +26,19 @@ module Polysemy.Final
     -- must be a monadic value of the target monad
     -- with the functorial state wrapped inside of it.
   , Strategic
-  , WithStrategy
-  , pureS
-  , liftS
+  , controlS
+  , liftWithS
+  , restoreS
   , runS
-  , bindS
-  , getInspectorS
-  , getInitialStateS
+  , controlS'
+  , liftWithS'
 
     -- * Interpretations
-  , runFinal
+  , runM
   , finalToFinal
 
   -- * Interpretations for Other Effects
   , embedToFinal
   ) where
 
-import Polysemy.Internal
-import Polysemy.Internal.Combinators
-import Polysemy.Internal.Union
-import Polysemy.Internal.Strategy
-import Polysemy.Internal.TH.Effect
-
------------------------------------------------------------------------------
--- | This represents a function which produces
--- an action of the final monad @m@ given:
---
---   * The initial effectful state at the moment the action
---     is to be executed.
---
---   * A way to convert @z@ (which is typically @'Sem' r@) to @m@ by
---     threading the effectful state through.
---
---   * An inspector that is able to view some value within the
---     effectful state if the effectful state contains any values.
---
--- A @'Polysemy.Internal.Union.Weaving'@ provides these components,
--- hence the name 'ThroughWeavingToFinal'.
---
--- @since 1.2.0.0
-type ThroughWeavingToFinal m z a =
-     forall f
-   . Traversable f
-  => f ()
-  -> (forall x. f (z x) -> m (f x))
-  -> (forall x. f x -> Maybe x)
-  -> m (f a)
-
------------------------------------------------------------------------------
--- | An effect for embedding higher-order actions in the final target monad
--- of the effect stack.
---
--- This is very useful for writing interpreters that interpret higher-order
--- effects in terms of the final monad.
---
--- 'Final' is more powerful than 'Embed', but is also less flexible
--- to interpret (compare 'Polysemy.Embed.runEmbedded' with 'finalToFinal').
--- If you only need the power of 'embed', then you should use 'Embed' instead.
---
--- /Beware/: 'Final' actions are interpreted as actions of the final monad,
--- and the effectful state visible to
--- 'withWeavingToFinal' \/ 'withStrategicToFinal'
--- \/ 'interpretFinal'
--- is that of /all interpreters run in order to produce the final monad/.
---
--- This means that any interpreter built using 'Final' will /not/
--- respect local/global state semantics based on the order of
--- interpreters run. You should signal interpreters that make use of
--- 'Final' by adding a @-'Final'@ suffix to the names of these.
---
--- State semantics of effects that are /not/
--- interpreted in terms of the final monad will always
--- appear local to effects that are interpreted in terms of the final monad.
---
--- State semantics between effects that are interpreted in terms of the final monad
--- depend on the final monad. For example, if the final monad is a monad transformer
--- stack, then state semantics will depend on the order monad transformers are stacked.
---
--- @since 1.2.0.0
-newtype Final m z a where
-  WithWeavingToFinal
-    :: ThroughWeavingToFinal m z a
-    -> Final m z a
-
-makeSem_ ''Final
-
------------------------------------------------------------------------------
--- | Allows for embedding higher-order actions of the final monad
--- by providing the means of explicitly threading effects through @'Sem' r@
--- to the final monad.
---
--- Consider using 'withStrategicToFinal' instead,
--- which provides a more user-friendly interface, but is also slightly weaker.
---
--- You are discouraged from using 'withWeavingToFinal' directly
--- in application code, as it ties your application code directly to
--- the final monad.
---
--- @since 1.2.0.0
-withWeavingToFinal
-  :: forall m r a
-   . Member (Final m) r
-  => ThroughWeavingToFinal m (Sem r) a
-  -> Sem r a
-
-
------------------------------------------------------------------------------
--- | 'withWeavingToFinal' admits an implementation of 'embed'.
---
--- Just like 'embed', you are discouraged from using this in application code.
---
--- @since 1.2.0.0
-embedFinal :: (Member (Final m) r, Functor m) => m a -> Sem r a
-embedFinal m = withWeavingToFinal $ \s _ _ -> (<$ s) <$> m
-{-# INLINE embedFinal #-}
-
------------------------------------------------------------------------------
--- | Allows for embedding higher-order actions of the final monad
--- by providing the means of explicitly threading effects through @'Sem' r@
--- to the final monad. This is done through the use of the 'Strategic'
--- environment, which provides 'runS' and 'bindS'.
---
--- You are discouraged from using 'withStrategicToFinal' in application code,
--- as it ties your application code directly to the final monad.
---
--- @since 1.2.0.0
-withStrategicToFinal :: Member (Final m) r
-                     => Strategic m (Sem r) a
-                     -> Sem r a
-withStrategicToFinal strat = withWeavingToFinal (runStrategy strat)
-{-# INLINE withStrategicToFinal #-}
-
-------------------------------------------------------------------------------
--- | Like 'interpretH', but may be used to
--- interpret higher-order effects in terms of the final monad.
---
--- 'interpretFinal' requires less boilerplate than using 'interpretH'
--- together with 'withStrategicToFinal' \/ 'withWeavingToFinal',
--- but is also less powerful.
--- 'interpretFinal' does not provide any means of executing actions
--- of @'Sem' r@ as you interpret each action, and the provided interpreter
--- is automatically recursively used to process higher-order occurences of
--- @'Sem' (e ': r)@ to @'Sem' r@.
---
--- If you need greater control of how the effect is interpreted,
--- use 'interpretH' together with 'withStrategicToFinal' \/
--- 'withWeavingToFinal' instead.
---
--- /Beware/: Effects that aren't interpreted in terms of the final
--- monad will have local state semantics in regards to effects
--- interpreted using 'interpretFinal'. See 'Final'.
---
--- @since 1.2.0.0
-interpretFinal
-    :: forall m e r a
-     . Member (Final m) r
-    => (forall x rInitial. e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-       -- ^ A natural transformation from the handled effect to the final monad.
-    -> Sem (e ': r) a
-    -> Sem r a
-interpretFinal h =
-  let
-    go :: Sem (e ': r) x -> Sem r x
-    go = hoistSem $ \u -> case decomp u of
-      Right (Weaving e mkT lwr ex) ->
-        injWeaving $
-          Weaving
-            (WithWeavingToFinal (runStrategy (h e)))
-            (\n -> mkT (n . go))
-            lwr
-            ex
-      Left g -> hoist go g
-    {-# INLINE go #-}
-  in
-    go
-{-# INLINE interpretFinal #-}
-
-------------------------------------------------------------------------------
--- | Lower a 'Sem' containing only a single lifted, final 'Monad' into that
--- monad.
---
--- If you also need to process an @'Embed' m@ effect, use this together with
--- 'embedToFinal'.
---
--- @since 1.2.0.0
-runFinal :: Monad m => Sem '[Final m] a -> m a
-runFinal = usingSem $ \u -> case extract u of
-  Weaving (WithWeavingToFinal wav) mkT lwr ex -> do
-    let s = mkInitState lwr
-        Distrib wv = mkDistrib mkT lwr
-        ins = mkInspector
-    ex <$> wav s (runFinal . wv) ins
-{-# INLINE runFinal #-}
-
-------------------------------------------------------------------------------
--- | Given natural transformations between @m1@ and @m2@, run a @'Final' m1@
--- effect by transforming it into a @'Final' m2@ effect.
---
--- @since 1.2.0.0
-finalToFinal :: forall m1 m2 r a
-              . Member (Final m2) r
-             => (forall x. m1 x -> m2 x)
-             -> (forall x. m2 x -> m1 x)
-             -> Sem (Final m1 ': r) a
-             -> Sem r a
-finalToFinal to from =
-  let
-    go :: Sem (Final m1 ': r) x -> Sem r x
-    go = hoistSem $ \u -> case decomp u of
-      Right (Weaving (WithWeavingToFinal wav) mkT lwr ex) ->
-        injWeaving $
-          Weaving
-            (WithWeavingToFinal $ \s' wv' ins' ->
-              to $ wav s' (from . wv') ins'
-            )
-            (\n -> mkT (n . go))
-            lwr
-            ex
-      Left g -> hoist go g
-    {-# INLINE go #-}
-  in
-    go
-{-# INLINE finalToFinal #-}
-
-------------------------------------------------------------------------------
--- | Transform an @'Embed' m@ effect into a @'Final' m@ effect
---
--- @since 1.2.0.0
-embedToFinal :: (Member (Final m) r, Functor m)
-             => Sem (Embed m ': r) a
-             -> Sem r a
-embedToFinal = interpret $ \(Embed m) -> embedFinal m
-{-# INLINE embedToFinal #-}
+import Polysemy.Internal.Final
diff --git a/src/Polysemy/Fixpoint.hs b/src/Polysemy/Fixpoint.hs
index 3c30d299..aa88fd9c 100644
--- a/src/Polysemy/Fixpoint.hs
+++ b/src/Polysemy/Fixpoint.hs
@@ -64,13 +64,9 @@ fixpointToFinal :: forall m r a
                  . (Member (Final m) r, MonadFix m)
                 => Sem (Fixpoint ': r) a
                 -> Sem r a
-fixpointToFinal = interpretFinal @m $
-  \(Fixpoint f) -> do
-    f'  <- bindS f
-    s   <- getInitialStateS
-    ins <- getInspectorS
-    pure $ mfix $ \fa -> f' $
-      fromMaybe (bomb "fixpointToFinal") (inspect ins fa) <$ s
+fixpointToFinal = interpretFinal @m $ \case
+  Fixpoint f -> controlS $ \lower ->
+    mfix $ lower . f . foldr const (bomb "fixpointToFinal")
 {-# INLINE fixpointToFinal #-}
 
 ------------------------------------------------------------------------------
diff --git a/src/Polysemy/Internal.hs b/src/Polysemy/Internal.hs
index 6066f2e5..13e859ad 100644
--- a/src/Polysemy/Internal.hs
+++ b/src/Polysemy/Internal.hs
@@ -17,7 +17,6 @@ module Polysemy.Internal
   , sendUsing
   , embed
   , run
-  , runM
   , raise_
   , Raise (..)
   , raise
@@ -98,7 +97,7 @@ import Polysemy.Internal.Sing (ListOfLength (listOfLength))
 -- than 'Embed', but also less flexible to interpret.
 --
 -- A 'Sem' can be interpreted as a pure value (via 'run') or as any
--- traditional 'Monad' (via 'runM' or 'Polysemy.runFinal').
+-- traditional 'Monad' (via 'Polysemy.runM').
 -- Each effect @E@ comes equipped with some interpreters of the form:
 --
 -- @
@@ -654,6 +653,10 @@ runM (Sem m) = m $ \z ->
       pure $ ex $ a <$ s
 {-# INLINE runM #-}
 
+type family Append l r where
+  Append (a ': l) r = a ': (Append l r)
+  Append '[] r = r
+
 
 ------------------------------------------------------------------------------
 -- | Type synonym for interpreters that consume an effect without changing the
diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs
index a697fbaa..1789a063 100644
--- a/src/Polysemy/Internal/Combinators.hs
+++ b/src/Polysemy/Internal/Combinators.hs
@@ -379,6 +379,8 @@ interceptUsingH pr f (Sem m) = Sem $ \k -> m $ \u ->
 -- | Rewrite an effect @e1@ directly into @e2@, and put it on the top of the
 -- effect stack.
 --
+-- @'rewrite' n = 'interpretNew' ('propagate' . n)@
+--
 -- @since 1.2.3.0
 rewrite
     :: forall e1 e2 r a
diff --git a/src/Polysemy/Internal/Final.hs b/src/Polysemy/Internal/Final.hs
new file mode 100644
index 00000000..fb8a63c0
--- /dev/null
+++ b/src/Polysemy/Internal/Final.hs
@@ -0,0 +1,294 @@
+{-# LANGUAGE TemplateHaskell, PatternGuards #-}
+module Polysemy.Internal.Final
+  (
+    -- * Effect
+    Final(..)
+
+    -- * Actions
+  , withStrategicToFinal
+  , withLoweringToFinal
+  , controlF
+  , embedFinal
+
+    -- * Combinators for Interpreting to the Final Monad
+  , interpretFinal
+
+    -- * Strategy
+    -- | Strategy is a domain-specific language very similar to @Tactics@
+    -- (see 'Polysemy.Tactical'), and is used to describe how higher-order
+    -- effects are threaded down to the final monad.
+    --
+    -- Much like @Tactics@, computations can be run and threaded
+    -- through the use of 'runS' and 'bindS', and first-order constructors
+    -- may use 'pureS'. In addition, 'liftS' may be used to
+    -- lift actions of the final monad.
+    --
+    -- Unlike @Tactics@, the final return value within a 'Strategic'
+    -- must be a monadic value of the target monad
+    -- with the functorial state wrapped inside of it.
+  , Strategic
+  , controlS
+  , liftWithS
+  , restoreS
+  , runS
+  , controlS'
+  , liftWithS'
+
+    -- * Interpretations
+  , runM
+  , finalToFinal
+
+  -- * Interpretations for Other Effects
+  , embedToFinal
+  ) where
+
+import Control.Monad.Trans
+import Polysemy.Internal
+import Polysemy.Internal.Combinators
+import Polysemy.Internal.Union
+import Polysemy.Internal.TH.Effect
+
+-----------------------------------------------------------------------------
+-- | An effect for embedding higher-order actions in the final target monad
+-- of the effect stack.
+--
+-- This is very useful for writing interpreters that interpret higher-order
+-- effects in terms of the final monad.
+--
+-- 'Final' is more powerful than 'Embed', but is also less flexible
+-- to interpret (compare 'Polysemy.Embed.runEmbedded' with 'finalToFinal').
+-- If you only need the power of 'embed', then you should use 'Embed' instead.
+--
+-- /Beware/: 'Final' actions are interpreted as actions of the final monad,
+-- and the effectful state visible to 'controlF' \/ 'withStrategicToFinal'
+-- \/ 'interpretFinal'
+-- is that of /all interpreters run in order to produce the final monad/.
+--
+-- This means that any interpreter built using 'Final' will /not/
+-- respect local/global state semantics based on the order of
+-- interpreters run. You should signal interpreters that make use of
+-- 'Final' by adding a @-'Final'@ suffix to the names of these.
+--
+-- State semantics of effects that are /not/
+-- interpreted in terms of the final monad will always
+-- appear local to effects that are interpreted in terms of the final monad.
+--
+-- State semantics between effects that are interpreted in terms of the final monad
+-- depend on the final monad. For example, if the final monad is a monad transformer
+-- stack, then state semantics will depend on the order monad transformers are stacked.
+--
+-- @since 1.2.0.0
+newtype Final m z a where
+  WithLoweringToFinal
+    :: (forall t. MonadTransWeave t => (forall x. z x -> t m x) -> t m a)
+    -> Final m z a
+
+makeSem ''Final
+
+data Strategy m t n z a where
+  LiftWithS :: forall m t n z a
+             . (  (  forall x
+                   . Sem '[Strategy m t n, Final m, Embed m] x
+                  -> m (t x)
+                  )
+               -> m a
+               )
+            -> Strategy m t n z a
+  RestoreS  :: forall m t n z a. t a -> Strategy m t n z a
+  RunS      :: forall m t n z a. n a -> Strategy m t n z a
+
+restoreS :: forall m t n r a. t a -> Sem (Strategy m t n ': r) a
+restoreS = send . RestoreS @m @_ @n
+{-# INLINE restoreS #-}
+
+runS :: forall m t n r a. n a -> Sem (Strategy m t n ': r) a
+runS = send . RunS @m @t
+{-# INLINE runS #-}
+
+liftWithS' :: forall m t n r a
+            . (  (  forall x
+                  . Sem '[Strategy m t n, Final m, Embed m] x -> m (t x)
+                 )
+              -> m a
+              )
+           -> Sem (Strategy m t n ': r) a
+liftWithS' main = send (LiftWithS main)
+{-# INLINE liftWithS' #-}
+
+controlS' :: forall m t n r a
+           . (  (  forall x
+                 . Sem '[Strategy m t n, Final m, Embed m] x -> m (t x)
+                )
+             -> m (t a)
+             )
+          -> Sem (Strategy m t n ': r) a
+controlS' main = liftWithS' main >>= restoreS
+{-# INLINE controlS' #-}
+
+liftWithS :: forall m t n r a
+           . ((forall x. n x -> m (t x)) -> m a) -> Sem (Strategy m t n ': r) a
+liftWithS main = liftWithS' $ \n -> main (n . runS)
+{-# INLINE liftWithS #-}
+
+controlS :: forall m t n r a
+          . ((forall x. n x -> m (t x)) -> m (t a))
+         -> Sem (Strategy m t n ': r) a
+controlS main = controlS' $ \n -> main (n . runS)
+{-# INLINE controlS #-}
+
+-- | A convenience method for @'withStrategicToFinal' . 'controlS'@
+controlF :: forall m r a
+          . (Member (Final m) r, Monad m)
+         => (  forall t
+             . Traversable t
+            => (forall x. Sem r x -> m (t x)) -> m (t a)
+            )
+         -> Sem r a
+controlF main = withLoweringToFinal $ \n ->
+  controlT $ \lower -> main (lower . n)
+{-# INLINE controlF #-}
+
+type Strategic m n a =
+  forall t. Traversable t => Sem '[Strategy m t n, Final m, Embed m] a
+
+runStrategy :: forall m n t a
+             . (Monad m, MonadTransWeave t)
+            => Sem '[Strategy m (StT t) n, Final m, Embed m] a
+            -> (forall x. n x -> t m x) -> t m a
+runStrategy main nat =
+  let
+    go :: forall x. Sem '[Strategy m (StT t) n, Final m, Embed m] x -> t m x
+    go = usingSem $ \(Union pr (Weaving eff mkT lwr ex)) -> do
+      let run_it = (ex . (<$ mkInitState lwr))
+      case pr of
+        Here -> run_it <$> case eff of
+          RestoreS t -> restoreT (return t)
+          RunS m -> nat m
+          LiftWithS main' -> liftWith $ \lower -> main' (lower . go)
+        There Here | WithLoweringToFinal main' <- eff ->
+          fmap ex $ lwr $ getComposeT $ main' (ComposeT . mkT go)
+        There (There Here) | Embed m <- eff -> run_it <$> lift m
+  in
+    go main
+
+-----------------------------------------------------------------------------
+-- | Allows for embedding higher-order actions of the final monad
+-- by providing the means of explicitly threading effects through @'Sem' r@
+-- to the final monad. This is done through the use of the 'Strategic'
+-- environment, which provides a variety of combinators, most notably 'controlS'.
+--
+-- You are discouraged from using 'withStrategicToFinal' in application code,
+-- as it ties your application code directly to the final monad.
+--
+-- @since 1.2.0.0
+withStrategicToFinal :: (Monad m, Member (Final m) r)
+                     => Strategic m (Sem r) a
+                     -> Sem r a
+withStrategicToFinal main = withLoweringToFinal (runStrategy main)
+{-# INLINE withStrategicToFinal #-}
+
+------------------------------------------------------------------------------
+-- | Lower a 'Sem' containing only a single lifted 'Monad' into that
+-- monad.
+runM :: Monad m => Sem '[Final m, Embed m] a -> m a
+runM = usingSem $ \u -> case decomp u of
+  Right (Weaving (WithLoweringToFinal main) mkT lwr ex) ->
+    fmap ex $ lwr $ main $ mkT runM
+  Left g -> case extract g of
+    Weaving (Embed m) _ lwr ex -> fmap (ex . (<$ mkInitState lwr)) m
+{-# INLINE runM #-}
+
+
+-----------------------------------------------------------------------------
+-- | 'withStrategicToFinal' admits an implementation of 'embed'.
+--
+-- Just like 'embed', you are discouraged from using this in application code.
+--
+-- @since 1.2.0.0
+embedFinal :: (Member (Final m) r, Monad m) => m a -> Sem r a
+embedFinal m = withLoweringToFinal $ \_ -> lift m
+{-# INLINE embedFinal #-}
+
+------------------------------------------------------------------------------
+-- | Like 'interpretH', but may be used to
+-- interpret higher-order effects in terms of the final monad.
+--
+-- 'interpretFinal' requires less boilerplate than using 'interpretH'
+-- together with 'withStrategicToFinal' \/ 'withWeavingToFinal',
+-- but is also less powerful.
+-- 'interpretFinal' does not provide any means of executing actions
+-- of @'Sem' r@ as you interpret each action, and the provided interpreter
+-- is automatically recursively used to process higher-order occurences of
+-- @'Sem' (e ': r)@ to @'Sem' r@.
+--
+-- If you need greater control of how the effect is interpreted,
+-- use 'interpretH' together with 'withStrategicToFinal' \/
+-- 'withWeavingToFinal' instead.
+--
+-- /Beware/: Effects that aren't interpreted in terms of the final
+-- monad will have local state semantics in regards to effects
+-- interpreted using 'interpretFinal'. See 'Final'.
+--
+-- @since 1.2.0.0
+interpretFinal
+    :: forall m e r a
+     . (Member (Final m) r, Monad m)
+    => (forall x rInitial. e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
+       -- ^ A natural transformation from the handled effect to the final monad.
+    -> Sem (e ': r) a
+    -> Sem r a
+interpretFinal h =
+  let
+    go :: Sem (e ': r) x -> Sem r x
+    go = hoistSem $ \u -> case decomp u of
+      Right (Weaving e mkT lwr ex) ->
+        injWeaving $
+          Weaving
+            (WithLoweringToFinal (runStrategy (h e)))
+            (\n -> mkT (n . go))
+            lwr
+            ex
+      Left g -> hoist go g
+    {-# INLINE go #-}
+  in
+    go
+{-# INLINE interpretFinal #-}
+
+------------------------------------------------------------------------------
+-- | Given natural transformations between @m1@ and @m2@, run a @'Final' m1@
+-- effect by transforming it into a @'Final' m2@ effect.
+--
+-- @since 1.2.0.0
+finalToFinal :: forall m1 m2 r a
+              . (Monad m1, Monad m2, Member (Final m2) r)
+             => (forall x. m1 x -> m2 x)
+             -> (forall x. m2 x -> m1 x)
+             -> Sem (Final m1 ': r) a
+             -> Sem r a
+finalToFinal to from =
+  let
+    go :: Sem (Final m1 ': r) x -> Sem r x
+    go = hoistSem $ \u -> case decomp u of
+      Right (Weaving (WithLoweringToFinal main) mkT lwr ex) ->
+        injWeaving $
+          Weaving
+            (WithLoweringToFinal $ \n -> hoistT to $ main (hoistT from . n)
+            )
+            (\n -> mkT (n . go))
+            lwr
+            ex
+      Left g -> hoist go g
+    {-# INLINE go #-}
+  in
+    go
+{-# INLINE finalToFinal #-}
+
+------------------------------------------------------------------------------
+-- | Transform an @'Embed' m@ effect into a @'Final' m@ effect
+--
+-- @since 1.2.0.0
+embedToFinal :: (Member (Final m) r, Monad m)
+             => Sem (Embed m ': r) a
+             -> Sem r a
+embedToFinal = interpret $ \(Embed m) -> embedFinal m
+{-# INLINE embedToFinal #-}
diff --git a/src/Polysemy/Internal/Interpretation.hs b/src/Polysemy/Internal/Interpretation.hs
index 729aa096..d94b7d65 100644
--- a/src/Polysemy/Internal/Interpretation.hs
+++ b/src/Polysemy/Internal/Interpretation.hs
@@ -2,6 +2,7 @@
 {-# OPTIONS_HADDOCK not-home #-}
 module Polysemy.Internal.Interpretation where
 
+import           Control.Monad
 import           Polysemy.Internal
 import           Polysemy.Internal.WeaveClass
 import           Polysemy.Internal.Union
@@ -10,14 +11,32 @@ import           Polysemy.Internal.Kind
 
 newtype Processor z t r = Processor { getProcessor :: forall x. z x -> Sem r (t x) }
 
+
 -- | An effect for running monadic actions within a higher-order effect
 -- currently being interpreted.
 data RunH z t e r :: Effect where
-  RunH           :: forall z t e r m a. z a -> RunH z t e r m a
-  GetProcessorH  :: forall z t e r m. RunH z t e r m (Processor z t r)
-  GetProcessorH' :: forall z t e r m. RunH z t e r m (Processor z t (e ': r))
-  ExposeH        :: forall z t e r m a. m a -> RunH z t e r m (t a)
-  RestoreH       :: forall z t e r m a. t a -> RunH z t e r m a
+  RunH             :: forall z t e r m a
+                    . z a
+                   -> RunH z t e r m a
+  WithProcessorH   :: forall z t e r m a
+                    . ((forall x. z x -> Sem (e ': r) (t x)) -> a)
+                   -> RunH z t e r m a
+  WithInterpreterH :: forall z t e r m a
+                    . ((forall x. Sem (e ': r) x -> Sem r x) -> a)
+                   -> RunH z t e r m a
+  LiftWithH        :: forall z t e r m a
+                    . ((forall x. Sem (RunH z t e r ': r) x -> Sem r (t x)) -> a)
+                   -> RunH z t e r m a
+  RestoreH         :: forall z t e r m a
+                    . t a
+                   -> RunH z t e r m a
+
+propagate :: forall e r rInitial t e' r' a
+           . Member e r
+          => e (Sem rInitial) a
+          -> Sem (RunH (Sem rInitial) t e' r' ': r) a
+propagate e = liftSem $ hoist runH $ Union (There membership) (mkWeaving e)
+{-# INLINE propagate #-}
 
 -- | Run a monadic action given by a higher-order effect that is currently
 -- being interpreted, and recursively apply the current interpreter on it.
@@ -29,6 +48,23 @@ runH :: forall z t e r r' a. z a -> Sem (RunH z t e r ': r') a
 runH = send . RunH @z @t @e @r
 {-# INLINE runH #-}
 
+liftWithH :: forall z t e r r' a
+           . ((forall x. Sem (RunH z t e r ': r) x -> Sem r (t x)) -> Sem r' a)
+          -> Sem (RunH z t e r ': r') a
+liftWithH main = send (LiftWithH main) >>= raise
+{-# INLINE liftWithH #-}
+
+withInterpreterH :: forall z t e r r' a
+                  . ((forall x. Sem (e ': r) x -> Sem r x) -> Sem (RunH z t e r ': r') a)
+                 -> Sem (RunH z t e r ': r') a
+withInterpreterH main = join $ send (WithInterpreterH @z @t main)
+
+controlH :: forall z t e r r' a
+          . ((forall x. Sem (RunH z t e r ': r) x -> Sem r (t x)) -> Sem r' (t a))
+         -> Sem (RunH z t e r ': r') a
+controlH main = liftWithH main >>= restoreH @z @t @e @r
+{-# INLINE controlH #-}
+
 -- | Run a monadic action given by a higher-order effect that is currently
 -- being interpreted.
 --
@@ -58,9 +94,9 @@ runH' z = runExposeH' z >>= raise . restoreH
 --
 -- @since TODO
 runExposeH :: forall z t e r a. z a -> Sem (RunH z t e r ': r) (t a)
-runExposeH z = do
+runExposeH z = withInterpreterH $ \n -> do
   Processor pr <- getProcessorH
-  raise (pr z)
+  raise (n (pr z))
 {-# INLINE runExposeH #-}
 
 -- | Run a monadic action given by a higher-order effect that is currently
@@ -76,7 +112,7 @@ runExposeH z = do
 -- @since TODO
 runExposeH' :: forall z t e r a. z a -> Sem (e ': RunH z t e r ': r) (t a)
 runExposeH' z = do
-  Processor pr <- raise getProcessorH'
+  Processor pr <- raise getProcessorH
   raiseUnder (pr z)
 {-# INLINE runExposeH' #-}
 
@@ -113,7 +149,6 @@ restoreH :: forall z t e r r' a. t a -> Sem (RunH z t e r ': r') a
 restoreH = send . RestoreH @z @_ @e @r
 {-# INLINE restoreH #-}
 
-
 -- | Reify the effectful state of the local effects of the argument.
 --
 -- @'runExposeH' m = 'exposeH' ('runH' m)@
@@ -123,8 +158,8 @@ restoreH = send . RestoreH @z @_ @e @r
 -- using 'runExposeH' and `runExposeH'` instead.
 --
 -- @since TODO
-exposeH :: forall z t e r r' a. Member (RunH z t e r) r' => Sem r' a -> Sem r' (t a)
-exposeH = send . ExposeH @z @_ @e @r
+exposeH :: forall z t e r a. Sem (RunH z t e r ': r) a -> Sem (RunH z t e r ': r) (t a)
+exposeH m = liftWithH $ \lower -> lower m
 {-# INLINE exposeH #-}
 
 -- | Retrieve a 'Processor': a function which can be used
@@ -134,22 +169,22 @@ exposeH = send . ExposeH @z @_ @e @r
 --
 -- The processor automatically recursively applies the current interpreter on
 -- monadic actions processed.
-getProcessorH :: forall z t e r r'. Sem (RunH z t e r ': r') (Processor z t r)
-getProcessorH = send (GetProcessorH @_ @_ @e)
+getProcessorH :: forall z t e r r'. Sem (RunH z t e r ': r') (Processor z t (e ': r))
+getProcessorH = send (WithProcessorH @_ @_ @e Processor)
 {-# INLINE getProcessorH #-}
 
 -- | Retrieve a 'Processor': a function which can be used
 -- to process a monadic action given by a higher-order effect that is currently
 -- being interpreted without immediately running it, turning it into a @'Sem' (e ': r)@ action
 -- that returns a reified effectful state.
-getProcessorH' :: forall z t e r r'. Sem (RunH z t e r ': r') (Processor z t (e ': r))
-getProcessorH' = send GetProcessorH'
-{-# INLINE getProcessorH' #-}
+-- getProcessorH' :: forall z t e r r'. Sem (RunH z t e r ': r') (Processor z t (e ': r))
+-- getProcessorH' = send GetProcessorH'
+-- {-# INLINE getProcessorH' #-}
 
 type EffHandlerH e r =
-     forall z t x
+     forall rInitial t x
    . Traversable t
-  => e z x -> Sem (RunH z t e r ': r) x
+  => e (Sem rInitial) x -> Sem (RunH (Sem rInitial) t e r ': r) x
 
 ------------------------------------------------------------------------------
 -- | Like 'interpret', but for higher-order effects (i.e. those which make use
@@ -195,47 +230,43 @@ interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
                  ex
           ) ->
       let
+          {-# SPECIALIZE INLINE commonHandler :: forall n x. Weaving (RunH z (StT t) e r) n x -> t m x #-}
+          {-# SPECIALIZE INLINE commonHandler :: forall n x. Weaving (RunH z (StT t) e r) n x -> t (Sem r) x #-}
+          commonHandler :: forall n b x. Monad b => Weaving (RunH z (StT t) e r) n x -> t b x
+          commonHandler (Weaving eff _ lwr' ex') = do
+            let run_it = fmap (ex' . (<$ mkInitState lwr'))
+            case eff of
+              RunH _ -> errorWithoutStackTrace "RunH not commonly handled"
+              WithInterpreterH main -> run_it $ return $ main $ interpretNew h
+              WithProcessorH main -> run_it $
+                liftWith $ \lower -> return $ main (lower . mkT id)
+              RestoreH t -> run_it $
+                restoreT (return t)
+              LiftWithH main -> run_it $ liftWith $ \lower -> return $
+                main (lower . go2)
+
           go1 :: forall x. Sem (RunH z (StT t) e r ': r) x -> t m x
           go1 = usingSem $ \u' -> case decomp u' of
             Left g -> liftHandlerWithNat go2 k g
-            Right (Weaving eff mkT' lwr' ex') -> do
-              let run_it = fmap (ex' . (<$ mkInitState lwr'))
+            Right wav@(Weaving eff _ lwr' ex') -> do
+              let run_it = (ex' . (<$ mkInitState lwr'))
               case eff of
-                RunH z -> run_it $
-                  mkT (usingSem k . interpretNew h) z
-                GetProcessorH -> run_it $
-                  liftWith $ \lower -> return $ Processor (lower . mkT (interpretNew h))
-                GetProcessorH' -> run_it $
-                  liftWith $ \lower -> return $ Processor (lower . mkT id)
-                RestoreH t -> run_it $
-                  restoreT (return t)
-                ExposeH m -> fmap ex' $ lwr' $ controlT $ \lower' -> do
-                  let m' = lower' (mkT' go1 m)
-                  liftWith $ \lower -> do
-                    t  <- lower m'
-                    lower' $ traverse (restoreT . return) t
+                RunH z -> run_it <$> mkT (usingSem k . interpretNew h) z
+                _      -> commonHandler wav
+          {-# INLINE go1 #-}
 
           go2 :: forall x. Sem (RunH z (StT t) e r ': r) x -> t (Sem r) x
           go2 = usingSem $ \u' -> case decomp u' of
             Left g -> liftHandlerWithNat go2 liftSem g
-            Right (Weaving eff mkT' lwr' ex') -> do
-              let run_it = fmap (ex' . (<$ mkInitState lwr'))
+            Right wav@(Weaving eff _ lwr' ex') -> do
+              let run_it = (ex' . (<$ mkInitState lwr'))
               case eff of
-                RunH z -> run_it $
-                  mkT (interpretNew h) z
-                GetProcessorH -> run_it $
-                  liftWith $ \lower -> return $ Processor (lower . mkT (interpretNew h))
-                GetProcessorH' -> run_it $
-                  liftWith $ \lower -> return $ Processor (lower . mkT id)
-                RestoreH t -> run_it $
-                  restoreT (return t)
-                ExposeH m -> fmap ex' $ lwr' $ controlT $ \lower' -> do
-                  let m' = lower' (mkT' go2 m)
-                  liftWith $ \lower -> do
-                    t  <- lower m'
-                    lower' $ traverse (restoreT . return) t
+                RunH z -> run_it <$> mkT (interpretNew h) z
+                _      -> commonHandler wav
+          {-# NOINLINE go2 #-}
       in
         fmap ex $ lwr $ go1 (h e)
+{-# INLINE interpretNew #-}
 
 -- TODO (KingoftheHomeless): If it matters, optimize the definitions
 -- below
diff --git a/src/Polysemy/Internal/Union.hs b/src/Polysemy/Internal/Union.hs
index 27e3a0b5..2ae4718b 100644
--- a/src/Polysemy/Internal/Union.hs
+++ b/src/Polysemy/Internal/Union.hs
@@ -27,6 +27,7 @@ module Polysemy.Internal.Union
   , inj
   , injUsing
   , injWeaving
+  , mkWeaving
   , weaken
 
   -- * Using Unions
@@ -358,12 +359,17 @@ weakenMid sl sm (Union pr e) = Union (injectMembership @right sl sm pr) e
 ------------------------------------------------------------------------------
 -- | Lift an effect @e@ into a 'Union' capable of holding it.
 inj :: forall e r rInitial a. Member e r => e (Sem rInitial) a -> Union r (Sem rInitial) a
-inj e = injWeaving $ Weaving
+inj = injWeaving . mkWeaving
+{-# INLINE inj #-}
+
+
+mkWeaving :: forall e rInitial a. e (Sem rInitial) a -> Weaving e (Sem rInitial) a
+mkWeaving e = Weaving
   e
   (coerce :: (Sem rInitial x -> n x) -> Sem rInitial x -> IdentityT n x)
   (fmap Identity . runIdentityT)
   runIdentity
-{-# INLINE inj #-}
+{-# INLINE mkWeaving #-}
 
 
 ------------------------------------------------------------------------------
diff --git a/src/Polysemy/Internal/WeaveClass.hs b/src/Polysemy/Internal/WeaveClass.hs
index e636540f..5c6f92e9 100644
--- a/src/Polysemy/Internal/WeaveClass.hs
+++ b/src/Polysemy/Internal/WeaveClass.hs
@@ -25,8 +25,8 @@ import qualified Control.Monad.Trans.State.Lazy as LSt
 import qualified Control.Monad.Trans.State.Strict as SSt
 import qualified Control.Monad.Trans.Writer.Lazy as LWr
 
--- | A variant of the classic @MonadTransWeave@ class from @monad-control@,
--- but with a small number of changes to make it more suitable with Polysemy's
+-- | A variant of the classic @MonadTransControl@ class from @monad-control@,
+-- but with a small number of changes to make it more suitable for Polysemy's
 -- internals.
 class ( MonadTrans t
       , forall z. Monad z => Monad (t z)
@@ -110,6 +110,8 @@ instance MonadTransWeave IdentityT where
 
   liftWith main = IdentityT (main (fmap Identity . runIdentityT))
 
+  controlT main = IdentityT (runIdentity <$> main (fmap Identity . runIdentityT))
+
   restoreT = IdentityT . fmap runIdentity
 
 instance MonadTransWeave (LSt.StateT s) where
diff --git a/src/Polysemy/Internal/Writer.hs b/src/Polysemy/Internal/Writer.hs
index c80f6ea2..bf20f26c 100644
--- a/src/Polysemy/Internal/Writer.hs
+++ b/src/Polysemy/Internal/Writer.hs
@@ -42,22 +42,17 @@ writerToEndoWriter
     => Sem (Writer o ': r) a
     -> Sem r a
 writerToEndoWriter = interpretNew $ \case
-      Tell o   -> tell (Endo (o <>))
-      Listen m -> do
-        (o, a) <- listen (runH m)
-        return (appEndo o mempty, a)
-      Pass m -> pass $ do
-        (f, a) <- runH m
-        let f' (Endo oo) = let !o' = f (oo mempty) in Endo (o' <>)
-        return (f', a)
+  Tell o   -> tell (Endo (o <>))
+  Listen m -> do
+    (o, a) <- listen (runH m)
+    return (appEndo o mempty, a)
+  Pass m -> pass $ do
+    (f, a) <- runH m
+    let f' (Endo oo) = let !o' = f (oo mempty) in Endo (o' <>)
+    return (f', a)
 {-# INLINE writerToEndoWriter #-}
 
 
--- TODO(KingoftheHomeless): Make this mess more palatable
---
--- 'interpretFinal' is too weak for our purposes, so we
--- use 'interpretH' + 'withWeavingToFinal'.
-
 ------------------------------------------------------------------------------
 -- | A variant of 'Polysemy.Writer.runWriterTVar' where an 'STM' action is
 -- used instead of a 'TVar' to commit 'tell's.
@@ -68,29 +63,27 @@ runWriterSTMAction :: forall o r a
                          -> Sem r a
 runWriterSTMAction write = interpretNew $ \case
   Tell o -> embedFinal $ atomically (write o)
-  Listen m -> do
-    -- Using 'withWeavingToFinal' instead of 'withStrategicToFinal'
-    -- here allows us to avoid using two additional 'embedFinal's in
-    -- order to create the TVars.
-    withWeavingToFinal $ \s wv _ -> mask $ \restore -> do
-      -- See below to understand how this works
-      tvar   <- newTVarIO mempty
-      switch <- newTVarIO False
-      fa     <-
-        restore (wv (runWriterSTMAction (writeListen tvar switch) (runH' m) <$ s))
-          `onException` commitListen tvar switch
-      o      <- commitListen tvar switch
-      return $ fmap (o, ) fa
-  Pass m -> do
-    withWeavingToFinal $ \s wv ins' -> mask $ \restore -> do
-      -- See below to understand how this works
-      tvar   <- newTVarIO mempty
-      switch <- newTVarIO False
-      t      <-
-        restore (wv (runWriterSTMAction (writePass tvar switch) (runH' m) <$ s))
-          `onException` commitPass tvar switch id
-      commitPass tvar switch $ maybe id fst (ins' t)
-      return $ fmap snd t
+  Listen m -> controlF $ \lower -> mask $ \restore -> do
+    -- See below to understand how this works
+    tvar   <- newTVarIO mempty
+    switch <- newTVarIO False
+    fa     <-
+        restore
+          (lower (runWriterSTMAction (writeListen tvar switch) (runH' m)))
+      `onException`
+        commitListen tvar switch
+    o      <- commitListen tvar switch
+    return $ fmap (o, ) fa
+  Pass m -> controlF $ \lower -> mask $ \restore -> do
+    -- See below to understand how this works
+    tvar   <- newTVarIO mempty
+    switch <- newTVarIO False
+    t      <-
+        restore (lower (runWriterSTMAction (writePass tvar switch) (runH' m)))
+      `onException`
+        commitPass tvar switch id
+    commitPass tvar switch $ foldr (const . fst) id t
+    return $ fmap snd t
 
   where
     {- KingoftheHomeless:
@@ -107,7 +100,7 @@ runWriterSTMAction write = interpretNew $ \case
       ('commitListen' serves only as a (likely unneeded)
       safety measure.)
 
-      'commitListen'/'commitPass' is protected by 'mask'+'onException'.
+      'commitListen''/'commitPass' is protected by 'mask'+'onException'.
       Combine this with the fact that the 'withWeavingToFinal' can't be
       interrupted by pure errors emitted by effects (since these will be
       represented as part of the functorial state), and we
diff --git a/src/Polysemy/Interpretation.hs b/src/Polysemy/Interpretation.hs
index 22437356..d5be194b 100644
--- a/src/Polysemy/Interpretation.hs
+++ b/src/Polysemy/Interpretation.hs
@@ -5,11 +5,13 @@ module Polysemy.Interpretation
   , runExposeH'
   , exposeH
   , restoreH
+  , propagate
 
   -- * Lowering Higher-Order thunks to actions of @'Sem' r@.
   , Processor(..)
+  , liftWithH
+  , controlH
   , getProcessorH
-  , getProcessorH'
   ) where
 
 import Polysemy.Internal.Interpretation
diff --git a/src/Polysemy/Law.hs b/src/Polysemy/Law.hs
index c4eb0af3..0cd12349 100644
--- a/src/Polysemy/Law.hs
+++ b/src/Polysemy/Law.hs
@@ -123,7 +123,7 @@ class MakeLaw e r where
 instance MakeLaw e '[] where
   mkLaw = Law run
 
-instance MakeLaw e '[Embed IO] where
+instance MakeLaw e '[Final IO, Embed IO] where
   mkLaw = LawIO runM
 
 
diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs
index 0d9c5aba..a4cd6f56 100644
--- a/src/Polysemy/Resource.hs
+++ b/src/Polysemy/Resource.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, NondecreasingIndentation #-}
 
 module Polysemy.Resource
   ( -- * Effect
@@ -24,7 +24,6 @@ import           Polysemy
 import           Polysemy.Final
 import           Polysemy.Interpretation
 
-
 ------------------------------------------------------------------------------
 -- | An effect capable of providing 'X.bracket' semantics. Interpreters for this
 -- will successfully run the deallocation action even in the presence of other
@@ -113,33 +112,36 @@ resourceToIOFinal :: Member (Final IO) r
                   => Sem (Resource ': r) a
                   -> Sem r a
 resourceToIOFinal = interpretFinal $ \case
-  Bracket alloc dealloc use -> do
-    a <- runS  alloc
-    d <- bindS dealloc
-    u <- bindS use
-    pure $ X.bracket a d u
-
-  BracketOnError alloc dealloc use -> do
-    ins <- getInspectorS
-    a <- runS  alloc
-    d <- bindS dealloc
-    u <- bindS use
-    pure $
-      X.bracketOnError
-        a
-        d
-        (\x -> do
-          result <- u x
-          case inspect ins result of
-            Just _ -> pure result
-            Nothing -> do
-              _ <- d x
-              pure result
-        )
+  Bracket alloc dealloc use ->
+    controlS' $ \lower -> X.mask $ \restore -> lower $ do
+      a <- runS alloc
+      tb <- liftWithS $ \lower' ->
+              restore (lower' (use a))
+            `X.onException`
+              lower' (dealloc a)
+      case traverse (const Nothing) tb of
+        Just tVoid -> do
+          _ <- runS (dealloc a)
+          restoreS tVoid
+        Nothing -> do
+          b <- restoreS tb
+          _ <- runS (dealloc a)
+          return b
 
+  BracketOnError alloc dealloc use ->
+    controlS' $ \lower -> X.mask $ \restore -> lower $ do
+      a <- runS alloc
+      tb <- liftWithS $ \lower' ->
+              restore (lower' (use a))
+            `X.onException`
+              lower' (dealloc a)
+      case traverse (const Nothing) tb of
+        Just tVoid -> do
+          _ <- runS (dealloc a)
+          restoreS tVoid
+        Nothing -> restoreS tb
 {-# INLINE resourceToIOFinal #-}
 
-
 ------------------------------------------------------------------------------
 -- | Run a 'Resource' effect in terms of 'X.bracket'.
 --
@@ -152,27 +154,31 @@ lowerResource
        -- 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
+lowerResource finish = interpretNew $ \case
+  Bracket alloc dealloc use -> controlH $ \lower ->
+    embed $ X.mask $ \restore -> do
+    tr <- finish $ lower $ runH alloc
+    case traverse (const Nothing) tr of
+      Just tVoid -> return tVoid
+      Nothing -> do
+        tu <- restore (finish $ lower $ restoreH tr >>= \r -> (,) r <$> runH (use r))
+                `X.onException` finish (lower (restoreH tr >>= runH . dealloc))
+        case traverse (const Nothing) tu of
+          Just tVoid -> tVoid <$ (finish $ lower $ restoreH tr >>= runH . dealloc)
+          Nothing -> finish $ lower $ restoreH tu >>= \(r, u) -> u <$ runH (dealloc r)
 
-    embed $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)
-{-# INLINE lowerResource #-}
+  BracketOnError alloc dealloc use -> controlH $ \lower ->
+    embed $ X.mask $ \restore -> do
+    tr <- finish $ lower $ runH $ alloc
+    case traverse (const Nothing) tr of
+      Just tVoid -> return tVoid
+      Nothing -> do
+        tu <- restore (finish $ lower $ restoreH tr >>= runH . use)
+                `X.onException` finish (lower (restoreH tr >>= runH . dealloc))
+        case traverse (const Nothing) tu of
+          Just tVoid -> tVoid <$ (finish $ lower $ restoreH tr >>= runH . dealloc)
+          Nothing    -> return tu
+{-#     INLINE lowerResource #-}
 {-# DEPRECATED lowerResource "Use 'resourceToIOFinal' instead" #-}
 
 
@@ -195,7 +201,8 @@ runResource = interpretNew $ \case
       _ <- runExposeH (dealloc r)
       restoreH ta
     else do
-    -- If "use" suceceeded, the we restore it and simply run dealloc as normal.
+      -- If "use" succeeded, then the effectful state is restored and dealloc is
+      -- run as normal.
       a <- restoreH ta
       _ <- runH (dealloc r)
       return a
diff --git a/src/Polysemy/Writer.hs b/src/Polysemy/Writer.hs
index ee5e3037..6a40ebc9 100644
--- a/src/Polysemy/Writer.hs
+++ b/src/Polysemy/Writer.hs
@@ -112,7 +112,7 @@ runLazyWriter = interpretViaLazyWriter $ \(Weaving e mkT lwr ex) ->
       let m' = lwr $ mkT id m
       Lazy.pass $ do
         ft <- m'
-        let f = maybe id fst (mkInspector ft)
+        let f = foldr (const . fst) id ft
         return (ex $ snd <$> ft, f)
 {-# INLINE runLazyWriter #-}
 

From f9c396642b7edff96761f18e783ce39ae7fe63cb Mon Sep 17 00:00:00 2001
From: Torsten Schmits <git@tryp.io>
Date: Sat, 2 Oct 2021 15:57:00 +0200
Subject: [PATCH 08/21] rebase v2 on master

---
 polysemy-plugin/test/ExampleSpec.hs |  2 +-
 src/Polysemy/Internal.hs            | 17 -----------------
 test/BracketSpec.hs                 |  9 ++++-----
 test/FinalSpec.hs                   |  4 ++--
 test/FixpointSpec.hs                |  8 ++++----
 test/LawsSpec.hs                    |  2 +-
 test/OutputSpec.hs                  |  4 ++--
 test/WriterSpec.hs                  |  8 ++++----
 8 files changed, 18 insertions(+), 36 deletions(-)

diff --git a/polysemy-plugin/test/ExampleSpec.hs b/polysemy-plugin/test/ExampleSpec.hs
index 79038544..de917442 100644
--- a/polysemy-plugin/test/ExampleSpec.hs
+++ b/polysemy-plugin/test/ExampleSpec.hs
@@ -34,7 +34,7 @@ program = catch @CustomException work $ \e -> writeTTY ("Caught " ++ show e)
 
 foo :: IO (Either CustomException ())
 foo =
-    runFinal
+    runM
   . embedToFinal @IO
   . resourceToIOFinal
   . errorToIOFinal @CustomException
diff --git a/src/Polysemy/Internal.hs b/src/Polysemy/Internal.hs
index 13e859ad..fbea0d87 100644
--- a/src/Polysemy/Internal.hs
+++ b/src/Polysemy/Internal.hs
@@ -641,23 +641,6 @@ run (Sem m) = runIdentity $ m absurdU
 {-# INLINE run #-}
 
 
-------------------------------------------------------------------------------
--- | Lower a 'Sem' containing only a single lifted 'Monad' into that
--- monad.
-runM :: Monad m => Sem '[Embed m] a -> m a
-runM (Sem m) = m $ \z ->
-  case extract z of
-    Weaving e _ lwr ex -> do
-      let s = mkInitState lwr
-      a <- unEmbed e
-      pure $ ex $ a <$ s
-{-# INLINE runM #-}
-
-type family Append l r where
-  Append (a ': l) r = a ': (Append l r)
-  Append '[] r = r
-
-
 ------------------------------------------------------------------------------
 -- | Type synonym for interpreters that consume an effect without changing the
 -- return value. Offered for user convenience.
diff --git a/test/BracketSpec.hs b/test/BracketSpec.hs
index b75109d5..4c2d4477 100644
--- a/test/BracketSpec.hs
+++ b/test/BracketSpec.hs
@@ -152,7 +152,7 @@ runTest = pure
         . runError @()
 
 runTest2
-  :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO] a
+  :: Sem '[Error (), Resource, State [Char], Trace, Output String, Final IO, Embed IO] a
   -> IO ([String], ([Char], Either () a))
 runTest2 = runM
          . ignoreOutput
@@ -162,10 +162,9 @@ runTest2 = runM
          . runError @()
 
 runTest3
-  :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO, Final IO] a
+  :: Sem '[Error (), Resource, State [Char], Trace, Output String, Final IO, Embed IO] a
   -> IO ([String], ([Char], Either () a))
-runTest3 = runFinal
-         . embedToFinal
+runTest3 = runM
          . outputToIOMonoid (:[])
          . traceToOutput
          . stateToIO ""
@@ -196,7 +195,7 @@ testAllThree name k m = do
 testTheIOTwo
     :: String
     -> (([String], ([Char], Either () a)) -> Expectation)
-    -> (Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO] a)
+    -> (Sem '[Error (), Resource, State [Char], Trace, Output String, Final IO, Embed IO] a)
     -> Spec
 testTheIOTwo name k m = do
   describe name $ do
diff --git a/test/FinalSpec.hs b/test/FinalSpec.hs
index 2249685f..4520c8ff 100644
--- a/test/FinalSpec.hs
+++ b/test/FinalSpec.hs
@@ -42,7 +42,7 @@ follow (Node _ ref) = embed $ readIORef ref
 test1 :: IO (Either Int (String, Int, Maybe Int))
 test1 = do
   ref <- newIORef "abra"
-  runFinal
+  runM
     . embedToFinal @IO
     . runStateIORef ref -- Order of these interpreters don't matter
     . errorToIOFinal
@@ -64,7 +64,7 @@ test1 = do
 
 test2 :: IO ([String], Either () ())
 test2 =
-    runFinal
+    runM
   . runTraceList
   . errorToIOFinal
   . asyncToIOFinal
diff --git a/test/FixpointSpec.hs b/test/FixpointSpec.hs
index c0e748f9..d497698c 100644
--- a/test/FixpointSpec.hs
+++ b/test/FixpointSpec.hs
@@ -31,7 +31,7 @@ runFinalState s sm = mfix $ \ ~(s', _) ->
 test1 :: (String, (Int, ()))
 test1 =
     runIdentity
-  . runFinal
+  . runM
   . fixpointToFinal @Identity
   . runOutputMonoid (show @Int)
   . runFinalState 1
@@ -45,7 +45,7 @@ test1 =
 test2 :: Either [Int] [Int]
 test2 =
     runIdentity
-  . runFinal
+  . runM
   . fixpointToFinal @Identity
   . runError
   $ mdo
@@ -55,7 +55,7 @@ test2 =
 test3 :: Either () (Int, Int)
 test3 =
     runIdentity
-  . runFinal
+  . runM
   . fixpointToFinal @Identity
   . runError
   . runLazyState @Int 1
@@ -67,7 +67,7 @@ test3 =
 test4 :: (Int, Either () Int)
 test4 =
     runIdentity
-  . runFinal
+  . runM
   . fixpointToFinal @Identity
   . runLazyState @Int 1
   . runError
diff --git a/test/LawsSpec.hs b/test/LawsSpec.hs
index 0777bc12..d6da6db1 100644
--- a/test/LawsSpec.hs
+++ b/test/LawsSpec.hs
@@ -16,5 +16,5 @@ spec = parallel $ do
       property $ prop_lawfulState @'[] $ fmap snd . runLazyState @Int 0
 
     it "stateToIO should pass the laws" $
-      property $ prop_lawfulState @'[Embed IO] $ fmap snd . stateToIO @Int 0
+      property $ prop_lawfulState @'[Final IO, Embed IO] $ fmap snd . stateToIO @Int 0
 
diff --git a/test/OutputSpec.hs b/test/OutputSpec.hs
index 0ac72fbf..ffed64d4 100644
--- a/test/OutputSpec.hs
+++ b/test/OutputSpec.hs
@@ -48,7 +48,7 @@ spec = parallel $ do
     it "should commit writes of asynced computations" $
       let io = do
             ref <- newIORef ""
-            runFinal
+            runM
               . embedToFinal @IO
               . asyncToIOFinal
               . runOutputMonoidIORef ref (show @Int)
@@ -62,7 +62,7 @@ spec = parallel $ do
     it "should commit writes of asynced computations" $
       let io = do
             ref <- newTVarIO ""
-            runFinal
+            runM
               . embedToFinal @IO
               . asyncToIOFinal
               . runOutputMonoidTVar ref (show @Int)
diff --git a/test/WriterSpec.hs b/test/WriterSpec.hs
index a72134c7..a690716f 100644
--- a/test/WriterSpec.hs
+++ b/test/WriterSpec.hs
@@ -57,7 +57,7 @@ test3 = run . runWriter $ listen (tell "and hear")
 test4 :: IO (String, String)
 test4 = do
   tvar <- newTVarIO ""
-  (listened, _) <- runFinal . asyncToIOFinal . runWriterTVar tvar $ do
+  (listened, _) <- runM . asyncToIOFinal . runWriterTVar tvar $ do
     tell "message "
     listen $ do
       tell "has been"
@@ -70,7 +70,7 @@ test5 :: IO (String, String)
 test5 = do
   tvar <- newTVarIO ""
   lock <- newEmptyMVar
-  (listened, a) <- runFinal . asyncToIOFinal . runWriterTVar tvar $ do
+  (listened, a) <- runM . asyncToIOFinal . runWriterTVar tvar $ do
     tell "message "
     listen $ do
       tell "has been"
@@ -153,8 +153,8 @@ spec = do
 
     it "should commit writes of asyncs spawned inside a listen block even if \
        \the block failed for any reason." $ do
-      Right end1 <- runFinal . errorToIOFinal $ test6
-      Right end2 <- runFinal . runError $ test6
+      Right end1 <- runM . raiseUnder . errorToIOFinal $ test6
+      Right end2 <- runM . raiseUnder . runError $ test6
       end1 `shouldBe` "message has been received"
       end2 `shouldBe` "message has been received"
 

From 54a95df7a6f6f369b2f4c22f35863ea46627904f Mon Sep 17 00:00:00 2001
From: Torsten Schmits <git@tryp.io>
Date: Sat, 2 Oct 2021 16:01:35 +0200
Subject: [PATCH 09/21] fix doctest

---
 test/TypeErrors.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/test/TypeErrors.hs b/test/TypeErrors.hs
index 06fcc8d7..24402f84 100644
--- a/test/TypeErrors.hs
+++ b/test/TypeErrors.hs
@@ -91,7 +91,7 @@ tooFewArgumentsReinterpret = ()
 -- ...
 -- ... Unhandled effect 'Embed IO'
 -- ...
--- ... Expected... Sem '[Embed m] (Bool, ())
+-- ... Expected... Sem '[Final m, Embed m] (Bool, ())
 -- ... Actual... Sem '[] (Bool, ())
 -- ...
 runningTooManyEffects = ()

From 17a6eb620694811145a0e4cdf34a5b6f4b77cadb Mon Sep 17 00:00:00 2001
From: Torsten Schmits <git@tryp.io>
Date: Sat, 2 Oct 2021 16:58:24 +0200
Subject: [PATCH 10/21] eta-expand some things for 901 subsumption

---
 src/Polysemy/Internal/Union.hs      |  4 ++--
 src/Polysemy/Internal/WeaveClass.hs | 22 ++++++++++------------
 2 files changed, 12 insertions(+), 14 deletions(-)

diff --git a/src/Polysemy/Internal/Union.hs b/src/Polysemy/Internal/Union.hs
index 2ae4718b..60b84fc1 100644
--- a/src/Polysemy/Internal/Union.hs
+++ b/src/Polysemy/Internal/Union.hs
@@ -366,7 +366,7 @@ inj = injWeaving . mkWeaving
 mkWeaving :: forall e rInitial a. e (Sem rInitial) a -> Weaving e (Sem rInitial) a
 mkWeaving e = Weaving
   e
-  (coerce :: (Sem rInitial x -> n x) -> Sem rInitial x -> IdentityT n x)
+  (\ nt -> coerce nt)
   (fmap Identity . runIdentityT)
   runIdentity
 {-# INLINE mkWeaving #-}
@@ -379,7 +379,7 @@ injUsing :: forall e r rInitial a.
   ElemOf e r -> e (Sem rInitial) a -> Union r (Sem rInitial) a
 injUsing pr e = Union pr $ Weaving
   e
-  (coerce :: (Sem rInitial x -> n x) -> Sem rInitial x -> IdentityT n x)
+  (\ nt -> coerce nt)
   (fmap Identity . runIdentityT)
   runIdentity
 {-# INLINE injUsing #-}
diff --git a/src/Polysemy/Internal/WeaveClass.hs b/src/Polysemy/Internal/WeaveClass.hs
index 5c6f92e9..d20ed1f5 100644
--- a/src/Polysemy/Internal/WeaveClass.hs
+++ b/src/Polysemy/Internal/WeaveClass.hs
@@ -12,18 +12,16 @@ module Polysemy.Internal.WeaveClass
   ) where
 
 import Control.Monad
-import Data.Coerce
-import Data.Functor.Identity
-import Data.Functor.Compose
-import Data.Tuple
 import Control.Monad.Trans
+import qualified Control.Monad.Trans.Except as E
 import Control.Monad.Trans.Identity
 import Control.Monad.Trans.Maybe
-
-import qualified Control.Monad.Trans.Except as E
 import qualified Control.Monad.Trans.State.Lazy as LSt
 import qualified Control.Monad.Trans.State.Strict as SSt
 import qualified Control.Monad.Trans.Writer.Lazy as LWr
+import Data.Functor.Compose
+import Data.Functor.Identity
+import Data.Tuple
 
 -- | A variant of the classic @MonadTransControl@ class from @monad-control@,
 -- but with a small number of changes to make it more suitable for Polysemy's
@@ -106,7 +104,7 @@ mkInspector = foldr (const . Just) Nothing
 
 instance MonadTransWeave IdentityT where
   type StT IdentityT = Identity
-  hoistT = (coerce :: (m x -> n x) -> IdentityT m x -> IdentityT n x)
+  hoistT nt = IdentityT . nt . runIdentityT
 
   liftWith main = IdentityT (main (fmap Identity . runIdentityT))
 
@@ -117,7 +115,7 @@ instance MonadTransWeave IdentityT where
 instance MonadTransWeave (LSt.StateT s) where
   type StT (LSt.StateT s) = (,) s
 
-  hoistT = LSt.mapStateT
+  hoistT nt = LSt.mapStateT nt
 
   controlT main = LSt.StateT $ \s ->
     swap <$> main (\m -> swap <$> LSt.runStateT m s)
@@ -131,7 +129,7 @@ instance MonadTransWeave (LSt.StateT s) where
 instance MonadTransWeave (SSt.StateT s) where
   type StT (SSt.StateT s) = (,) s
 
-  hoistT = SSt.mapStateT
+  hoistT nt = SSt.mapStateT nt
 
   controlT main = SSt.StateT $ \s ->
     swap <$!> main (\m -> swap <$!> SSt.runStateT m s)
@@ -145,7 +143,7 @@ instance MonadTransWeave (SSt.StateT s) where
 instance MonadTransWeave (E.ExceptT e) where
   type StT (E.ExceptT e) = Either e
 
-  hoistT = E.mapExceptT
+  hoistT nt = E.mapExceptT nt
 
   controlT main = E.ExceptT (main E.runExceptT)
 
@@ -156,7 +154,7 @@ instance MonadTransWeave (E.ExceptT e) where
 instance Monoid w => MonadTransWeave (LWr.WriterT w) where
   type StT (LWr.WriterT w) = (,) w
 
-  hoistT = LWr.mapWriterT
+  hoistT nt = LWr.mapWriterT nt
 
   controlT main = LWr.WriterT (swap <$> main (fmap swap . LWr.runWriterT))
 
@@ -168,7 +166,7 @@ instance Monoid w => MonadTransWeave (LWr.WriterT w) where
 instance MonadTransWeave MaybeT where
   type StT MaybeT = Maybe
 
-  hoistT = mapMaybeT
+  hoistT nt = mapMaybeT nt
 
   controlT main = MaybeT (main runMaybeT)
 

From 229c3d6d44d67633799d04cd4bdbafb3f0f1bb03 Mon Sep 17 00:00:00 2001
From: Torsten Schmits <git@tryp.io>
Date: Tue, 19 Oct 2021 01:00:50 +0200
Subject: [PATCH 11/21] throw out the old furniture

---
 polysemy.cabal                          |   6 +-
 src/Polysemy.hs                         |  32 +--
 src/Polysemy/Async.hs                   |   4 +-
 src/Polysemy/Error.hs                   |   4 +-
 src/Polysemy/Fixpoint.hs                |  44 ----
 src/Polysemy/Internal/Combinators.hs    | 306 +-----------------------
 src/Polysemy/Internal/Final.hs          |   2 +-
 src/Polysemy/Internal/Interpretation.hs | 165 +++++++++----
 src/Polysemy/Internal/Strategy.hs       | 130 ----------
 src/Polysemy/Internal/Tactics.hs        | 251 -------------------
 src/Polysemy/Internal/Writer.hs         |   4 +-
 src/Polysemy/Interpretation.hs          |   2 +-
 src/Polysemy/Membership.hs              |   2 +-
 src/Polysemy/NonDet.hs                  |   2 +-
 src/Polysemy/Reader.hs                  |   2 +-
 src/Polysemy/Resource.hs                |  68 +++---
 src/Polysemy/State.hs                   |  15 +-
 src/Polysemy/Writer.hs                  |   2 +-
 test/FusionSpec.hs                      |  15 +-
 test/InspectorSpec.hs                   |  77 ------
 test/TacticsSpec.hs                     |  22 --
 21 files changed, 194 insertions(+), 961 deletions(-)
 delete mode 100644 src/Polysemy/Internal/Strategy.hs
 delete mode 100644 src/Polysemy/Internal/Tactics.hs
 delete mode 100644 test/InspectorSpec.hs
 delete mode 100644 test/TacticsSpec.hs

diff --git a/polysemy.cabal b/polysemy.cabal
index eeaaad74..802f2696 100644
--- a/polysemy.cabal
+++ b/polysemy.cabal
@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: cee4a3c928927f8880db3e8eafce7ebcb55523469c67c211e8deb2b6586d79b4
+-- hash: 96f83fbb272ecfd080af174e975b37c78835a9125864a2f7eb939c5ec88856a6
 
 name:           polysemy
 version:        1.6.0.0
@@ -70,8 +70,6 @@ library
       Polysemy.Internal.Kind
       Polysemy.Internal.NonDet
       Polysemy.Internal.Sing
-      Polysemy.Internal.Strategy
-      Polysemy.Internal.Tactics
       Polysemy.Internal.TH.Common
       Polysemy.Internal.TH.Effect
       Polysemy.Internal.Union
@@ -158,12 +156,10 @@ test-suite polysemy-test
       FixpointSpec
       FusionSpec
       HigherOrderSpec
-      InspectorSpec
       InterceptSpec
       KnownRowSpec
       LawsSpec
       OutputSpec
-      TacticsSpec
       ThEffectSpec
       TypeErrors
       ViewSpec
diff --git a/src/Polysemy.hs b/src/Polysemy.hs
index ff0fc5dd..8af57790 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -109,13 +109,6 @@ module Polysemy
 
     -- * Combinators for Interpreting Higher-Order Effects
   , EffHandlerH
-  , interpretNew
-  , interceptNew
-  , reinterpretNew
-  , reinterpret2New
-  , reinterpret3New
-
-    -- * Combinators for Interpreting Higher-Order Effects using the 'Tactical' enviroment
   , interpretH
   , interceptH
   , reinterpretH
@@ -134,39 +127,19 @@ module Polysemy
   , (.@@)
 
     -- * 'RunH'
-    -- | When interpreting higher-order effects using 'interpretNew'
+    -- | When interpreting higher-order effects using 'interpretH'
     -- and friends, you can't execute higher-order \"thunks\" given by
     -- the interpreted effect directly. Instead, these must be executed
     -- using 'runH' or 'runH''.
     --
     -- These functions are enough for most purposes when using
-    -- 'interpretNew'. However, "Polysemy.Interpretation" offers
+    -- 'interpretH'. However, "Polysemy.Interpretation" offers
     -- additional, more complicated features which are occassionally
     -- needed.
   , RunH
   , runH
   , runH'
 
-    -- * Tactics
-    -- | Higher-order effects need to explicitly thread /other effects'/ state
-    -- through themselves. Tactics are a domain-specific language for describing
-    -- exactly how this threading should take place.
-    --
-    -- The first computation to be run should use 'runT', and subsequent
-    -- computations /in the same environment/ should use 'bindT'. Any
-    -- first-order constructors which appear in a higher-order context may use
-    -- 'pureT' to satisfy the typechecker.
-  , Tactical
-  , WithTactics
-  , getInitialStateT
-  , pureT
-  , runTSimple
-  , bindTSimple
-  , runT
-  , bindT
-  , getInspectorT
-  , Inspector (..)
-
   ) where
 
 import Polysemy.Final
@@ -175,5 +148,4 @@ import Polysemy.Internal.Combinators
 import Polysemy.Internal.Interpretation
 import Polysemy.Internal.Forklift
 import Polysemy.Internal.Kind
-import Polysemy.Internal.Tactics
 import Polysemy.Internal.TH.Effect
diff --git a/src/Polysemy/Async.hs b/src/Polysemy/Async.hs
index 973c9ebb..68925b7c 100644
--- a/src/Polysemy/Async.hs
+++ b/src/Polysemy/Async.hs
@@ -73,7 +73,7 @@ asyncToIO
     => Sem (Async ': r) a
     -> Sem r a
 asyncToIO m = withLowerToIO $ \lower _ -> lower $
-  interpretNew
+  interpretH
     ( \case
         Async ma -> liftWithH $ \lowerZ -> do
           fa  <- embed $ A.async $ lower $ lowerZ $ asyncToIO $ runH' ma
@@ -124,7 +124,7 @@ lowerAsync
        -- some combination of 'runM' and other interpreters composed via '.@'.
     -> Sem (Async ': r) a
     -> Sem r a
-lowerAsync lower m = interpretNew
+lowerAsync lower m = interpretH
     ( \case
         Async ma -> liftWithH $ \lowerZ -> do
           let ins = foldr (const . Just) Nothing
diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs
index eb719116..fe6ebd05 100644
--- a/src/Polysemy/Error.hs
+++ b/src/Polysemy/Error.hs
@@ -216,7 +216,7 @@ mapError
   => (e1 -> e2)
   -> Sem (Error e1 ': r) a
   -> Sem r a
-mapError f = interpretNew $ \case
+mapError f = interpretH $ \case
   Throw e -> throw $ f e
   Catch action handler ->
     runError (runH' action) >>= \case
@@ -302,7 +302,7 @@ runErrorAsExc
     => (∀ x. Sem r x -> IO x)
     -> Sem (Error e ': r) a
     -> Sem r a
-runErrorAsExc lower = interpretNew $ \case
+runErrorAsExc lower = interpretH $ \case
   Throw e -> embed $ X.throwIO $ WrappedExc e
   Catch main handle -> controlH $ \lowerZ -> do
     let runIt = lower . lowerZ . runH
diff --git a/src/Polysemy/Fixpoint.hs b/src/Polysemy/Fixpoint.hs
index aa88fd9c..7a34e354 100644
--- a/src/Polysemy/Fixpoint.hs
+++ b/src/Polysemy/Fixpoint.hs
@@ -9,7 +9,6 @@ module Polysemy.Fixpoint
   ) where
 
 import Control.Monad.Fix
-import Data.Maybe
 
 import Polysemy
 import Polysemy.Final
@@ -68,46 +67,3 @@ fixpointToFinal = interpretFinal @m $ \case
   Fixpoint f -> controlS $ \lower ->
     mfix $ lower . f . foldr const (bomb "fixpointToFinal")
 {-# 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" #-}
diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs
index 1789a063..3fb9d904 100644
--- a/src/Polysemy/Internal/Combinators.hs
+++ b/src/Polysemy/Internal/Combinators.hs
@@ -1,90 +1,24 @@
 {-# LANGUAGE AllowAmbiguousTypes   #-}
-
 {-# OPTIONS_HADDOCK not-home #-}
-
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 module Polysemy.Internal.Combinators
   ( -- * First order
-    interpret
-  , intercept
-  , reinterpret
-  , reinterpret2
-  , reinterpret3
-  , rewrite
+    rewrite
   , transform
 
-    -- * Higher order with 'Tactical'
-  , interpretH
-  , interceptH
-  , reinterpretH
-  , reinterpret2H
-  , reinterpret3H
-
-  -- * Conditional
-  , interceptUsing
-  , interceptUsingH
-
     -- * Statefulness
   , stateful
   , lazilyStateful
   ) where
 
-import           Control.Monad
+import Control.Monad
 import qualified Control.Monad.Trans.State.Lazy as LS
 import qualified Control.Monad.Trans.State.Strict as S
 import qualified Data.Tuple as S (swap)
-import           Polysemy.Internal
-import           Polysemy.Internal.CustomErrors
-import           Polysemy.Internal.Tactics
-import           Polysemy.Internal.Union
-
-firstOrder
-    :: ((forall rInitial x. e (Sem rInitial) x ->
-         Tactical e (Sem rInitial) r x) -> t)
-    -> (forall rInitial x. e (Sem rInitial) x -> Sem r x)
-    -> t
-firstOrder higher f = higher $ \(e :: e (Sem rInitial) x) ->
-  liftT $ f e
-{-# INLINE firstOrder #-}
-
-
-------------------------------------------------------------------------------
--- | The simplest way to produce an effect handler. Interprets an effect @e@ by
--- transforming it into other effects inside of @r@.
-interpret
-    :: FirstOrder e "interpret"
-    => (∀ rInitial x. e (Sem rInitial) x -> Sem r x)
-       -- ^ A natural transformation from the handled effect to other effects
-       -- already in 'Sem'.
-    -> Sem (e ': r) a
-    -> Sem r a
--- TODO(sandy): could probably give a `coerce` impl for `runTactics` here
-interpret = firstOrder interpretH
-{-# INLINE interpret #-}
 
-
-------------------------------------------------------------------------------
--- | Like 'interpret', but for higher-order effects (ie. those which make use of
--- the @m@ parameter.)
---
--- 'interpretNew' is /heavily recommended/ over this. Only use 'interpretH'
--- if you need the additional power of the 'Tactical' environment -- that is,
--- the ability to inspect and manipulate the underlying effectful state.
---
--- See the notes on 'Tactical' for how to use this function.
-interpretH
-    :: (∀ rInitial x . e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-       -- ^ A natural transformation from the handled effect to other effects
-       -- already in 'Sem'.
-    -> Sem (e ': r) a
-    -> Sem r a
-interpretH f (Sem m) = Sem $ \k -> m $ \u ->
-  case decomp u of
-    Left  x -> k $ hoist (interpretH f) x
-    Right (Weaving e mkT lwr ex) -> do
-      let s = mkInitState lwr
-          Distrib d = mkDistrib mkT lwr
-      fmap ex $ usingSem k $ runTactics s d (interpretH f . d) $ f e
-{-# INLINE interpretH #-}
+import Polysemy.Internal
+import Polysemy.Internal.CustomErrors
+import Polysemy.Internal.Union
 
 ------------------------------------------------------------------------------
 -- | A highly-performant combinator for interpreting an effect statefully. See
@@ -149,237 +83,11 @@ lazilyStateful
 lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap S.swap . f e
 {-# INLINE[3] lazilyStateful #-}
 
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret', but for higher-order effects.
---
--- 'reinterpretNew' is /heavily recommended/ over this. Only use 'reinterpretH'
--- if you need the additional power of the 'Tactical' environment -- that is,
--- the ability to inspect and manipulate the underlying effectful state.
---
--- See the notes on 'Tactical' for how to use this function.
-reinterpretH
-    :: forall e1 e2 r a
-     . (∀ rInitial x. e1 (Sem rInitial) x ->
-        Tactical e1 (Sem rInitial) (e2 ': r) x)
-       -- ^ A natural transformation from the handled effect to the new effect.
-    -> Sem (e1 ': r) a
-    -> Sem (e2 ': r) a
-reinterpretH f sem = Sem $ \k -> runSem sem $ \u ->
-  case decompCoerce u of
-    Left x  -> k $ hoist (reinterpretH f) $ x
-    Right (Weaving e mkT lwr ex) -> do
-      let s = mkInitState lwr
-          Distrib d = mkDistrib mkT lwr
-      fmap ex $ usingSem k
-              $ runTactics s (raiseUnder . d) (reinterpretH f . d)
-              $ f e
-{-# INLINE[3] reinterpretH #-}
--- TODO(sandy): Make this fuse in with 'stateful' directly.
-
-
-------------------------------------------------------------------------------
--- | Like 'interpret', but instead of removing the effect @e@, reencodes it in
--- some new effect @f@. This function will fuse when followed by
--- 'Polysemy.State.runState', meaning it's free to 'reinterpret' in terms of
--- the 'Polysemy.State.State' effect and immediately run it.
-reinterpret
-    :: forall e1 e2 r a
-     . FirstOrder e1 "reinterpret"
-    => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': r) x)
-       -- ^ A natural transformation from the handled effect to the new effect.
-    -> Sem (e1 ': r) a
-    -> Sem (e2 ': r) a
-reinterpret = firstOrder reinterpretH
-{-# INLINE[3] reinterpret #-}
--- TODO(sandy): Make this fuse in with 'stateful' directly.
-
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret2', but for higher-order effects.
---
--- 'reinterpret2New' is /heavily recommended/ over this. Only use 'reinterpret2H'
--- if you need the additional power of the 'Tactical' environment -- that is,
--- the ability to inspect and manipulate the underlying effectful state.
---
--- See the notes on 'Tactical' for how to use this function.
-reinterpret2H
-    :: forall e1 e2 e3 r a
-     . (∀ rInitial x. e1 (Sem rInitial) x ->
-        Tactical e1 (Sem rInitial) (e2 ': e3 ': r) x)
-       -- ^ A natural transformation from the handled effect to the new effects.
-    -> Sem (e1 ': r) a
-    -> Sem (e2 ': e3 ': r) a
-reinterpret2H f (Sem m) = Sem $ \k -> m $ \u ->
-  case decompCoerce u of
-    Left x  -> k $ weaken $ hoist (reinterpret2H f) $ x
-    Right (Weaving e mkT lwr ex) -> do
-      let s = mkInitState lwr
-          Distrib d = mkDistrib mkT lwr
-      fmap ex $ usingSem k
-              $ runTactics s (raiseUnder2 . d) (reinterpret2H f . d)
-              $ f e
-{-# INLINE[3] reinterpret2H #-}
-
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret', but introduces /two/ intermediary effects.
-reinterpret2
-    :: forall e1 e2 e3 r a
-     . FirstOrder e1 "reinterpret2"
-    => (∀ rInitial x. e1 (Sem rInitial) x ->
-        Sem (e2 ': e3 ': r) x)
-       -- ^ A natural transformation from the handled effect to the new effects.
-    -> Sem (e1 ': r) a
-    -> Sem (e2 ': e3 ': r) a
-reinterpret2 = firstOrder reinterpret2H
-{-# INLINE[3] reinterpret2 #-}
-
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret3', but for higher-order effects.
---
--- 'reinterpret3New' is /heavily recommended/ over this. Only use 'reinterpret3H'
--- if you need the additional power of the 'Tactical' environment -- that is,
--- the ability to inspect and manipulate the underlying effectful state.
---
--- See the notes on 'Tactical' for how to use this function.
-reinterpret3H
-    :: forall e1 e2 e3 e4 r a
-     . (∀ rInitial x. e1 (Sem rInitial) x ->
-        Tactical e1 (Sem rInitial) (e2 ': e3 ': e4 ': r) x)
-       -- ^ A natural transformation from the handled effect to the new effects.
-    -> Sem (e1 ': r) a
-    -> Sem (e2 ': e3 ': e4 ': r) a
-reinterpret3H f (Sem m) = Sem $ \k -> m $ \u ->
-  case decompCoerce u of
-    Left x  -> k . weaken . weaken . hoist (reinterpret3H f) $ x
-    Right (Weaving e mkT lwr ex) -> do
-      let s = mkInitState lwr
-          Distrib d = mkDistrib mkT lwr
-      fmap ex $ usingSem k
-              $ runTactics s (raiseUnder3 . d) (reinterpret3H f . d)
-              $ f e
-{-# INLINE[3] reinterpret3H #-}
-
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret', but introduces /three/ intermediary effects.
-reinterpret3
-    :: forall e1 e2 e3 e4 r a
-     . FirstOrder e1 "reinterpret3"
-    => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': e3 ': e4 ': r) x)
-       -- ^ A natural transformation from the handled effect to the new effects.
-    -> Sem (e1 ': r) a
-    -> Sem (e2 ': e3 ': e4 ': r) a
-reinterpret3 = firstOrder reinterpret3H
-{-# INLINE[3] reinterpret3 #-}
-
-
-------------------------------------------------------------------------------
--- | Like 'interpret', but instead of handling the effect, allows responding to
--- the effect while leaving it unhandled. This allows you, for example, to
--- intercept other effects and insert logic around them.
-intercept
-    :: ( Member e r
-       , FirstOrder e "intercept"
-       )
-    => (∀ x rInitial. e (Sem rInitial) x -> Sem r x)
-       -- ^ A natural transformation from the handled effect to other effects
-       -- already in 'Sem'.
-    -> Sem r a
-       -- ^ Unlike 'interpret', 'intercept' does not consume any effects.
-    -> Sem r a
-intercept f = interceptH $ \(e :: e (Sem rInitial) x) ->
-  liftT @(Sem rInitial) $ f e
-{-# INLINE intercept #-}
-
-
-------------------------------------------------------------------------------
--- | Like 'intercept', but for higher-order effects.
---
--- 'interceptNew' is /heavily recommended/ over this. Only use 'interceptH'
--- if you need the additional power of the 'Tactical' environment -- that is,
--- the ability to inspect and manipulate the underlying effectful state.
---
--- See the notes on 'Tactical' for how to use this function.
-interceptH
-    :: Member e r
-    => (∀ x rInitial. e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-       -- ^ A natural transformation from the handled effect to other effects
-       -- already in 'Sem'.
-    -> Sem r a
-       -- ^ Unlike 'interpretH', 'interceptH' does not consume any effects.
-    -> Sem r a
-interceptH = interceptUsingH membership
-{-# INLINE interceptH #-}
-
-------------------------------------------------------------------------------
--- | A variant of 'intercept' that accepts an explicit proof that the effect
--- is in the effect stack rather then requiring a 'Member' constraint.
---
--- This is useful in conjunction with 'Polysemy.Membership.tryMembership'
--- in order to conditionally perform 'intercept'.
---
--- @since 1.3.0.0
-interceptUsing
-    :: FirstOrder e "interceptUsing"
-    => ElemOf e r
-       -- ^ A proof that the handled effect exists in @r@.
-       -- This can be retrieved through 'Polysemy.Membership.membership' or
-       -- 'Polysemy.Membership.tryMembership'.
-    -> (∀ x rInitial. e (Sem rInitial) x -> Sem r x)
-       -- ^ A natural transformation from the handled effect to other effects
-       -- already in 'Sem'.
-    -> Sem r a
-       -- ^ Unlike 'interpret', 'intercept' does not consume any effects.
-    -> Sem r a
-interceptUsing pr f = interceptUsingH pr $ \(e :: e (Sem rInitial) x) ->
-  liftT @(Sem rInitial) $ f e
-{-# INLINE interceptUsing #-}
-
-------------------------------------------------------------------------------
--- | A variant of 'interceptH' that accepts an explicit proof that the effect
--- is in the effect stack rather then requiring a 'Member' constraint.
---
--- This is useful in conjunction with 'Polysemy.Membership.tryMembership'
--- in order to conditionally perform 'interceptH'.
---
--- 'interceptUsingNew' is /heavily recommended/ over this. Only use
--- 'interceptUsingH' if you need the additional power of the 'Tactical'
--- environment -- that is, the ability to inspect and manipulate the underlying
--- effectful state.
---
--- See the notes on 'Tactical' for how to use this function.
---
--- @since 1.3.0.0
-interceptUsingH
-    :: ElemOf e r
-       -- ^ A proof that the handled effect exists in @r@.
-       -- This can be retrieved through 'Polysemy.Membership.membership' or
-       -- 'Polysemy.Membership.tryMembership'.
-    -> (∀ x rInitial. e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-       -- ^ A natural transformation from the handled effect to other effects
-       -- already in 'Sem'.
-    -> Sem r a
-       -- ^ Unlike 'interpretH', 'interceptUsingH' does not consume any effects.
-    -> Sem r a
-interceptUsingH pr f (Sem m) = Sem $ \k -> m $ \u ->
-  case prjUsing pr u of
-    Just (Weaving e mkT lwr ex) -> do
-      let s = mkInitState lwr
-          Distrib d = mkDistrib mkT lwr
-      fmap ex $ usingSem k
-              $ runTactics s (raise . d) (interceptUsingH pr f . d)
-              $ f e
-    Nothing -> k $ hoist (interceptUsingH pr f) u
-{-# INLINE interceptUsingH #-}
-
 ------------------------------------------------------------------------------
 -- | Rewrite an effect @e1@ directly into @e2@, and put it on the top of the
 -- effect stack.
 --
--- @'rewrite' n = 'interpretNew' ('propagate' . n)@
+-- @'rewrite' n = 'interpretH' ('propagate' . n)@
 --
 -- @since 1.2.3.0
 rewrite
diff --git a/src/Polysemy/Internal/Final.hs b/src/Polysemy/Internal/Final.hs
index fb8a63c0..5890e639 100644
--- a/src/Polysemy/Internal/Final.hs
+++ b/src/Polysemy/Internal/Final.hs
@@ -44,9 +44,9 @@ module Polysemy.Internal.Final
 
 import Control.Monad.Trans
 import Polysemy.Internal
-import Polysemy.Internal.Combinators
 import Polysemy.Internal.Union
 import Polysemy.Internal.TH.Effect
+import Polysemy.Internal.Interpretation (interpret)
 
 -----------------------------------------------------------------------------
 -- | An effect for embedding higher-order actions in the final target monad
diff --git a/src/Polysemy/Internal/Interpretation.hs b/src/Polysemy/Internal/Interpretation.hs
index d94b7d65..7d30ef01 100644
--- a/src/Polysemy/Internal/Interpretation.hs
+++ b/src/Polysemy/Internal/Interpretation.hs
@@ -2,11 +2,12 @@
 {-# OPTIONS_HADDOCK not-home #-}
 module Polysemy.Internal.Interpretation where
 
-import           Control.Monad
-import           Polysemy.Internal
-import           Polysemy.Internal.WeaveClass
-import           Polysemy.Internal.Union
-import           Polysemy.Internal.Kind
+import Control.Monad
+
+import Polysemy.Internal
+import Polysemy.Internal.CustomErrors (FirstOrder)
+import Polysemy.Internal.Kind
+import Polysemy.Internal.Union
 
 
 newtype Processor z t r = Processor { getProcessor :: forall x. z x -> Sem r (t x) }
@@ -192,7 +193,7 @@ type EffHandlerH e r =
 --
 -- This is significantly easier to use than 'interpretH' and its corresponding
 -- 'Tactical' environment.
--- Because of this, 'interpretNew' and friends are /heavily recommended/ over
+-- Because of this, 'interpretH' and friends are /heavily recommended/ over
 -- 'interpretH' and friends /unless/ you need the extra power that the 'Tactical'
 -- environment provides -- the ability to inspect and manipulate the underlying
 -- effectful state.
@@ -205,7 +206,7 @@ type EffHandlerH e r =
 --   Bind :: m a -> (a -> m b) -> Bind m b
 --
 -- runBind :: Sem (Bind ': r) a -> Sem r a
--- runBind = 'interpretNew' \\case
+-- runBind = 'interpretH' \\case
 --   Bind ma f -> do
 --     a <- 'runH' ma
 --     b <- 'runH' (f a)
@@ -213,13 +214,13 @@ type EffHandlerH e r =
 -- @
 --
 -- @since TODO
-interpretNew :: forall e r a
+interpretH :: forall e r a
               . EffHandlerH e r
              -> Sem (e ': r) a
              -> Sem r a
-interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
+interpretH h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
   sem $ \u -> case decomp u of
-    Left g -> k $ hoist (interpretNew h) g
+    Left g -> k $ hoist (interpretH h) g
     Right (Weaving e
                  (mkT :: forall n x
                        . Monad n
@@ -237,7 +238,7 @@ interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
             let run_it = fmap (ex' . (<$ mkInitState lwr'))
             case eff of
               RunH _ -> errorWithoutStackTrace "RunH not commonly handled"
-              WithInterpreterH main -> run_it $ return $ main $ interpretNew h
+              WithInterpreterH main -> run_it $ return $ main $ interpretH h
               WithProcessorH main -> run_it $
                 liftWith $ \lower -> return $ main (lower . mkT id)
               RestoreH t -> run_it $
@@ -251,7 +252,7 @@ interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
             Right wav@(Weaving eff _ lwr' ex') -> do
               let run_it = (ex' . (<$ mkInitState lwr'))
               case eff of
-                RunH z -> run_it <$> mkT (usingSem k . interpretNew h) z
+                RunH z -> run_it <$> mkT (usingSem k . interpretH h) z
                 _      -> commonHandler wav
           {-# INLINE go1 #-}
 
@@ -261,12 +262,26 @@ interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
             Right wav@(Weaving eff _ lwr' ex') -> do
               let run_it = (ex' . (<$ mkInitState lwr'))
               case eff of
-                RunH z -> run_it <$> mkT (interpretNew h) z
+                RunH z -> run_it <$> mkT (interpretH h) z
                 _      -> commonHandler wav
           {-# NOINLINE go2 #-}
       in
         fmap ex $ lwr $ go1 (h e)
-{-# INLINE interpretNew #-}
+{-# INLINE interpretH #-}
+
+------------------------------------------------------------------------------
+-- | The simplest way to produce an effect handler. Interprets an effect @e@ by
+-- transforming it into other effects inside of @r@.
+--
+-- @since TODO
+interpret :: forall e r a
+              . FirstOrder e "interpret"
+             => (∀ rInitial x. e (Sem rInitial) x -> Sem r x)
+             -> Sem (e ': r) a
+             -> Sem r a
+interpret h =
+  interpretH (raise . h)
+{-# INLINE interpret #-}
 
 -- TODO (KingoftheHomeless): If it matters, optimize the definitions
 -- below
@@ -274,71 +289,133 @@ interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
 ------------------------------------------------------------------------------
 -- | Like 'reinterpret', but for higher-order effects.
 --
--- This is /heavily recommended/ over 'reinterpretH' unless you need
--- the extra power that the 'Tactical' environment provides.
---
 -- @since TODO
-reinterpretNew :: forall e1 e2 r a
+reinterpretH :: forall e1 e2 r a
                 . EffHandlerH e1 (e2 ': r)
                -> Sem (e1 ': r) a
                -> Sem (e2 ': r) a
-reinterpretNew h = interpretNew h . raiseUnder
-{-# INLINE reinterpretNew #-}
+reinterpretH h = interpretH h . raiseUnder
+{-# INLINE reinterpretH #-}
 
 ------------------------------------------------------------------------------
--- | Like 'reinterpret2', but for higher-order effects.
+-- | Like 'interpret', but instead of removing the effect @e@, reencodes it in
+-- some new effect @f@. This function will fuse when followed by
+-- 'Polysemy.State.runState', meaning it's free to 'reinterpret' in terms of
+-- the 'Polysemy.State.State' effect and immediately run it.
 --
--- This is /heavily recommended/ over 'reinterpret2H' unless you need
--- the extra power that the 'Tactical' environment provides.
+-- @since TODO
+reinterpret :: forall e1 e2 r a
+              . FirstOrder e1 "reinterpret"
+             => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': r) x)
+             -> Sem (e1 ': r) a
+             -> Sem (e2 ': r) a
+reinterpret h =
+  reinterpretH (raise . h)
+{-# INLINE reinterpret #-}
+
+------------------------------------------------------------------------------
+-- | Like 'reinterpret2', but for higher-order effects.
 --
 -- @since TODO
-reinterpret2New :: forall e1 e2 e3 r a
+reinterpret2H :: forall e1 e2 e3 r a
                  . EffHandlerH e1 (e2 ': e3 ': r)
                 -> Sem (e1 ': r) a
                 -> Sem (e2 ': e3 ': r) a
-reinterpret2New h = interpretNew h . raiseUnder2
-{-# INLINE reinterpret2New #-}
+reinterpret2H h = interpretH h . raiseUnder2
+{-# INLINE reinterpret2H #-}
 
 ------------------------------------------------------------------------------
--- | Like 'reinterpret3', but for higher-order effects.
+-- | Like 'reinterpret', but introduces /two/ intermediary effects.
 --
--- This is /heavily recommended/ over 'reinterpret3H' unless you need
--- the extra power that the 'Tactical' environment provides.
+-- @since TODO
+reinterpret2 :: forall e1 e2 e3 r a
+              . FirstOrder e1 "reinterpret2"
+             => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': e3 ': r) x)
+             -> Sem (e1 ': r) a
+             -> Sem (e2 ': e3 ': r) a
+reinterpret2 h =
+  reinterpret2H (raise . h)
+{-# INLINE reinterpret2 #-}
+
+------------------------------------------------------------------------------
+-- | Like 'reinterpret3', but for higher-order effects.
 --
 -- @since TODO
-reinterpret3New :: forall e1 e2 e3 e4 r a
+reinterpret3H :: forall e1 e2 e3 e4 r a
                  . EffHandlerH e1 (e2 ': e3 ': e4 ': r)
                 -> Sem (e1 ': r) a
                 -> Sem (e2 ': e3 ': e4 ': r) a
-reinterpret3New h = interpretNew h . raiseUnder3
-{-# INLINE reinterpret3New #-}
+reinterpret3H h = interpretH h . raiseUnder3
+{-# INLINE reinterpret3H #-}
 
 ------------------------------------------------------------------------------
--- | Like 'intercept', but for higher-order effects.
+-- | Like 'reinterpret', but introduces /three/ intermediary effects.
 --
--- This is /heavily recommended/ over 'interceptH' unless you need
--- the extra power that the 'Tactical' environment provides.
+-- @since TODO
+reinterpret3 :: forall e1 e2 e3 e4 r a
+              . FirstOrder e1 "reinterpret3"
+             => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': e3 ': e4 ': r) x)
+             -> Sem (e1 ': r) a
+             -> Sem (e2 ': e3 ': e4 ': r) a
+reinterpret3 h =
+  reinterpret3H (raise . h)
+{-# INLINE reinterpret3 #-}
+
+------------------------------------------------------------------------------
+-- | Like 'intercept', but for higher-order effects.
 --
 -- @since TODO
-interceptNew :: forall e r a
+intercept :: forall e r a
               . Member e r
              => EffHandlerH e r
              -> Sem r a
              -> Sem r a
-interceptNew h = interpretNew h . expose
-{-# INLINE interceptNew #-}
+intercept h = interpretH h . expose
+{-# INLINE intercept #-}
 
 ------------------------------------------------------------------------------
--- | Like 'interceptUsing', but for higher-order effects.
+-- | Like 'interpret', but instead of handling the effect, allows responding to
+-- the effect while leaving it unhandled. This allows you, for example, to
+-- intercept other effects and insert logic around them.
 --
--- This is /heavily recommended/ over 'interceptUsingH' unless you need
--- the extra power that the 'Tactical' environment provides.
+-- @since TODO
+interceptH :: forall e r a
+              . FirstOrder e "intercept"
+             => Member e r
+             => (∀ rInitial x. e (Sem rInitial) x -> Sem r x)
+             -> Sem r a
+             -> Sem r a
+interceptH h =
+  intercept (raise . h)
+{-# INLINE interceptH #-}
+
+------------------------------------------------------------------------------
+-- | Like 'interceptUsing', but for higher-order effects.
 --
 -- @since TODO
-interceptUsingNew :: forall e r a
+interceptUsing :: forall e r a
                    . ElemOf e r
                   -> EffHandlerH e r
                   -> Sem r a
                   -> Sem r a
-interceptUsingNew pr h = interpretNew h . exposeUsing pr
-{-# INLINE interceptUsingNew #-}
+interceptUsing pr h = interpretH h . exposeUsing pr
+{-# INLINE interceptUsing #-}
+
+------------------------------------------------------------------------------
+-- | A variant of 'intercept' that accepts an explicit proof that the effect
+-- is in the effect stack rather then requiring a 'Member' constraint.
+--
+-- This is useful in conjunction with 'Polysemy.Membership.tryMembership'
+-- in order to conditionally perform 'intercept'.
+--
+-- @since TODO
+interceptUsingH :: forall e r a .
+                     FirstOrder e "interceptUsing"
+                  => Member e r
+                  => ElemOf e r
+                  -> (∀ rInitial x. e (Sem rInitial) x -> Sem r x)
+                  -> Sem r a
+                  -> Sem r a
+interceptUsingH pr h =
+  interceptUsing pr (raise . h)
+{-# INLINE interceptUsingH #-}
diff --git a/src/Polysemy/Internal/Strategy.hs b/src/Polysemy/Internal/Strategy.hs
deleted file mode 100644
index ad2d441a..00000000
--- a/src/Polysemy/Internal/Strategy.hs
+++ /dev/null
@@ -1,130 +0,0 @@
-{-# OPTIONS_HADDOCK not-home #-}
-
-module Polysemy.Internal.Strategy where
-
-import Polysemy.Internal
-import Polysemy.Internal.Combinators
-import Polysemy.Internal.Tactics (Inspector(..))
-
-
-
-data Strategy m f n z a where
-  GetInitialState     :: Strategy m f n z (f ())
-  HoistInterpretation :: (a -> n b) -> Strategy m f n z (f a -> m (f b))
-  GetInspector        :: Strategy m f n z (Inspector f)
-
-
-------------------------------------------------------------------------------
--- | 'Strategic' is an environment in which you're capable of explicitly
--- threading higher-order effect states to the final monad.
--- This is a variant of @Tactics@ (see 'Polysemy.Tactical'), and usage
--- is extremely similar.
---
--- @since 1.2.0.0
-type Strategic m n a = forall f. Traversable f => Sem (WithStrategy m f n) (m (f a))
-
-
-------------------------------------------------------------------------------
--- | @since 1.2.0.0
-type WithStrategy m f n = '[Strategy m f n]
-
-
-------------------------------------------------------------------------------
--- | Internal function to process Strategies in terms of
--- 'Polysemy.Final.withWeavingToFinal'.
---
--- @since 1.2.0.0
-runStrategy :: Traversable f
-            => Sem '[Strategy m f n] a
-            -> f ()
-            -> (forall x. f (n x) -> m (f x))
-            -> (forall x. f x -> Maybe x)
-            -> a
-runStrategy sem = \s wv ins -> run $ interpret
-  (\case
-    GetInitialState       -> pure s
-    HoistInterpretation f -> pure $ \fa -> wv (f <$> fa)
-    GetInspector          -> pure (Inspector ins)
-  ) sem
-{-# INLINE runStrategy #-}
-
-
-------------------------------------------------------------------------------
--- | Get a natural transformation capable of potentially inspecting values
--- inside of @f@. Binding the result of 'getInspectorS' produces a function that
--- can sometimes peek inside values returned by 'bindS'.
---
--- This is often useful for running callback functions that are not managed by
--- polysemy code.
---
--- See also 'Polysemy.getInspectorT'
---
--- @since 1.2.0.0
-getInspectorS :: forall m f n. Sem (WithStrategy m f n) (Inspector f)
-getInspectorS = send (GetInspector @m @f @n)
-{-# INLINE getInspectorS #-}
-
-
-------------------------------------------------------------------------------
--- | Get the stateful environment of the world at the moment the
--- @Strategy@ is to be run.
---
--- Prefer 'pureS', 'liftS', 'runS', or 'bindS' instead of using this function
--- directly.
---
--- @since 1.2.0.0
-getInitialStateS :: forall m f n. Sem (WithStrategy m f n) (f ())
-getInitialStateS = send (GetInitialState @m @f @n)
-{-# INLINE getInitialStateS #-}
-
-
-------------------------------------------------------------------------------
--- | Embed a value into 'Strategic'.
---
--- @since 1.2.0.0
-pureS :: Applicative m => a -> Strategic m n a
-pureS a = pure . (a <$) <$> getInitialStateS
-{-# INLINE pureS #-}
-
-
-------------------------------------------------------------------------------
--- | Lifts an action of the final monad into 'Strategic'.
---
--- /Note/: you don't need to use this function if you already have a monadic
--- action with the functorial state threaded into it, by the use of
--- 'runS' or 'bindS'.
--- In these cases, you need only use 'pure' to embed the action into the
--- 'Strategic' environment.
---
--- @since 1.2.0.0
-liftS :: Functor m => m a -> Strategic m n a
-liftS m = do
-  s <- getInitialStateS
-  pure $ (<$ s) <$> m
-{-# INLINE liftS #-}
-
-
-------------------------------------------------------------------------------
--- | Lifts a monadic action into the stateful environment, in terms
--- of the final monad.
--- The stateful environment will be the same as the one that the @Strategy@
--- is initially run in.
---
--- Use 'bindS'  if you'd prefer to explicitly manage your stateful environment.
---
--- @since 1.2.0.0
-runS :: n a -> Sem (WithStrategy m f n) (m (f a))
-runS na = bindS (const na) <*> getInitialStateS
-{-# INLINE runS #-}
-
-
-------------------------------------------------------------------------------
--- | Embed a kleisli action into the stateful environment, in terms of the final
--- monad. You can use 'bindS' to get an effect parameter of the form @a -> n b@
--- into something that can be used after calling 'runS' on an effect parameter
--- @n a@.
---
--- @since 1.2.0.0
-bindS :: (a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
-bindS = send . HoistInterpretation
-{-# INLINE bindS #-}
diff --git a/src/Polysemy/Internal/Tactics.hs b/src/Polysemy/Internal/Tactics.hs
deleted file mode 100644
index 8088e95c..00000000
--- a/src/Polysemy/Internal/Tactics.hs
+++ /dev/null
@@ -1,251 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-
-{-# OPTIONS_HADDOCK not-home #-}
-
-module Polysemy.Internal.Tactics
-  ( Tactics (..)
-  , getInitialStateT
-  , getInspectorT
-  , Inspector (..)
-  , runT
-  , runTSimple
-  , bindT
-  , bindTSimple
-  , pureT
-  , liftT
-  , runTactics
-  , Tactical
-  , WithTactics
-  ) where
-
-import Polysemy.Internal
-import Polysemy.Internal.Union
-
-
-------------------------------------------------------------------------------
--- | 'Tactical' is an environment in which you're capable of explicitly
--- threading higher-order effect states. This is provided by the (internal)
--- effect @Tactics@, which is capable of rewriting monadic actions so they run
--- in the correct stateful environment.
---
--- Inside a 'Tactical', you're capable of running 'pureT', 'runT' and 'bindT'
--- which are the main tools for rewriting monadic stateful environments.
---
--- For example, consider trying to write an interpreter for
--- 'Polysemy.Resource.Resource', whose effect is defined as:
---
--- @
--- data 'Polysemy.Resource.Resource' m a where
---   'Polysemy.Resource.Bracket' :: m a -> (a -> m ()) -> (a -> m b) -> 'Polysemy.Resource.Resource' m b
--- @
---
--- Here we have an @m a@ which clearly needs to be run first, and then
--- subsequently call the @a -> m ()@ and @a -> m b@ arguments. In a 'Tactical'
--- environment, we can write the threading code thusly:
---
--- @
--- 'Polysemy.Resource.Bracket' alloc dealloc use -> do
---   alloc'   <- 'runT'  alloc
---   dealloc' <- 'bindT' dealloc
---   use'     <- 'bindT' use
--- @
---
--- where
---
--- @
--- alloc'   ::         'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f a1)
--- dealloc' :: f a1 -> 'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f ())
--- use'     :: f a1 -> 'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f x)
--- @
---
--- The @f@ type here is existential and corresponds to "whatever
--- state the other effects want to keep track of." @f@ is always
--- a 'Traversable'.
---
--- @alloc'@, @dealloc'@ and @use'@ are now in a form that can be
--- easily consumed by your interpreter. At this point, simply bind
--- them in the desired order and continue on your merry way.
---
--- We can see from the types of @dealloc'@ and @use'@ that since they both
--- consume a @f a1@, they must run in the same stateful environment. This
--- means, for illustration, any 'Polysemy.State.put's run inside the @use@
--- block will not be visible inside of the @dealloc@ block.
---
--- Power users may explicitly use 'getInitialStateT' and 'bindT' to construct
--- whatever data flow they'd like; although this is usually unnecessary.
-type Tactical e m r x = ∀ f. Traversable f
-                          => Sem (WithTactics e f m r) (f x)
-
-type WithTactics e f m r = Tactics f m (e ': r) ': r
-
-data Tactics f n r m a where
-  GetInitialState      :: Tactics f n r m (f ())
-  HoistInterpretation  :: (a -> n b) -> Tactics f n r m (f a -> Sem r (f b))
-  HoistInterpretationH :: (a -> n b) -> f a -> Tactics f n r m (f b)
-  GetInspector         :: Tactics f n r m (Inspector f)
-
-
-------------------------------------------------------------------------------
--- | Get the stateful environment of the world at the moment the effect @e@ is
--- to be run. Prefer 'pureT', 'runT' or 'bindT' instead of using this function
--- directly.
-getInitialStateT :: forall f m r e. Sem (WithTactics e f m r) (f ())
-getInitialStateT = send @(Tactics _ m (e ': r)) GetInitialState
-
-
-------------------------------------------------------------------------------
--- | Get a natural transformation capable of potentially inspecting values
--- inside of @f@. Binding the result of 'getInspectorT' produces a function that
--- can sometimes peek inside values returned by 'bindT'.
---
--- This is often useful for running callback functions that are not managed by
--- polysemy code.
---
--- ==== Example
---
--- We can use the result of 'getInspectorT' to "undo" 'pureT' (or any of the other
--- 'Tactical' functions):
---
--- @
--- ins <- 'getInspectorT'
--- fa <- 'pureT' "hello"
--- fb <- 'pureT' True
--- let a = 'inspect' ins fa   -- Just "hello"
---     b = 'inspect' ins fb   -- Just True
--- @
-getInspectorT :: forall e f m r. Sem (WithTactics e f m r) (Inspector f)
-getInspectorT = send @(Tactics _ m (e ': r)) GetInspector
-
-
-------------------------------------------------------------------------------
--- | A container for 'inspect'. See the documentation for 'getInspectorT'.
-newtype Inspector f = Inspector
-  { inspect :: forall x. f x -> Maybe x
-    -- ^ See the documentation for 'getInspectorT'.
-  }
-
-
-------------------------------------------------------------------------------
--- | Lift a value into 'Tactical'.
-pureT :: Functor f => a -> Sem (WithTactics e f m r) (f a)
-pureT a = do
-  istate <- getInitialStateT
-  pure $ a <$ istate
-
-
-------------------------------------------------------------------------------
--- | Run a monadic action in a 'Tactical' environment. The stateful environment
--- used will be the same one that the effect is initally run in. Use 'bindT' if
--- you'd prefer to explicitly manage your stateful environment.
-runT
-    :: m a
-      -- ^ The monadic action to lift. This is usually a parameter in your
-      -- effect.
-    -> Sem (WithTactics e f m r)
-                (Sem (e ': r) (f a))
-runT na = do
-  istate <- getInitialStateT
-  na'    <- bindT (const na)
-  pure $ na' istate
-{-# INLINE runT #-}
-
-------------------------------------------------------------------------------
--- | Run a monadic action in a 'Tactical' environment. The stateful environment
--- used will be the same one that the effect is initally run in.
--- Use 'bindTSimple' if you'd prefer to explicitly manage your stateful
--- environment.
---
--- This is a less flexible but significantly simpler variant of 'runT'.
--- Instead of returning a 'Sem' action corresponding to the provided action,
--- 'runTSimple' runs the action immediately.
---
--- @since 1.5.0.0
-runTSimple :: m a
-              -- ^ The monadic action to lift. This is usually a parameter in your
-              -- effect.
-           -> Tactical e m r a
-runTSimple na = do
-  istate <- getInitialStateT
-  bindTSimple (const na) istate
-{-# INLINE runTSimple #-}
-
-
-------------------------------------------------------------------------------
--- | Lift a kleisli action into the stateful environment. You can use
--- 'bindT' to get an effect parameter of the form @a -> m b@ into something
--- that can be used after calling 'runT' on an effect parameter @m a@.
-bindT
-    :: (a -> m b)
-       -- ^ The monadic continuation to lift. This is usually a parameter in
-       -- your effect.
-       --
-       -- Continuations lifted via 'bindT' will run in the same environment
-       -- which produced the @a@.
-    -> Sem (WithTactics e f m r)
-                (f a -> Sem (e ': r) (f b))
-bindT f = send $ HoistInterpretation f
-{-# INLINE bindT #-}
-
-------------------------------------------------------------------------------
--- | Lift a kleisli action into the stateful environment.
--- You can use 'bindTSimple' to execute an effect parameter of the form
--- @a -> m b@ by providing the result of a `runTSimple` or another
--- `bindTSimple`.
---
--- This is a less flexible but significantly simpler variant of 'bindT'.
--- Instead of returning a 'Sem' kleisli action corresponding to the
--- provided kleisli action, 'bindTSimple' runs the kleisli action immediately.
---
--- @since 1.5.0.0
-bindTSimple
-    :: forall m f r e a b
-     . (a -> m b)
-       -- ^ The monadic continuation to lift. This is usually a parameter in
-       -- your effect.
-       --
-       -- Continuations executed via 'bindTSimple' will run in the same
-       -- environment which produced the @a@.
-    -> f a
-    -> Sem (WithTactics e f m r) (f b)
-bindTSimple f s = send @(Tactics _ _ (e ': r)) $ HoistInterpretationH f s
-{-# INLINE bindTSimple #-}
-
-
-------------------------------------------------------------------------------
--- | Internal function to create first-order interpreter combinators out of
--- higher-order ones.
-liftT
-    :: forall m f r e a
-     . Traversable f
-    => Sem r a
-    -> Sem (WithTactics e f m r) (f a)
-liftT m = do
-  a <- raise m
-  pureT a
-{-# INLINE liftT #-}
-
-
-------------------------------------------------------------------------------
--- | Run the 'Tactics' effect.
-runTactics
-   :: Traversable f
-   => f ()
-   -> (∀ x. f (m x) -> Sem r2 (f x))
-   -> (∀ x. f (m x) -> Sem r (f x))
-   -> Sem (Tactics f m r2 ': r) a
-   -> Sem r a
-runTactics s d d' (Sem m) = Sem $ \k -> m $ \u ->
-  case decomp u of
-    Left x -> k $ hoist (runTactics s d d') x
-    Right (Weaving e _ lwr ex) -> do
-      let s' = mkInitState lwr
-      case e of
-        GetInitialState ->
-          pure $ ex $ s <$ s'
-        HoistInterpretation na ->
-          pure $ ex $ (d . fmap na) <$ s'
-        HoistInterpretationH na fa ->
-          (ex . (<$ s')) <$> runSem (d' (fmap na fa)) k
-        GetInspector ->
-          pure $ ex $ Inspector mkInspector <$ s'
-{-# INLINE runTactics #-}
diff --git a/src/Polysemy/Internal/Writer.hs b/src/Polysemy/Internal/Writer.hs
index bf20f26c..de9ef4e5 100644
--- a/src/Polysemy/Internal/Writer.hs
+++ b/src/Polysemy/Internal/Writer.hs
@@ -41,7 +41,7 @@ writerToEndoWriter
     :: (Monoid o, Member (Writer (Endo o)) r)
     => Sem (Writer o ': r) a
     -> Sem r a
-writerToEndoWriter = interpretNew $ \case
+writerToEndoWriter = interpretH $ \case
   Tell o   -> tell (Endo (o <>))
   Listen m -> do
     (o, a) <- listen (runH m)
@@ -61,7 +61,7 @@ runWriterSTMAction :: forall o r a
                          => (o -> STM ())
                          -> Sem (Writer o ': r) a
                          -> Sem r a
-runWriterSTMAction write = interpretNew $ \case
+runWriterSTMAction write = interpretH $ \case
   Tell o -> embedFinal $ atomically (write o)
   Listen m -> controlF $ \lower -> mask $ \restore -> do
     -- See below to understand how this works
diff --git a/src/Polysemy/Interpretation.hs b/src/Polysemy/Interpretation.hs
index d5be194b..b0a7900e 100644
--- a/src/Polysemy/Interpretation.hs
+++ b/src/Polysemy/Interpretation.hs
@@ -1,4 +1,4 @@
--- | Tools for more advanced usages of 'Polysemy.interpretNew'
+-- | Tools for more advanced usages of 'Polysemy.interpretH'
 module Polysemy.Interpretation
   ( -- * Manipuluating effectful state
     runExposeH
diff --git a/src/Polysemy/Membership.hs b/src/Polysemy/Membership.hs
index c5472082..a9c5b608 100644
--- a/src/Polysemy/Membership.hs
+++ b/src/Polysemy/Membership.hs
@@ -9,7 +9,7 @@ module Polysemy.Membership
   -- * Using membership
   , subsumeUsing
   , interceptUsing
-  , interceptUsingNew
+  , interceptUsing
   , interceptUsingH
   ) where
 
diff --git a/src/Polysemy/NonDet.hs b/src/Polysemy/NonDet.hs
index 24cad6c9..6795c395 100644
--- a/src/Polysemy/NonDet.hs
+++ b/src/Polysemy/NonDet.hs
@@ -59,7 +59,7 @@ nonDetToError :: Member (Error e) r
               => e
               -> Sem (NonDet ': r) a
               -> Sem r a
-nonDetToError (e :: e) = interpretNew $ \case
+nonDetToError (e :: e) = interpretH $ \case
   Empty -> throw e
   Choose left right -> do
     runH left `catch` \(_ :: e) -> runH right
diff --git a/src/Polysemy/Reader.hs b/src/Polysemy/Reader.hs
index 18829ac1..240969ef 100644
--- a/src/Polysemy/Reader.hs
+++ b/src/Polysemy/Reader.hs
@@ -37,7 +37,7 @@ asks f = f <$> ask
 ------------------------------------------------------------------------------
 -- | Run a 'Reader' effect with a constant value.
 runReader :: i -> Sem (Reader i ': r) a -> Sem r a
-runReader i = interpretNew $ \case
+runReader i = interpretH $ \case
   Ask -> return i
   Local f m -> runReader (f i) (runH' m)
 {-# INLINE runReader #-}
diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs
index a4cd6f56..8849e91b 100644
--- a/src/Polysemy/Resource.hs
+++ b/src/Polysemy/Resource.hs
@@ -154,7 +154,7 @@ lowerResource
        -- some combination of 'runM' and other interpreters composed via '.@'.
     -> Sem (Resource ': r) a
     -> Sem r a
-lowerResource finish = interpretNew $ \case
+lowerResource finish = interpretH $ \case
   Bracket alloc dealloc use -> controlH $ \lower ->
     embed $ X.mask $ \restore -> do
     tr <- finish $ lower $ runH alloc
@@ -190,7 +190,7 @@ runResource
     :: ∀ r a
      . Sem (Resource ': r) a
     -> Sem r a
-runResource = interpretNew $ \case
+runResource = interpretH $ \case
   Bracket alloc dealloc use -> do
     r  <- runH alloc
     ta <- runExposeH (use r)
@@ -239,39 +239,41 @@ resourceToIO
      . 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
+resourceToIO =
+  undefined
+  -- 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)
+  --   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
+  -- 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
-          )
+  --   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 #-}
 
diff --git a/src/Polysemy/State.hs b/src/Polysemy/State.hs
index a87ff5e8..451e44ce 100644
--- a/src/Polysemy/State.hs
+++ b/src/Polysemy/State.hs
@@ -28,14 +28,14 @@ module Polysemy.State
   , hoistStateIntoStateT
   ) where
 
-import           Control.Monad.ST
+import Control.Monad.ST
 import qualified Control.Monad.Trans.State as S
-import           Data.IORef
-import           Data.STRef
-import           Polysemy
-import           Polysemy.Internal
-import           Polysemy.Internal.Combinators
-import           Polysemy.Internal.Union
+import Data.IORef
+import Data.STRef
+import Polysemy
+import Polysemy.Internal
+import Polysemy.Internal.Combinators
+import Polysemy.Internal.Union
 
 
 ------------------------------------------------------------------------------
@@ -254,6 +254,7 @@ hoistStateIntoStateT (Sem m) = m $ \u ->
 {-# INLINE hoistStateIntoStateT #-}
 
 
+-- TODO these don't fire anymore, unless `reinterpret` is inlined later
 {-# RULES "runState/reinterpret"
    forall s e (f :: forall m x. e m x -> Sem (State s ': r) x).
      runState s (reinterpret f e) = stateful (\x s' -> runState s' $ f x) s e
diff --git a/src/Polysemy/Writer.hs b/src/Polysemy/Writer.hs
index 6a40ebc9..5d846250 100644
--- a/src/Polysemy/Writer.hs
+++ b/src/Polysemy/Writer.hs
@@ -67,7 +67,7 @@ runWriter
     :: Monoid o
     => Sem (Writer o ': r) a
     -> Sem r (o, a)
-runWriter = runState mempty . reinterpretNew
+runWriter = runState mempty . reinterpretH
   (\case
       Tell o -> modify' (<> o)
       Listen m -> do
diff --git a/test/FusionSpec.hs b/test/FusionSpec.hs
index db396d1f..9d23b4e0 100644
--- a/test/FusionSpec.hs
+++ b/test/FusionSpec.hs
@@ -15,13 +15,14 @@ module FusionSpec where
 
 import qualified Control.Monad.Trans.Except as E
 import qualified Control.Monad.Trans.State.Strict as S
-import           Polysemy.Error
-import           Polysemy.Internal
-import           Polysemy.Internal.Combinators
-import           Polysemy.Internal.Union
-import           Polysemy.State
-import           Test.Hspec
-import           Test.Inspection
+import Polysemy.Error
+import Polysemy.Internal
+import Polysemy.Internal.Combinators
+import Polysemy.Internal.Interpretation (reinterpret)
+import Polysemy.Internal.Union
+import Polysemy.State
+import Test.Hspec
+import Test.Inspection
 
 
 isSuccess :: Result -> Bool
diff --git a/test/InspectorSpec.hs b/test/InspectorSpec.hs
deleted file mode 100644
index c6df0274..00000000
--- a/test/InspectorSpec.hs
+++ /dev/null
@@ -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
-
diff --git a/test/TacticsSpec.hs b/test/TacticsSpec.hs
deleted file mode 100644
index 726be3cc..00000000
--- a/test/TacticsSpec.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module TacticsSpec where
-
-import Polysemy
-import Polysemy.Internal (send)
-import Test.Hspec
-
-data TestE :: Effect where
-  TestE :: m a -> (a -> m b) -> TestE m b
-
-interpretTestE :: InterpreterFor TestE r
-interpretTestE =
-  interpretH $ \case
-    TestE ma f -> do
-      a <- runTSimple ma
-      bindTSimple f a
-
-spec :: Spec
-spec = parallel $ describe "runTSimple and bindTSimple" $ do
-  it "should act as expected" $ do
-    r <- runM (interpretTestE (send (TestE (pure 5) (pure . (9 +)))))
-    print r
-    (14 :: Int) `shouldBe` r

From 261b17d8d80294c19c7cc7a5da57e43e80c7dd8e Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 18 Oct 2021 21:51:44 -0700
Subject: [PATCH 12/21] Remove deprecated functions

---
 src/Polysemy/Async.hs    | 24 ------------------------
 src/Polysemy/Error.hs    | 40 ----------------------------------------
 src/Polysemy/Resource.hs | 40 ----------------------------------------
 src/Polysemy/Trace.hs    | 11 -----------
 4 files changed, 115 deletions(-)

diff --git a/src/Polysemy/Async.hs b/src/Polysemy/Async.hs
index 68925b7c..b811953e 100644
--- a/src/Polysemy/Async.hs
+++ b/src/Polysemy/Async.hs
@@ -15,7 +15,6 @@ module Polysemy.Async
     -- * Interpretations
   , asyncToIO
   , asyncToIOFinal
-  , lowerAsync
   ) where
 
 import qualified Control.Concurrent.Async as A
@@ -113,26 +112,3 @@ asyncToIOFinal = interpretFinal @IO $ \case
   Cancel a -> embed (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 ma -> liftWithH $ \lowerZ -> do
-          let ins = foldr (const . Just) Nothing
-          fa  <- embed $ A.async $ lower $ lowerZ $ runH ma
-          return $ ins <$> fa
-
-        Await a -> embed (A.wait a)
-        Cancel a -> embed (A.cancel a)
-    )  m
-{-# INLINE lowerAsync #-}
-{-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}
diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs
index fe6ebd05..548f972b 100644
--- a/src/Polysemy/Error.hs
+++ b/src/Polysemy/Error.hs
@@ -23,7 +23,6 @@ module Polysemy.Error
   , runError
   , mapError
   , errorToIOFinal
-  , lowerError
   ) where
 
 import qualified Control.Exception as X
@@ -270,42 +269,3 @@ runErrorAsExcFinal = interpretFinal $ \case
       lower (h e)
 {-# 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 -> controlH $ \lowerZ -> do
-    let runIt = lower . lowerZ . runH
-    embed $ X.catch (runIt main) $ \(se :: WrappedExc e) ->
-      runIt $ handle $ unwrapExc se
-{-# INLINE runErrorAsExc #-}
diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs
index 8849e91b..d4735924 100644
--- a/src/Polysemy/Resource.hs
+++ b/src/Polysemy/Resource.hs
@@ -15,7 +15,6 @@ module Polysemy.Resource
   , runResource
   , resourceToIOFinal
   , resourceToIO
-  , lowerResource
   ) where
 
 import qualified Control.Exception as X
@@ -142,45 +141,6 @@ resourceToIOFinal = interpretFinal $ \case
         Nothing -> restoreS tb
 {-# 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 -> controlH $ \lower ->
-    embed $ X.mask $ \restore -> do
-    tr <- finish $ lower $ runH alloc
-    case traverse (const Nothing) tr of
-      Just tVoid -> return tVoid
-      Nothing -> do
-        tu <- restore (finish $ lower $ restoreH tr >>= \r -> (,) r <$> runH (use r))
-                `X.onException` finish (lower (restoreH tr >>= runH . dealloc))
-        case traverse (const Nothing) tu of
-          Just tVoid -> tVoid <$ (finish $ lower $ restoreH tr >>= runH . dealloc)
-          Nothing -> finish $ lower $ restoreH tu >>= \(r, u) -> u <$ runH (dealloc r)
-
-  BracketOnError alloc dealloc use -> controlH $ \lower ->
-    embed $ X.mask $ \restore -> do
-    tr <- finish $ lower $ runH $ alloc
-    case traverse (const Nothing) tr of
-      Just tVoid -> return tVoid
-      Nothing -> do
-        tu <- restore (finish $ lower $ restoreH tr >>= runH . use)
-                `X.onException` finish (lower (restoreH tr >>= runH . dealloc))
-        case traverse (const Nothing) tu of
-          Just tVoid -> tVoid <$ (finish $ lower $ restoreH tr >>= runH . dealloc)
-          Nothing    -> return tu
-{-#     INLINE lowerResource #-}
-{-# DEPRECATED lowerResource "Use 'resourceToIOFinal' instead" #-}
-
 
 ------------------------------------------------------------------------------
 -- | Run a 'Resource' effect purely.
diff --git a/src/Polysemy/Trace.hs b/src/Polysemy/Trace.hs
index e27b603a..a133e002 100644
--- a/src/Polysemy/Trace.hs
+++ b/src/Polysemy/Trace.hs
@@ -11,7 +11,6 @@ module Polysemy.Trace
   , traceToHandle
   , traceToStdout
   , traceToStderr
-  , traceToIO
   , runTraceList
   , ignoreTrace
   , traceToOutput
@@ -61,16 +60,6 @@ traceToStderr = traceToHandle stderr
 {-# INLINE traceToStderr #-}
 
 
-------------------------------------------------------------------------------
--- | Run a 'Trace' effect by printing the messages to stdout.
---
--- @since 1.0.0.0
-traceToIO :: Member (Embed IO) r => Sem (Trace ': r) a -> Sem r a
-traceToIO = traceToStdout
-{-# INLINE traceToIO #-}
-{-# deprecated traceToIO "Use traceToStdout" #-}
-
-
 ------------------------------------------------------------------------------
 -- | Run a 'Trace' effect by ignoring all of its messages.
 --

From 45786008db6fe0e40a191070cdc299bba91db816 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 18 Oct 2021 21:56:33 -0700
Subject: [PATCH 13/21] Remove the Forklift

---
 polysemy.cabal                    |  3 +-
 src/Polysemy.hs                   |  4 --
 src/Polysemy/Async.hs             | 37 -------------
 src/Polysemy/Error.hs             |  4 +-
 src/Polysemy/IO.hs                | 29 -----------
 src/Polysemy/Internal/Forklift.hs | 87 -------------------------------
 6 files changed, 2 insertions(+), 162 deletions(-)
 delete mode 100644 src/Polysemy/Internal/Forklift.hs

diff --git a/polysemy.cabal b/polysemy.cabal
index 802f2696..9b267e10 100644
--- a/polysemy.cabal
+++ b/polysemy.cabal
@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 96f83fbb272ecfd080af174e975b37c78835a9125864a2f7eb939c5ec88856a6
+-- hash: 00fd0e64910f1fddf88d384ff8631fc6c9d733b32ea93654a58c1ba383795e9a
 
 name:           polysemy
 version:        1.6.0.0
@@ -64,7 +64,6 @@ library
       Polysemy.Internal.CustomErrors.Redefined
       Polysemy.Internal.Final
       Polysemy.Internal.Fixpoint
-      Polysemy.Internal.Forklift
       Polysemy.Internal.Index
       Polysemy.Internal.Interpretation
       Polysemy.Internal.Kind
diff --git a/src/Polysemy.hs b/src/Polysemy.hs
index 8af57790..6d9929e9 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -115,9 +115,6 @@ module Polysemy
   , reinterpret2H
   , reinterpret3H
 
-    -- * Combinators for Interpreting Directly to IO
-  , withLowerToIO
-
     -- * Kind Synonyms
   , Effect
   , EffectRow
@@ -146,6 +143,5 @@ import Polysemy.Final
 import Polysemy.Internal
 import Polysemy.Internal.Combinators
 import Polysemy.Internal.Interpretation
-import Polysemy.Internal.Forklift
 import Polysemy.Internal.Kind
 import Polysemy.Internal.TH.Effect
diff --git a/src/Polysemy/Async.hs b/src/Polysemy/Async.hs
index b811953e..b2064b7d 100644
--- a/src/Polysemy/Async.hs
+++ b/src/Polysemy/Async.hs
@@ -13,14 +13,12 @@ module Polysemy.Async
   , sequenceConcurrently
 
     -- * Interpretations
-  , asyncToIO
   , asyncToIOFinal
   ) where
 
 import qualified Control.Concurrent.Async as A
 import           Polysemy
 import           Polysemy.Final
-import           Polysemy.Interpretation
 
 
 
@@ -48,41 +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 ma -> liftWithH $ \lowerZ -> do
-          fa  <- embed $ A.async $ lower $ lowerZ $ asyncToIO $ runH' ma
-          let ins = foldr (const . Just) Nothing
-          return (fmap ins fa)
-
-        Await a -> embed (A.wait a)
-        Cancel a -> embed (A.cancel a)
-    )  m
-{-# INLINE asyncToIO #-}
 
 ------------------------------------------------------------------------------
 -- | Run an 'Async' effect in terms of 'A.async' through final 'IO'.
diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs
index 548f972b..d3e8faa6 100644
--- a/src/Polysemy/Error.hs
+++ b/src/Polysemy/Error.hs
@@ -28,11 +28,9 @@ module Polysemy.Error
 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
-import           Polysemy.Interpretation
 import           Polysemy.Internal
 import           Polysemy.Internal.Union
 
@@ -224,7 +222,7 @@ mapError f = interpretH $ \case
 {-# INLINE mapError #-}
 
 
-newtype WrappedExc e = WrappedExc { unwrapExc :: e }
+newtype WrappedExc e = WrappedExc { _unwrapExc :: e }
   deriving (Typeable)
 
 instance Typeable e => Show (WrappedExc e) where
diff --git a/src/Polysemy/IO.hs b/src/Polysemy/IO.hs
index bac7486c..f3f9928c 100644
--- a/src/Polysemy/IO.hs
+++ b/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) _ lwr ex) ->
-        ex <$> ((<$ mkInitState lwr) <$> wd)
diff --git a/src/Polysemy/Internal/Forklift.hs b/src/Polysemy/Internal/Forklift.hs
deleted file mode 100644
index 52bc15c0..00000000
--- a/src/Polysemy/Internal/Forklift.hs
+++ /dev/null
@@ -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) _ lwr ex) ->
-      ex . (<$ mkInitState lwr) <$> 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
-

From 52d2924c488d4ae0e78d24a04f9c90378a69aefc Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 18 Oct 2021 21:58:52 -0700
Subject: [PATCH 14/21] Remove Law

---
 polysemy.cabal            |   5 +-
 src/Polysemy/Law.hs       | 197 --------------------------------------
 src/Polysemy/State/Law.hs |  59 ------------
 test/LawsSpec.hs          |  20 ----
 4 files changed, 1 insertion(+), 280 deletions(-)
 delete mode 100644 src/Polysemy/Law.hs
 delete mode 100644 src/Polysemy/State/Law.hs
 delete mode 100644 test/LawsSpec.hs

diff --git a/polysemy.cabal b/polysemy.cabal
index 9b267e10..22d45a4f 100644
--- a/polysemy.cabal
+++ b/polysemy.cabal
@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 00fd0e64910f1fddf88d384ff8631fc6c9d733b32ea93654a58c1ba383795e9a
+-- hash: d3d109d81dd162ae3d66420b1be680c03ff6472012cc5308b1e108839910a801
 
 name:           polysemy
 version:        1.6.0.0
@@ -76,14 +76,12 @@ library
       Polysemy.Internal.Writer
       Polysemy.Interpretation
       Polysemy.IO
-      Polysemy.Law
       Polysemy.Membership
       Polysemy.NonDet
       Polysemy.Output
       Polysemy.Reader
       Polysemy.Resource
       Polysemy.State
-      Polysemy.State.Law
       Polysemy.Tagged
       Polysemy.Trace
       Polysemy.View
@@ -157,7 +155,6 @@ test-suite polysemy-test
       HigherOrderSpec
       InterceptSpec
       KnownRowSpec
-      LawsSpec
       OutputSpec
       ThEffectSpec
       TypeErrors
diff --git a/src/Polysemy/Law.hs b/src/Polysemy/Law.hs
deleted file mode 100644
index 0cd12349..00000000
--- a/src/Polysemy/Law.hs
+++ /dev/null
@@ -1,197 +0,0 @@
-{-# LANGUAGE CPP                    #-}
-{-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE UndecidableInstances   #-}
-
-#if __GLASGOW_HASKELL__ < 806
--- There is a bug in older versions of Haddock that don't allow documentation
--- on GADT arguments.
-#define HADDOCK --
-#else
-#define HADDOCK -- ^
-#endif
-
-module Polysemy.Law
-  ( Law (..)
-  , runLaw
-  , MakeLaw (..)
-  , Citizen (..)
-  , printf
-  , module Test.QuickCheck
-  ) where
-
-import Control.Arrow (first)
-import Data.Char
-import Polysemy
-import Test.QuickCheck
-
-
-------------------------------------------------------------------------------
--- | Associates the name @r@ with the eventual type @a@. For example,
--- @'Citizen' (String -> Bool) Bool@ can produce arbitrary @Bool@s by calling
--- the given function with arbitrary @String@s.
-class Citizen r a | r -> a where
-  -- | Generate two @a@s via two @r@s. Additionally, produce a list of strings
-  -- corresponding to any arbitrary arguments we needed to build.
-  getCitizen :: r -> r -> Gen ([String], (a, a))
-
-instance {-# OVERLAPPING #-} Citizen (Sem r a -> b) (Sem r a -> b) where
-  getCitizen r1 r2 = pure ([], (r1, r2))
-
-instance Citizen (Sem r a) (Sem r a) where
-  getCitizen r1 r2 = pure ([], (r1, r2))
-
-instance (Arbitrary a, Show a, Citizen b r) => Citizen (a -> b) r where
-  getCitizen f1 f2 = do
-    a <- arbitrary
-    first (show a :) <$> getCitizen (f1 a) (f2 a)
-
-
-------------------------------------------------------------------------------
--- | A law that effect @e@ must satisfy whenever it is in environment @r@. You
--- can use 'runLaw' to transform these 'Law's into QuickCheck-able 'Property's.
-data Law e r where
-  -- | A pure 'Law', that doesn't require any access to 'IO'.
-  Law
-      :: ( Eq a
-         , Show a
-         , Citizen i12n (Sem r x -> a)
-         , Citizen res (Sem (e ': r) x)
-         )
-      => i12n
-         HADDOCK An interpretation from @'Sem' r x@ down to a pure value. This is
-         -- likely 'run'.
-      -> String
-         HADDOCK A string representation of the left-hand of the rule. This is
-         -- a formatted string, for more details, refer to 'printf'.
-      -> res
-         HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@,
-         -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this
-         -- is a function type, it's guaranteed to be called with the same
-         -- arguments that the right-handed side was called with.
-      -> String
-         HADDOCK A string representation of the right-hand of the rule. This is
-         -- a formatted string, for more details, refer to 'printf'.
-      -> res
-         HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@,
-         -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this
-         -- is a function type, it's guaranteed to be called with the same
-         -- arguments that the left-handed side was called with.
-      -> Law e r
-  -- | Like 'Law', but for 'IO'-accessing effects.
-  LawIO
-      :: ( Eq a
-         , Show a
-         , Citizen i12n (Sem r x -> IO a)
-         , Citizen res (Sem (e ': r) x)
-         )
-      => i12n
-         HADDOCK An interpretation from @'Sem' r x@ down to an 'IO' value. This is
-         -- likely 'runM'.
-      -> String
-         HADDOCK A string representation of the left-hand of the rule. This is
-         -- a formatted string, for more details, refer to 'printf'.
-      -> res
-         HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@,
-         -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this
-         -- is a function type, it's guaranteed to be called with the same
-         -- arguments that the right-handed side was called with.
-      -> String
-         HADDOCK A string representation of the right-hand of the rule. This is
-         -- a formatted string, for more details, refer to 'printf'.
-      -> res
-         HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@,
-         -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this
-         -- is a function type, it's guaranteed to be called with the same
-         -- arguments that the left-handed side was called with.
-      -> Law e r
-
-
-------------------------------------------------------------------------------
--- | A typeclass that provides the smart constructor 'mkLaw'.
-class MakeLaw e r where
-  -- | A smart constructor for building 'Law's.
-  mkLaw
-      :: (Eq a, Show a, Citizen res (Sem (e ': r) a))
-      => String
-      -> res
-      -> String
-      -> res
-      -> Law e r
-
-instance MakeLaw e '[] where
-  mkLaw = Law run
-
-instance MakeLaw e '[Final IO, Embed IO] where
-  mkLaw = LawIO runM
-
-
-------------------------------------------------------------------------------
--- | Produces a QuickCheck-able 'Property' corresponding to whether the given
--- interpreter satisfies the 'Law'.
-runLaw :: InterpreterFor e r -> Law e r -> Property
-runLaw i12n (Law finish str1 a str2 b) = property $ do
-  (_, (lower, _)) <- getCitizen finish finish
-  (args, (ma, mb)) <- getCitizen a b
-  let run_it = lower . i12n
-      a' = run_it ma
-      b' = run_it mb
-  pure $
-    counterexample
-      (mkCounterexampleString str1 a' str2 b' args)
-      (a' == b')
-runLaw i12n (LawIO finish str1 a str2 b) = property $ do
-  (_, (lower, _)) <- getCitizen finish finish
-  (args, (ma, mb)) <- getCitizen a b
-  let run_it = lower . i12n
-  pure $ ioProperty $ do
-    a' <- run_it ma
-    b' <- run_it mb
-    pure $
-      counterexample
-        (mkCounterexampleString str1 a' str2 b' args)
-        (a' == b')
-
-
-------------------------------------------------------------------------------
--- | Make a string representation for a failing 'runLaw' property.
-mkCounterexampleString
-    :: Show a
-    => String
-    -> a
-    -> String
-    -> a
-    -> [String]
-    -> String
-mkCounterexampleString str1 a str2 b args =
-  mconcat
-    [ printf str1 args , " (result: " , show a , ")\n /= \n"
-    , printf str2 args , " (result: " , show b , ")"
-    ]
-
-
-------------------------------------------------------------------------------
--- | A bare-boned implementation of printf. This function will replace tokens
--- of the form @"%n"@ in the first string with @args !! n@.
---
--- This will only work for indexes up to 9.
---
--- For example:
---
--- >>> printf "hello %1 %2% %3 %1" ["world", "50"]
--- "hello world 50% %3 world"
-printf :: String -> [String] -> String
-printf str args = splitArgs str
-  where
-    splitArgs :: String -> String
-    splitArgs s =
-      case break (== '%') s of
-        (as, "") -> as
-        (as, _ : b : bs)
-          | isDigit b
-          , let d = read [b] - 1
-          , d < length args
-            -> as ++ (args !! d) ++ splitArgs bs
-        (as, _ : bs) ->  as ++ "%" ++ splitArgs bs
-
diff --git a/src/Polysemy/State/Law.hs b/src/Polysemy/State/Law.hs
deleted file mode 100644
index 8f8d90dc..00000000
--- a/src/Polysemy/State/Law.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-
-module Polysemy.State.Law where
-
-import Polysemy
-import Polysemy.Law
-import Polysemy.State
-import Control.Applicative
-import Control.Arrow
-
-
-------------------------------------------------------------------------------
--- | A collection of laws that show a `State` interpreter is correct.
-prop_lawfulState
-    :: forall r s
-     . (Eq s, Show s, Arbitrary s, MakeLaw (State s) r)
-    => InterpreterFor (State s) r
-    -> Property
-prop_lawfulState i12n = conjoin
-  [ runLaw i12n law_putTwice
-  , runLaw i12n law_getTwice
-  , runLaw i12n law_getPutGet
-  ]
-
-
-law_putTwice
-    :: forall s r
-     . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)
-    => Law (State s) r
-law_putTwice =
-  mkLaw
-    "put %1 >> put %2 >> get"
-    (\s s' -> put @s s >> put @s s' >> get @s)
-    "put %2 >> get"
-    (\_ s' ->             put @s s' >> get @s)
-
-law_getTwice
-    :: forall s r
-     . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)
-    => Law (State s) r
-law_getTwice =
-  mkLaw
-    "liftA2 (,) get get"
-    (liftA2 (,) (get @s) (get @s))
-    "(id &&& id) <$> get"
-    ((id &&& id) <$> get @s)
-
-law_getPutGet
-    :: forall s r
-     . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)
-    => Law (State s) r
-law_getPutGet =
-  mkLaw
-    "get >>= put >> get"
-    (get @s >>= put @s >> get @s)
-    "get"
-    (get @s)
-
diff --git a/test/LawsSpec.hs b/test/LawsSpec.hs
deleted file mode 100644
index d6da6db1..00000000
--- a/test/LawsSpec.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module LawsSpec where
-
-import Polysemy
-import Polysemy.Law
-import Polysemy.State
-import Polysemy.State.Law
-import Test.Hspec
-
-spec :: Spec
-spec = parallel $ do
-  describe "State effects" $ do
-    it "runState should pass the laws" $
-      property $ prop_lawfulState @'[] $ fmap snd . runState @Int 0
-
-    it "runLazyState should pass the laws" $
-      property $ prop_lawfulState @'[] $ fmap snd . runLazyState @Int 0
-
-    it "stateToIO should pass the laws" $
-      property $ prop_lawfulState @'[Final IO, Embed IO] $ fmap snd . stateToIO @Int 0
-

From b3ebc4ffec5ee0da4a238bceecfe8a5ee06cc7a8 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 18 Oct 2021 22:01:39 -0700
Subject: [PATCH 15/21] Remove View

---
 polysemy.cabal       |  4 +--
 src/Polysemy/View.hs | 76 --------------------------------------------
 test/ViewSpec.hs     | 40 -----------------------
 3 files changed, 1 insertion(+), 119 deletions(-)
 delete mode 100644 src/Polysemy/View.hs
 delete mode 100644 test/ViewSpec.hs

diff --git a/polysemy.cabal b/polysemy.cabal
index 22d45a4f..563d60d8 100644
--- a/polysemy.cabal
+++ b/polysemy.cabal
@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: d3d109d81dd162ae3d66420b1be680c03ff6472012cc5308b1e108839910a801
+-- hash: c02e0285aee0795d2219f823c60e1b8b166e82403fe8a877f8b25cdce69a5785
 
 name:           polysemy
 version:        1.6.0.0
@@ -84,7 +84,6 @@ library
       Polysemy.State
       Polysemy.Tagged
       Polysemy.Trace
-      Polysemy.View
       Polysemy.Writer
   other-modules:
       Polysemy.Internal.PluginLookup
@@ -158,7 +157,6 @@ test-suite polysemy-test
       OutputSpec
       ThEffectSpec
       TypeErrors
-      ViewSpec
       WriterSpec
       Paths_polysemy
       Build_doctests
diff --git a/src/Polysemy/View.hs b/src/Polysemy/View.hs
deleted file mode 100644
index 6e86acc1..00000000
--- a/src/Polysemy/View.hs
+++ /dev/null
@@ -1,76 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module Polysemy.View
-  ( -- * Effect
-    View (..)
-
-    -- * Actions
-  , see
-
-    -- * Interpretations
-  , viewToState
-  , viewToInput
-  ) where
-
-import Polysemy
-import Polysemy.Input
-import Polysemy.State
-import Polysemy.Tagged
-
-
-------------------------------------------------------------------------------
--- | A 'View' is an expensive computation that should be cached.
-data View v m a where
-  See :: View v m v
-
-makeSem ''View
-
-
-------------------------------------------------------------------------------
--- | Transform a 'View' into an 'Input'.
-viewToInput
-    :: forall v i r a
-     . Member (Input i) r
-    => (i -> v)
-    -> Sem (View v ': r) a
-    -> Sem r a
-viewToInput f = interpret $ \case
-  See -> f <$> input
-
-
-------------------------------------------------------------------------------
--- | Get a 'View' as an exensive computation over an underlying 'State' effect.
--- This 'View' is only invalidated when the underlying 'State' changes.
-viewToState
-    :: forall v s r a
-     . Member (State s) r
-    => (s -> Sem r v)
-    -> Sem (View v ': r) a
-    -> Sem r a
-viewToState f = do
-  evalState Dirty
-    . untag @"view" @(State (Cached v))
-    . intercept @(State s)
-      ( \case
-        Get -> get
-        Put s -> do
-          put s
-          tag @"view" @(State (Cached v)) $ put $ Dirty @v
-      )
-    . reinterpret @(View v)
-      ( \case
-          See -> do
-            dirty <- tagged @"view" $ get @(Cached v)
-            case dirty of
-              Dirty -> do
-                s <- get
-                v' <- raise $ f s
-                tagged @"view" $ put $ Cached v'
-                pure v'
-              Cached v -> pure v
-      )
-
-
-data Cached a = Cached a | Dirty
-  deriving (Eq, Ord, Show, Functor)
-
diff --git a/test/ViewSpec.hs b/test/ViewSpec.hs
deleted file mode 100644
index 61baaecf..00000000
--- a/test/ViewSpec.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-module ViewSpec where
-
-import Polysemy
-import Polysemy.State
-import Polysemy.Trace
-import Polysemy.View
-import Test.Hspec
-
-
-check_see :: Members '[View String, Trace] r => Sem r ()
-check_see = trace . ("saw " ++) =<< see
-
-spec :: Spec
-spec = parallel $ do
-  describe "View effect" $ do
-    it "should cache views" $ do
-      let a = run
-            . runTraceList
-            . runState @Int 0
-            . viewToState @String @Int (\i -> do
-                  trace $ "caching "  ++ show i
-                  pure $ show i  ) $ do
-              check_see
-              check_see
-              put @Int 3
-              trace "it's lazy"
-              put @Int 5
-              check_see
-              check_see
-              get @Int
-
-      a `shouldBe` ([ "caching 0"
-                    , "saw 0"
-                    , "saw 0"
-                    , "it's lazy"
-                    , "caching 5"
-                    , "saw 5"
-                    , "saw 5"
-                    ], (5, 5))
-

From 339eea1133e3d5d957e0d797342b2052785d3181 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 18 Oct 2021 22:01:45 -0700
Subject: [PATCH 16/21] Fix AsyncSpec

---
 test/AsyncSpec.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/test/AsyncSpec.hs b/test/AsyncSpec.hs
index a70dd2e8..ce8386e2 100644
--- a/test/AsyncSpec.hs
+++ b/test/AsyncSpec.hs
@@ -17,7 +17,7 @@ spec = describe "async" $ do
     (ts, (s, r)) <- runM
                   . runTraceList
                   . runState "hello"
-                  . asyncToIO $ do
+                  . asyncToIOFinal $ do
       let message :: Member Trace r => Int -> String -> Sem r ()
           message n msg = trace $ mconcat
             [ show n, "> ", msg ]

From 275e11990fef57e465e860f73abb8a66ed7ebc1b Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 18 Oct 2021 22:19:32 -0700
Subject: [PATCH 17/21] Warning about Polysemy.Reader

---
 src/Polysemy/Reader.hs | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/src/Polysemy/Reader.hs b/src/Polysemy/Reader.hs
index 240969ef..5e5e0fb0 100644
--- a/src/Polysemy/Reader.hs
+++ b/src/Polysemy/Reader.hs
@@ -21,7 +21,15 @@ import Polysemy.Input
 
 
 ------------------------------------------------------------------------------
--- | An effect corresponding to 'Control.Monad.Trans.Reader.ReaderT'.
+-- | The Polysemy port of 'Control.Monad.Trans.Reader.ReaderT'.
+-- __Note that this is probably not the effect you are looking for.__ You
+-- probably want 'Polysemy.Input.Input' instead, which is like 'Reader' but
+-- without 'local'.
+--
+-- If you are trying to emulate anything akin to the @ReaderT IO@ pattern, note
+-- that it is /not recommended/ in Polysemy. Instead, your experience will be
+-- much more joyful if you avoid @IO@ entirely and think deeply about the
+-- lawful chunks of your program that can be turned into effects.
 data Reader i m a where
   Ask   :: Reader i m i
   Local :: (i -> i) -> m a -> Reader i m a

From 86e05a6f34419ecd8d1de606c2f495278781cd0a Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 18 Oct 2021 22:42:00 -0700
Subject: [PATCH 18/21] Add Fatal

---
 src/Polysemy/Fatal.hs | 224 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 224 insertions(+)
 create mode 100644 src/Polysemy/Fatal.hs

diff --git a/src/Polysemy/Fatal.hs b/src/Polysemy/Fatal.hs
new file mode 100644
index 00000000..592710a2
--- /dev/null
+++ b/src/Polysemy/Fatal.hs
@@ -0,0 +1,224 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TemplateHaskell     #-}
+
+module Polysemy.Fatal
+  ( -- * Effect
+    Fatal (..)
+
+    -- * Actions
+  , fatal
+  , fatalFromEither
+  , fatalFromEitherM
+  , fatalFromException
+  , fatalFromExceptionVia
+  , fatalFromExceptionSem
+  , fatalFromExceptionSemVia
+  , noteFatal
+
+    -- * Interpretations
+  , runFatal
+  , mapFatal
+  , fatalToError
+  , fatalToIOFinal
+  ) where
+
+import qualified Control.Exception as X
+import           Control.Monad
+import qualified Control.Monad.Trans.Except as E
+import           Data.Typeable
+import           Polysemy
+import           Polysemy.Error
+import           Polysemy.Final
+import           Polysemy.Internal
+import           Polysemy.Internal.Union
+
+
+data Fatal e m a where
+  Fatal :: e -> Fatal e m a
+
+makeSem ''Fatal
+
+------------------------------------------------------------------------------
+-- | Upgrade an 'Either' into an 'Fatal' effect.
+--
+-- @since 0.5.1.0
+fatalFromEither
+    :: Member (Fatal e) r
+    => Either e a
+    -> Sem r a
+fatalFromEither (Left e) = fatal e
+fatalFromEither (Right a) = pure a
+{-# INLINABLE fatalFromEither #-}
+
+------------------------------------------------------------------------------
+-- | A combinator doing 'embed' and 'fromEither' at the same time. Useful for
+-- interoperating with 'IO'.
+--
+-- @since 0.5.1.0
+fatalFromEitherM
+    :: forall e m r a
+     . ( Member (Fatal e) r
+       , Member (Embed m) r
+       )
+    => m (Either e a)
+    -> Sem r a
+fatalFromEitherM = fatalFromEither <=< embed
+{-# INLINABLE fatalFromEitherM #-}
+
+
+------------------------------------------------------------------------------
+-- | Lift an exception generated from an 'IO' action into an 'Fatal'.
+fatalFromException
+    :: forall e r a
+     . ( X.Exception e
+       , Member (Fatal e) r
+       , Member (Embed IO) r
+       )
+    => IO a
+    -> Sem r a
+fatalFromException = fatalFromExceptionVia @e id
+{-# INLINABLE fatalFromException #-}
+
+
+------------------------------------------------------------------------------
+-- | Like 'fromException', but with the ability to transform the exception
+-- before turning it into an 'Fatal'.
+fatalFromExceptionVia
+    :: ( X.Exception exc
+       , Member (Fatal err) r
+       , Member (Embed IO) r
+       )
+    => (exc -> err)
+    -> IO a
+    -> Sem r a
+fatalFromExceptionVia f m = do
+  r <- embed $ X.try m
+  case r of
+    Left e -> fatal $ f e
+    Right a -> pure a
+{-# INLINABLE fatalFromExceptionVia #-}
+
+------------------------------------------------------------------------------
+-- | Run a @Sem r@ action, converting any 'IO' exception generated by it into an 'Fatal'.
+fatalFromExceptionSem
+    :: forall e r a
+     . ( X.Exception e
+       , Member (Fatal e) r
+       , Member (Final IO) r
+       )
+    => Sem r a
+    -> Sem r a
+fatalFromExceptionSem = fatalFromExceptionSemVia @e id
+{-# INLINABLE fatalFromExceptionSem #-}
+
+
+------------------------------------------------------------------------------
+-- | Like 'fromExceptionSem', but with the ability to transform the exception
+-- before turning it into an 'Fatal'.
+fatalFromExceptionSemVia
+    :: ( X.Exception exc
+       , Member (Fatal err) r
+       , Member (Final IO) r
+       )
+    => (exc -> err)
+    -> Sem r a
+    -> Sem r a
+fatalFromExceptionSemVia f m = do
+  r <- controlF $ \lower ->
+    lower (fmap Right m) `X.catch` (lower . return . Left)
+  case r of
+    Left e -> fatal $ f e
+    Right a -> pure a
+{-# INLINABLE fatalFromExceptionSemVia #-}
+
+
+------------------------------------------------------------------------------
+-- | Attempt to extract a @'Just' a@ from a @'Maybe' a@, throwing the
+-- provided exception upon 'Nothing'.
+noteFatal :: Member (Fatal e) r => e -> Maybe a -> Sem r a
+noteFatal e Nothing  = fatal e
+noteFatal _ (Just a) = pure a
+{-# INLINABLE noteFatal #-}
+
+
+------------------------------------------------------------------------------
+-- | Run an 'Fatal' effect in the style of
+-- 'Control.Monad.Trans.Except.ExceptT'.
+runFatal
+    :: Sem (Fatal e ': r) a
+    -> Sem r (Either e a)
+runFatal (Sem m) = Sem $ \k -> E.runExceptT $ m $ \u ->
+  case decomp u of
+    Left x ->
+      liftHandlerWithNat (E.ExceptT . runFatal) k x
+    Right (Weaving (Fatal e) _ _ _) -> E.throwE e
+{-# INLINE runFatal #-}
+
+
+------------------------------------------------------------------------------
+-- | Transform one 'Fatal' into another. This function can be used to aggregate
+-- multiple fatals into a single type.
+--
+-- @since 1.0.0.0
+mapFatal
+  :: forall e1 e2 r a
+   . Member (Fatal e2) r
+  => (e1 -> e2)
+  -> Sem (Fatal e1 ': r) a
+  -> Sem r a
+mapFatal f = interpret $ \case
+  Fatal e -> fatal $ f e
+{-# INLINE mapFatal #-}
+
+
+newtype WrappedExc e = WrappedExc { _unwrapExc :: e }
+  deriving (Typeable)
+
+instance Typeable e => Show (WrappedExc e) where
+  show = mappend "WrappedExc: " . show . typeRep
+
+instance (Typeable e) => X.Exception (WrappedExc e)
+
+
+------------------------------------------------------------------------------
+-- | Run an 'Fatal' effect as an 'IO' 'X.Exception' through final 'IO'. This
+-- interpretation is significantly faster than 'runFatal'.
+--
+-- /Beware/: Effects that aren't interpreted in terms of 'IO'
+-- will have local state semantics in regards to 'Fatal' effects
+-- interpreted this way. See 'Final'.
+--
+-- @since 1.2.0.0
+fatalToIOFinal
+    :: ( Typeable e
+       , Member (Final IO) r
+       )
+    => Sem (Fatal e ': r) a
+    -> Sem r (Either e a)
+fatalToIOFinal sem = controlF $ \lower -> do
+    lower (Right <$> runFatalAsExcFinal sem)
+  `X.catch` \(WrappedExc e) ->
+    lower $ return $ Left e
+{-# INLINE fatalToIOFinal #-}
+
+
+runFatalAsExcFinal
+    :: forall e r a
+    .  ( Typeable e
+       , Member (Final IO) r
+       )
+    => Sem (Fatal e ': r) a
+    -> Sem r a
+runFatalAsExcFinal = interpretFinal @IO $ \case
+  Fatal e   -> embed $ X.throwIO $ WrappedExc e
+{-# INLINE runFatalAsExcFinal #-}
+
+
+fatalToError
+    :: Member (Error e) r
+    => Sem (Fatal e ': r) a
+    -> Sem r a
+fatalToError = interpret $ \case
+  Fatal e -> throw e
+{-# INLINE fatalToError #-}
+

From aa78182947d2c89921edc10cf7b99877703fa8e8 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 18 Oct 2021 23:42:56 -0700
Subject: [PATCH 19/21] Remove resourceToIO

---
 polysemy.cabal           |  3 +-
 src/Polysemy/Resource.hs | 62 ----------------------------------------
 test/BracketSpec.hs      | 16 -----------
 test/ErrorSpec.hs        |  2 +-
 4 files changed, 3 insertions(+), 80 deletions(-)

diff --git a/polysemy.cabal b/polysemy.cabal
index 563d60d8..ad849550 100644
--- a/polysemy.cabal
+++ b/polysemy.cabal
@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: c02e0285aee0795d2219f823c60e1b8b166e82403fe8a877f8b25cdce69a5785
+-- hash: 296ffb3e340f4324417e4d774a6aad757fa372fe33fd4551b4321bab6ff6564c
 
 name:           polysemy
 version:        1.6.0.0
@@ -54,6 +54,7 @@ library
       Polysemy.Error
       Polysemy.Fail
       Polysemy.Fail.Type
+      Polysemy.Fatal
       Polysemy.Final
       Polysemy.Fixpoint
       Polysemy.Input
diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs
index d4735924..cae31b05 100644
--- a/src/Polysemy/Resource.hs
+++ b/src/Polysemy/Resource.hs
@@ -14,7 +14,6 @@ module Polysemy.Resource
     -- * Interpretations
   , runResource
   , resourceToIOFinal
-  , resourceToIO
   ) where
 
 import qualified Control.Exception as X
@@ -176,64 +175,3 @@ runResource = interpretH $ \case
     restoreH ta
 {-# 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 =
-  undefined
-  -- 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 #-}
-
diff --git a/test/BracketSpec.hs b/test/BracketSpec.hs
index 4c2d4477..74429a7b 100644
--- a/test/BracketSpec.hs
+++ b/test/BracketSpec.hs
@@ -151,16 +151,6 @@ runTest = pure
         . runResource
         . runError @()
 
-runTest2
-  :: Sem '[Error (), Resource, State [Char], Trace, Output String, Final IO, Embed IO] a
-  -> IO ([String], ([Char], Either () a))
-runTest2 = runM
-         . ignoreOutput
-         . runTraceList
-         . runState ""
-         . resourceToIO
-         . runError @()
-
 runTest3
   :: Sem '[Error (), Resource, State [Char], Trace, Output String, Final IO, Embed IO] a
   -> IO ([String], ([Char], Either () a))
@@ -184,9 +174,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
@@ -199,9 +186,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
diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs
index cf9de9d8..f8dd5034 100644
--- a/test/ErrorSpec.hs
+++ b/test/ErrorSpec.hs
@@ -28,7 +28,7 @@ spec = parallel $ do
 
     it "should happen before Resource" $ do
       a <-
-        runM $ resourceToIO $ runError @MyExc $ do
+        runM $ resourceToIOFinal $ runError @MyExc $ do
           onException
             (fromException @MyExc $ do
               _ <- X.throwIO $ MyExc "hello"

From a1902af57ae226f5c657a3b57da96e59f3e8898e Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Mon, 18 Oct 2021 23:43:03 -0700
Subject: [PATCH 20/21] Remove hie.yaml since modern tooling generates it

---
 hie.yaml | 13 -------------
 1 file changed, 13 deletions(-)
 delete mode 100644 hie.yaml

diff --git a/hie.yaml b/hie.yaml
deleted file mode 100644
index 7ccd39c0..00000000
--- a/hie.yaml
+++ /dev/null
@@ -1,13 +0,0 @@
-cradle:
-  cabal:
-    - path: "."
-      component: "lib:polysemy"
-
-    - path: "./test"
-      component: "polysemy:test:polysemy-test"
-
-    - path: "./polysemy-plugin"
-      component: "lib:polysemy-plugin"
-
-    - path: "./polysemy-plugin/test"
-      component: "polysemy-plugin:test:polysemy-plugin-test"

From e1660caa5a4830e6890a83ad501f18c2860bb418 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Tue, 19 Oct 2021 00:16:50 -0700
Subject: [PATCH 21/21] Fix AsyncSpec

---
 test/AsyncSpec.hs | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

diff --git a/test/AsyncSpec.hs b/test/AsyncSpec.hs
index ce8386e2..e8902ffa 100644
--- a/test/AsyncSpec.hs
+++ b/test/AsyncSpec.hs
@@ -8,16 +8,21 @@ import Polysemy
 import Polysemy.Async
 import Polysemy.State
 import Polysemy.Trace
+import Polysemy.Output
 import Test.Hspec
+import Data.IORef
 
 
 spec :: Spec
 spec = describe "async" $ do
   it "should thread state and not lock" $ do
-    (ts, (s, r)) <- runM
-                  . runTraceList
-                  . runState "hello"
-                  . asyncToIOFinal $ do
+    s_ref <- newIORef "hello"
+    ts_ref <- newIORef []
+    r <- runM
+            . runOutputSem @String (\x -> embed $ modifyIORef ts_ref (x :))
+            . traceToOutput
+            . runStateIORef s_ref
+            . asyncToIOFinal $ do
       let message :: Member Trace r => Int -> String -> Sem r ()
           message n msg = trace $ mconcat
             [ show n, "> ", msg ]
@@ -41,6 +46,8 @@ spec = describe "async" $ do
           embed $ putMVar lock2 ()
 
       await a1 <* put "final"
+    s <- readIORef s_ref
+    ts <- fmap reverse $ readIORef ts_ref
 
     ts `shouldContain` ["1> hello", "2> olleh", "1> pong"]
     s `shouldBe` "final"