packages feed

polysemy-plugin 0.1.0.1 → 0.2.0.0

raw patch · 8 files changed

+450/−132 lines, 8 filesdep +inspection-testingdep +sybdep +transformersdep ~polysemyPVP ok

version bump matches the API change (PVP)

Dependencies added: inspection-testing, syb, transformers

Dependency ranges changed: polysemy

API changes (from Hackage documentation)

+ Polysemy.Plugin.Fundep: fundepPlugin :: TcPlugin
+ Polysemy.Plugin.InlineRecursiveCalls: inlineRecursiveCalls :: ModGuts -> CoreM ModGuts
+ Polysemy.Plugin.Phases: extraPhases :: DynFlags -> [CoreToDo]

Files

ChangeLog.md view
@@ -1,5 +1,17 @@ # Changelog for polysemy-plugin +## 0.2.0.0 (2019-05-23)++- Fixed a serious bug where the changes from 0.1.0.1 broke most real-world+    usages of polysemy+- The plugin will now automatically perform the transformation in+    `polysemy`'s `inlineRecursiveCalls` when run with `-O`++## 0.1.0.1 (2019-05-18)++- Added some explicit bounds for cabal+- Fixed a bug where effects that were too polymorphic would silently be accepted+ ## 0.1.0.0 (2019-04-27)  - Initial release
polysemy-plugin.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: b2f1b5ca3df4cb55d14d21f847975a2eb82809c4b569f214f7ff29a88bd9d65d+-- hash: 85478fdf6818cbb2b849d4dd68a9f8dbee303d4a7ac2005945ac34ac5eb9dd33  name:           polysemy-plugin-version:        0.1.0.1+version:        0.2.0.0 synopsis:       Disambiguate obvious uses of effects. description:    Please see the README on GitHub at <https://github.com/isovector/polysemy/tree/master/polysemy-plugin#readme> category:       Polysemy@@ -30,6 +30,9 @@ library   exposed-modules:       Polysemy.Plugin+      Polysemy.Plugin.Fundep+      Polysemy.Plugin.InlineRecursiveCalls+      Polysemy.Plugin.Phases   other-modules:       Paths_polysemy_plugin   hs-source-dirs:@@ -40,6 +43,8 @@     , ghc >=8.6.3 && <8.7     , ghc-tcplugins-extra >=0.3 && <0.4     , polysemy >=0.1+    , syb >=0.7 && <0.8+    , transformers >=0.5.5.0 && <0.6   default-language: Haskell2010  test-suite polysemy-plugin-test@@ -47,18 +52,23 @@   main-is: Main.hs   other-modules:       BadSpec+      ExampleSpec+      InlineRecursiveCallsSpec       PluginSpec       Paths_polysemy_plugin   hs-source-dirs:       test   default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax-  ghc-options: -threaded -rtsopts -with-rtsopts=-N -fplugin=Polysemy.Plugin+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -fplugin=Polysemy.Plugin -O2   build-depends:       base >=4.7 && <5     , ghc >=8.6.3 && <8.7     , ghc-tcplugins-extra >=0.3 && <0.4     , hspec >=2.6.0 && <3+    , inspection-testing >=0.4.1.1 && <0.5     , polysemy >=0.1     , polysemy-plugin     , should-not-typecheck >=2.1.0 && <3+    , syb >=0.7 && <0.8+    , transformers >=0.5.5.0 && <0.6   default-language: Haskell2010
src/Polysemy/Plugin.hs view
@@ -2,37 +2,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-}  --------------------------------------------------------------------------------- The MIT License (MIT)------ Copyright (c) 2017 Luka Horvat------ Permission is hereby granted, free of charge, to any person obtaining a copy--- of this software and associated documentation files (the "Software"), to--- deal in the Software without restriction, including without limitation the--- rights to use, copy, modify, merge, publish, distribute, sublicense, and/or--- sell copies of the Software, and to permit persons to whom the Software is--- furnished to do so, subject to the following conditions:------ The above copyright notice and this permission notice shall be included in--- all copies or substantial portions of the Software.------ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR--- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,--- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE--- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER--- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING--- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS--- IN THE SOFTWARE.---------------------------------------------------------------------------------------- This module is heavily based on 'Control.Effects.Plugin' from the--- 'simple-effects' package, originally by Luka Horvat.------ https://gitlab.com/LukaHorvat/simple-effects/commit/966ce80b8b5777a4bd8f87ffd443f5fa80cc8845#f51c1641c95dfaa4827f641013f8017e8cd02aab--------------------------------------------------------------------------------- -- | A typechecker plugin that can disambiguate "obvious" uses of effects in -- Polysemy. --@@ -92,127 +61,51 @@   ( plugin   ) where -import Class-import CoAxiom-import Control.Monad import CoreMonad-import Data.Maybe import DynFlags-import FastString (fsLit) import GHC (ModuleName, moduleName)-import GHC.TcPluginM.Extra (lookupModule, lookupName)-import Module     (mkModuleName, moduleSetElts)-import OccName    (mkTcOcc)-import Outputable-import TcPluginM  (TcPluginM, tcLookupClass)-import TcRnTypes-import TcSMonad hiding (tcLookupClass)-import TyCoRep    (Type (..))-import Type+import Module (mkModuleName, moduleSetElts)+import Polysemy.Plugin.Fundep+import Polysemy.Plugin.InlineRecursiveCalls -import Plugins    (Plugin (..), defaultPlugin+#if __GLASGOW_HASKELL__ >= 810+import Polysemy.Plugin.Phases+#endif++import Plugins (Plugin (..), defaultPlugin) #if __GLASGOW_HASKELL__ >= 806-    , PluginRecompile(..)+import Plugins (PluginRecompile(..)) #endif-    )   plugin :: Plugin plugin = defaultPlugin     { tcPlugin = const $ Just fundepPlugin-#if __GLASGOW_HASKELL__ >= 810     , installCoreToDos = const installTodos-#endif #if __GLASGOW_HASKELL__ >= 806     , pluginRecompile = const $ pure NoForceRecompile #endif     } + polysemyInternal :: ModuleName polysemyInternal = mkModuleName "Polysemy.Internal" -polysemyInternalUnion :: ModuleName-polysemyInternalUnion = mkModuleName "Polysemy.Internal.Union"  installTodos :: [CoreToDo] -> CoreM [CoreToDo] installTodos todos = do-  dynFlags <- getDynFlags-  case optLevel dynFlags of-    2 -> do-      mods <- moduleSetElts <$> getVisibleOrphanMods-      case any ((== polysemyInternal) . moduleName) mods of-        -- TODO(sandy): install extra passes-        True  -> pure todos-        False -> pure todos-    _ -> pure todos--fundepPlugin :: TcPlugin-fundepPlugin = TcPlugin-    { tcPluginInit = do-        md <- lookupModule polysemyInternalUnion (fsLit "polysemy")-        monadEffectTcNm <- lookupName md (mkTcOcc "Find")-        tcLookupClass monadEffectTcNm-    , tcPluginSolve = solveFundep-    , tcPluginStop = const (return ()) }--allMonadEffectConstraints :: Class -> [Ct] -> [(CtLoc, (Type, Type, Type))]-allMonadEffectConstraints cls cts =-    [ (ctLoc cd, (effName, eff, r))-        | cd@CDictCan{cc_class = cls', cc_tyargs = [_, r, eff]} <- cts-        , cls == cls'-        , let effName = getEffName eff-              ]--singleListToJust :: [a] -> Maybe a-singleListToJust [a] = Just a-singleListToJust _ = Nothing--findMatchingEffectIfSingular :: (Type, Type, Type) -> [(Type, Type, Type)] -> Maybe Type-findMatchingEffectIfSingular (effName, _, mon) ts = singleListToJust-    [ eff'-        | (effName', eff', mon') <- ts-        , eqType effName effName'-        , eqType mon mon' ]--getEffName :: Type -> Type-getEffName t = fst $ splitAppTys t----- isTyVar :: Type -> Bool--- isTyVar = isJust . getTyVar_maybe---canUnify :: Type -> Type -> Bool-canUnify wanted given =-  let (w, ws) = splitAppTys wanted-      (g, gs) = splitAppTys given-   in (&& eqType w g) . flip all (zip ws gs) $ \(wt, gt) ->-        if isTyVarTy gt-           then isTyVarTy wt-           else True---mkWanted :: Bool -> CtLoc -> Type -> Type -> TcPluginM (Maybe Ct)-mkWanted mustUnify loc wanted given = do-  if (not mustUnify || canUnify wanted given)-     then do-       (ev, _) <- unsafeTcPluginTcM $ runTcSDeriveds $ newWantedEq loc Nominal wanted given-       pure $ Just (CNonCanonical ev)-     else-       pure Nothing-+  dflags <- getDynFlags -solveFundep :: Class -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult-solveFundep effCls giv _ want = do-    let wantedEffs = allMonadEffectConstraints effCls want-    let givenEffs = snd <$> allMonadEffectConstraints effCls giv-    eqs <- forM wantedEffs $ \(loc, e@(_, eff, r)) ->-      case findMatchingEffectIfSingular e givenEffs of-        Nothing -> do-          case splitAppTys r of-            (_, [_, eff', _]) -> mkWanted False loc eff eff'-            _                 -> pure Nothing-        Just eff' -> mkWanted True loc eff eff'+  case optLevel dflags of+    0 -> pure todos+    _ -> do+      mods <- moduleSetElts <$> getVisibleOrphanMods+      pure $ case any ((== polysemyInternal) . moduleName) mods of+        True  -> CoreDoPluginPass "Inline Recursive Calls" inlineRecursiveCalls+               : todos+#if __GLASGOW_HASKELL__ >= 810+              ++ extraPhases dflags+#endif+        False -> todos -    return (TcPluginOk [] (catMaybes eqs))
+ src/Polysemy/Plugin/Fundep.hs view
@@ -0,0 +1,132 @@+------------------------------------------------------------------------------+-- The MIT License (MIT)+--+-- Copyright (c) 2017 Luka Horvat+--+-- Permission is hereby granted, free of charge, to any person obtaining a copy+-- of this software and associated documentation files (the "Software"), to+-- deal in the Software without restriction, including without limitation the+-- rights to use, copy, modify, merge, publish, distribute, sublicense, and/or+-- sell copies of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:+--+-- The above copyright notice and this permission notice shall be included in+-- all copies or substantial portions of the Software.+--+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS+-- IN THE SOFTWARE.+--+------------------------------------------------------------------------------+--+-- This module is heavily based on 'Control.Effects.Plugin' from the+-- 'simple-effects' package, originally by Luka Horvat.+--+-- https://gitlab.com/LukaHorvat/simple-effects/commit/966ce80b8b5777a4bd8f87ffd443f5fa80cc8845#f51c1641c95dfaa4827f641013f8017e8cd02aab++module Polysemy.Plugin.Fundep (fundepPlugin) where++import Class+import CoAxiom+import Control.Monad+import Data.Bifunctor+import Data.List+import Data.Maybe+import FastString (fsLit)+import GHC (ModuleName)+import GHC.TcPluginM.Extra (lookupModule, lookupName)+import Module (mkModuleName)+import OccName (mkTcOcc)+import TcPluginM (TcPluginM, tcLookupClass)+import TcRnTypes+import TcSMonad hiding (tcLookupClass)+import TyCoRep (Type (..))+import Type+++polysemyInternalUnion :: ModuleName+polysemyInternalUnion = mkModuleName "Polysemy.Internal.Union"++fundepPlugin :: TcPlugin+fundepPlugin = TcPlugin+    { tcPluginInit = do+        md <- lookupModule polysemyInternalUnion (fsLit "polysemy")+        monadEffectTcNm <- lookupName md (mkTcOcc "Find")+        tcLookupClass monadEffectTcNm+    , tcPluginSolve = solveFundep+    , tcPluginStop = const (return ()) }++allMonadEffectConstraints :: Class -> [Ct] -> [(CtLoc, (Type, Type, Type))]+allMonadEffectConstraints cls cts =+    [ (ctLoc cd, (effName, eff, r))+    | cd@CDictCan{cc_class = cls', cc_tyargs = [_, r, eff]} <- cts+    , cls == cls'+    , let effName = getEffName eff+    ]++singleListToJust :: [a] -> Maybe a+singleListToJust [a] = Just a+singleListToJust _ = Nothing++findMatchingEffectIfSingular :: (Type, Type, Type) -> [(Type, Type, Type)] -> Maybe Type+findMatchingEffectIfSingular (effName, _, mon) ts = singleListToJust+    [ eff'+        | (effName', eff', mon') <- ts+        , eqType effName effName'+        , eqType mon mon' ]++getEffName :: Type -> Type+getEffName t = fst $ splitAppTys t+++canUnify :: Type -> Type -> Bool+canUnify wanted given =+  let (w, ws) = splitAppTys wanted+      (g, gs) = splitAppTys given+   in (&& eqType w g) . flip all (zip ws gs) $ \(wt, gt) ->+        if isTyVarTy gt+           then isTyVarTy wt+           else True+++mkWanted :: Bool -> CtLoc -> Type -> Type -> TcPluginM (Maybe Ct)+mkWanted mustUnify loc wanted given =+  if (not mustUnify || canUnify wanted given)+     then do+       (ev, _) <- unsafeTcPluginTcM $ runTcSDeriveds $ newWantedEq loc Nominal wanted given+       pure $ Just $ CNonCanonical ev+     else+       pure Nothing++thd :: (a, b, c) -> c+thd (_, _, c) = c++countLength :: (a -> a -> Bool) -> [a] -> [(a, Int)]+countLength eq as =+  let grouped = groupBy eq as+   in zipWith (curry $ bimap head length) grouped grouped++solveFundep :: Class -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult+solveFundep _ _ _ [] = pure $ TcPluginOk [] []+solveFundep effCls giv _ want = do+    let wantedEffs = allMonadEffectConstraints effCls want+        givenEffs = snd <$> allMonadEffectConstraints effCls giv+        num_wanteds_by_r = countLength eqType $ fmap (thd . snd) wantedEffs+        must_unify r =+          let Just num_wanted = find (eqType r . fst) num_wanteds_by_r+           in snd num_wanted /= 1++    eqs <- forM wantedEffs $ \(loc, e@(_, eff, r)) -> do+      case findMatchingEffectIfSingular e givenEffs of+        Nothing -> do+          case splitAppTys r of+            (_, [_, eff', _]) -> mkWanted (must_unify r) loc eff eff'+            _                 -> pure Nothing+        Just eff' -> mkWanted True loc eff eff'++    pure $ TcPluginOk [] $ catMaybes eqs+
+ src/Polysemy/Plugin/InlineRecursiveCalls.hs view
@@ -0,0 +1,92 @@+module Polysemy.Plugin.InlineRecursiveCalls+  ( inlineRecursiveCalls+  ) where++import BasicTypes+import Control.Monad+import Control.Monad.Trans.State+import CoreMonad+import CoreSyn+import Data.Monoid+import Data.Traversable+import GHC+import Generics.SYB+import HscTypes+import IdInfo+import Name+import SrcLoc+import UniqSupply+import Unique+import Var+++inlineRecursiveCalls :: ModGuts -> CoreM ModGuts+inlineRecursiveCalls mg = do+  uniqSupply <- liftIO $ mkSplitUniqSupply '\x264a'+  flip evalStateT uniqSupply $ do+    bs <- traverse loopbreakBinds $ mg_binds mg+    pure $ mg { mg_binds = bs }+++type CoreSupplyM = StateT UniqSupply CoreM+++getUniq :: CoreSupplyM Unique+getUniq = do+  (u, s) <- gets takeUniqFromSupply+  put s+  pure u+++containsName :: CoreBndr -> CoreExpr -> Bool+containsName n e =+  getAny $+    everything+      (<>)+      (mkQ (Any False) $ matches n)+      e+++matches :: CoreBndr -> CoreExpr -> Any+matches n (Var n') | n == n' = Any True+matches _ _ = Any False+++replace :: Id -> Id -> Expr CoreBndr -> Expr CoreBndr+replace n n' = everywhere $ mkT go+  where+    go :: Expr CoreBndr -> Expr CoreBndr+    go v@(Var nn)+      | nn == n   = Var n'+      | otherwise = v+    go x = x+++loopbreaker :: CoreBndr -> CoreExpr -> CoreSupplyM [(Var, CoreExpr)]+loopbreaker n b = do+  u <- getUniq+  let Just info = zapUsageInfo $ idInfo n+      info' = setInlinePragInfo info alwaysInlinePragma+      n' = mkLocalVar+             (idDetails n)+             (mkInternalName u (occName n) noSrcSpan)+             (idType n)+         $ setInlinePragInfo vanillaIdInfo neverInlinePragma+  pure [ (lazySetIdInfo n info', replace n n' b)+       , (n', Var n)+       ]+++-- TODO(sandy): Make this only break loops in functions whose type ends in `Sem+-- * * -> Sem * *` for wildcards `*`+loopbreakBinds+    :: Bind CoreBndr+    -> CoreSupplyM (Bind CoreBndr)+loopbreakBinds nr@(NonRec n b)+  | containsName n b = Rec <$> loopbreaker n b+  | otherwise        = pure nr+loopbreakBinds (Rec bs) = fmap (Rec . join) . for bs $ \(n, b) ->+  case containsName n b of+    False -> pure [(n, b)]+    True  -> loopbreaker n b+
+ src/Polysemy/Plugin/Phases.hs view
@@ -0,0 +1,59 @@+module Polysemy.Plugin.Phases+  ( extraPhases+  ) where++import BasicTypes+import CoreMonad+import DynFlags++extraPhases :: DynFlags -> [CoreToDo]+extraPhases dflags =+    [ CoreDoSpecialising+    , simpl_phase 0 ["post-late-spec"] max_iter+    , simpl_gently+    , CoreDoStaticArgs+    , CoreDoSpecialising+    -- TODO(sandy): probably don't need this one+    , simpl_phase 0 ["post-late-spec"] max_iter+    , simpl_phases+    , simpl_gently+    ]++  where+    option   = flip gopt dflags+    max_iter = maxSimplIterations dflags+    rules_on = option Opt_DoLambdaEtaExpansion+    phases   = simplPhases dflags++    base_mode = SimplMode+      { sm_phase      = error "base_mode"+      , sm_names      = []+      , sm_dflags     = dflags+      , sm_rules      = option Opt_EnableRewriteRules+      , sm_eta_expand = rules_on+      , sm_inline     = True+      , sm_case_case  = True+      }++    simpl_phase phase names iter = CoreDoPasses+      [ runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness+      , CoreDoSimplify iter $+          base_mode { sm_phase = Phase phase+                    , sm_names = names+                    }+      , runMaybe (ruleCheck dflags) $ CoreDoRuleCheck $ Phase phase+      ]++    simpl_gently = CoreDoSimplify max_iter $ base_mode+      { sm_phase = InitialPhase+      , sm_names = ["Gentle"]+      , sm_rules = rules_on+      , sm_inline = True+      , sm_case_case = False+      }++    simpl_phases = CoreDoPasses+      [ simpl_phase phase ["main"] max_iter+      | phase <- [phases, phases-1 .. 1]+      ]+
+ test/ExampleSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}++module ExampleSpec where++import Polysemy+import Polysemy.Error+import Polysemy.Input+import Polysemy.Output+import Polysemy.Resource+import Test.Hspec++data Teletype m a where+  ReadTTY  :: Teletype m String+  WriteTTY :: String -> Teletype m ()++makeSem ''Teletype++runTeletypeIO :: Member (Lift IO) r => Sem (Teletype ': r) a -> Sem r a+runTeletypeIO = interpret $ \case+  ReadTTY      -> sendM getLine+  WriteTTY msg -> sendM $ putStrLn msg++data CustomException = ThisException | ThatException deriving Show++program :: Members '[Teletype, Resource, Error CustomException] r => Sem r ()+program = catch @CustomException work $ \e -> writeTTY ("Caught " ++ show e)+  where work = bracket (readTTY) (const $ writeTTY "exiting bracket") $ \i -> do+          writeTTY "entering bracket"+          case i of+            "explode"     -> throw ThisException+            "weird stuff" -> writeTTY i >> throw ThatException+            _             -> writeTTY i >> writeTTY "no exceptions"++foo :: IO (Either CustomException ())+foo = (runM .@ runResource .@@ runErrorInIO @CustomException) $ runTeletypeIO program++spec :: Spec+spec = describe "example" $ do+  it "should compile!" $ do+    True `shouldBe` True+
+ test/InlineRecursiveCallsSpec.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -ddump-simpl -dsuppress-coercions -dsuppress-uniques -dsuppress-idinfo #-}+++module InlineRecursiveCallsSpec+  ( spec+  ) where++import qualified Control.Monad.Trans.State as S+import           Data.Tuple+import           Polysemy.Internal+import           Polysemy.Internal.Effect+import           Polysemy.Internal.Union+import           Test.Hspec+import           Test.Inspection+++spec :: Spec+spec = describe "inlining recursive calls" $ do+  it "should explicitly break recursion" $ do+    -- TODO(sandy): This should use (===) instead of (==-), but can't due to+    -- a bug in inspection-testing. See:+    -- https://github.com/nomeata/inspection-testing/pull/19+    shouldSucceed $(inspectTest $ 'recursive ==- 'mutual)+++isSuccess :: Result -> Bool+isSuccess (Success _) = True+isSuccess (Failure e) = error e+++shouldSucceed :: Result -> Expectation+shouldSucceed r = r `shouldSatisfy` isSuccess+++------------------------------------------------------------------------------+recursive+    :: (∀ x m. e m x -> S.StateT s (Sem r) x)+    -> s+    -> Sem (e ': r) a+    -> Sem r (s, a)+recursive f s (Sem m) = Sem $ \k ->+  fmap swap $ flip S.runStateT s $ m $ \u ->+    case decomp u of+        Left x -> S.StateT $ \s' ->+          k . fmap swap+            . weave (s', ()) (uncurry $ recursive f)+            $ x+        Right (Yo e z _ y) ->+          fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e+++------------------------------------------------------------------------------+mutual+    :: (∀ x m. e m x -> S.StateT s (Sem r) x)+    -> s+    -> Sem (e ': r) a+    -> Sem r (s, a)+mutual f s (Sem m) = Sem $ \k ->+  fmap swap $ flip S.runStateT s $ m $ \u ->+    case decomp u of+        Left x -> S.StateT $ \s' ->+          k . fmap swap+            . weave (s', ()) (uncurry $ mutual2 f)+            $ x+        Right (Yo e z _ y) ->+          fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e+{-# INLINE mutual #-}++mutual2+    :: (∀ x m. e m x -> S.StateT s (Sem r) x)+    -> s+    -> Sem (e ': r) a+    -> Sem r (s, a)+mutual2 = mutual+{-# NOINLINE mutual2 #-}+