From b3534c99933a23e021da8fc5a416ceb58e9b361e Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Fri, 18 Dec 2020 19:06:06 +0100
Subject: [PATCH 1/4] 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             |  40 +++-
 src/Polysemy/Internal/Combinators.hs | 275 ++++++++++++++++++++++-----
 src/Polysemy/Internal/Forklift.hs    |   4 +-
 src/Polysemy/Internal/Tactics.hs     |  31 +--
 src/Polysemy/Internal/Union.hs       |  87 +++++----
 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 +-
 stack.yaml                           |   2 +-
 19 files changed, 601 insertions(+), 208 deletions(-)
 create mode 100644 src/Polysemy/Internal/WeaveClass.hs

diff --git a/polysemy.cabal b/polysemy.cabal
index 0c02cc20..19fd479c 100644
--- a/polysemy.cabal
+++ b/polysemy.cabal
@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 9d61a6c298262f3e765c48ccc01f30cd9c328104777970c3529931c4d5c4ca22
+-- hash: 754ab355722062c11ee014b832c3c95ddeea81fec4242a5938436c0ca64383c8
 
 name:           polysemy
 version:        1.4.0.0
@@ -71,6 +71,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 2162f53e..0e40118a 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -107,6 +107,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
@@ -124,6 +131,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
@@ -143,6 +158,7 @@ module Polysemy
   , bindT
   , getInspectorT
   , Inspector (..)
+
   ) where
 
 import Polysemy.Final
diff --git a/src/Polysemy/Bundle.hs b/src/Polysemy/Bundle.hs
index 7b00bb86..4dd6f594 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 (extendMembership @_ @r pr) $ Weaving e s wv ex ins
+  Right (Weaving (Bundle pr e) mkT lwr ex) ->
+    Union (extendMembership @_ @r pr) $ Weaving e mkT lwr ex
   Left g -> weakenList @r' @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 9e06388f..53073f3f 100644
--- a/src/Polysemy/Internal.hs
+++ b/src/Polysemy/Internal.hs
@@ -30,6 +30,8 @@ module Polysemy.Internal
   , Subsume (..)
   , subsume
   , subsumeUsing
+  , expose
+  , exposeUsing
   , Embed (..)
   , usingSem
   , liftSem
@@ -50,6 +52,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
@@ -532,7 +535,39 @@ 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 #-}
 
+------------------------------------------------------------------------------
+-- | 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
@@ -575,9 +610,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 dd8b4597..4afa26ef 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
     :: (∀ x rInitial . 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 32bc991e..9bbcc066 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 c1031cc3..e72691b9 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
@@ -39,14 +43,19 @@ module Polysemy.Internal.Union
   -- * Checking membership
   , KnownRow
   , tryMembership
+
+  , 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
 
 #ifndef NO_ERROR_MESSAGES
@@ -73,59 +82,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 #-}
 
 
@@ -291,13 +296,12 @@ weaken (Union pr a) = Union (There pr) a
 
 ------------------------------------------------------------------------------
 -- | 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 #-}
 
 
@@ -308,10 +312,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 #-}
 
diff --git a/stack.yaml b/stack.yaml
index 0e359480..a5671b1a 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-16.1
+resolver: lts-16.26
 
 packages:
 - .

From 82cbdb7df310d49d0cc2f2ed01af6dcb3ff7d6c5 Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Sat, 19 Dec 2020 10:45:35 +0100
Subject: [PATCH 2/4] 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 0e40118a..bc27781c 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -133,7 +133,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 4afa26ef..56bda0c6 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 9bbcc066..442fffdb 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 4dea8ea2cf88f3deee944af95352950289ef0837 Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Sat, 19 Dec 2020 10:59:02 +0100
Subject: [PATCH 3/4] 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 dc9d5afebd2ec2c717a24b71799e674c5ac364ff Mon Sep 17 00:00:00 2001
From: unknown <combiner8761@gmail.com>
Date: Sat, 19 Dec 2020 14:09:45 +0100
Subject: [PATCH 4/4] 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 bc27781c..57ea333f 100644
--- a/src/Polysemy.hs
+++ b/src/Polysemy.hs
@@ -133,7 +133,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 56bda0c6..128aa0b5 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