Make interpretH and friends expose Monad on existential m

src/Polysemy/Bundle.hs

@@ -43,9 +43,9 @@ sendBundle
   => Sem (e ': r) a
   -> Sem r a
 sendBundle = hoistSem $ \u -> case decomp u of
-  Right (Weaving e s wv ex ins) ->
-    injWeaving $
-      Weaving (Bundle (membership @e @r') e) s (sendBundle @e @r' . wv) ex ins
+  Right (Weaving (WeavingDetails e s wv ex ins)) ->
+    injWeaving $ Weaving $ WeavingDetails
+      (Bundle (membership @e @r') e) s (sendBundle @e @r' . wv) ex ins
   Left g -> hoist (sendBundle @e @r') g
 {-# INLINE sendBundle #-}
 
@@ -57,8 +57,9 @@ 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 (WeavingDetails (Bundle pr e) s wv ex ins)) ->
+    Union $ UnionDetails (extendMembership @_ @r pr) $ Weaving $
+      WeavingDetails e s wv ex ins
   Left g -> weakenList @r' @r g
 {-# INLINE runBundle #-}
 
@@ -70,7 +71,8 @@ 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 (WeavingDetails (Bundle pr e) s wv ex ins)) ->
+    Union $ UnionDetails (subsumeMembership pr)
+              (Weaving (WeavingDetails e s wv ex ins))
   Left g -> g
 {-# INLINE subsumeBundle #-}

src/Polysemy/Error.hs

@@ -202,8 +202,8 @@ runError (Sem m) = Sem $ \k -> E.runExceptT $ m $ \u ->
             (either (pure . Left) runError)
             hush
             x
-    Right (Weaving (Throw e) _ _ _ _) -> E.throwE e
-    Right (Weaving (Catch main handle) s d y _) ->
+    Right (Weaving (WeavingDetails (Throw e) _ _ _ _)) -> E.throwE e
+    Right (Weaving (WeavingDetails (Catch main handle) s d y _)) ->
       E.ExceptT $ usingSem k $ do
         ma <- runError $ d $ main <$ s
         case ma of

src/Polysemy/Final.hs

@@ -190,9 +190,9 @@ interpretFinal n =
   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 (WeavingDetails e s wv ex ins)) ->
         injWeaving $
-          Weaving
+          Weaving $ WeavingDetails
             (WithWeavingToFinal (runStrategy (n e)))
             s
             (go . wv)
@@ -214,7 +214,7 @@ 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 (WeavingDetails (WithWeavingToFinal wav) s wv ex ins) ->
     ex <$> wav s (runFinal . wv) ins
 {-# INLINE runFinal #-}
 
@@ -233,9 +233,9 @@ 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 (WeavingDetails (WithWeavingToFinal wav) s wv ex ins)) ->
         injWeaving $
-          Weaving
+          Weaving $ WeavingDetails
             (WithWeavingToFinal $ \s' wv' ins' ->
               to $ wav s' (from . wv') ins'
             )

src/Polysemy/IO.hs

@@ -68,6 +68,6 @@ lowerEmbedded run_m (Sem m) = withLowerToIO $ \lower _ ->
               . liftSem
               $ hoist (lowerEmbedded run_m) x
 
-      Right (Weaving (Embed wd) s _ y _) ->
+      Right (Weaving (WeavingDetails (Embed wd) s _ y _)) ->
         fmap y $ fmap (<$ s) wd
 

src/Polysemy/Internal.hs

@@ -353,8 +353,9 @@ raiseUnder :: ∀ e2 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': r) a
 raiseUnder = hoistSem $ hoist raiseUnder . weakenUnder
   where
     weakenUnder :: ∀ m x. Union (e1 ': r) m x -> Union (e1 ': e2 ': r) m x
-    weakenUnder (Union Here a) = Union Here a
-    weakenUnder (Union (There n) a) = Union (There (There n)) a
+    weakenUnder (Union (UnionDetails Here a)) = Union $ UnionDetails Here a
+    weakenUnder (Union (UnionDetails (There n) a)) = Union $
+      UnionDetails (There (There n)) a
     {-# INLINE weakenUnder #-}
 {-# INLINE raiseUnder #-}
 
@@ -368,8 +369,9 @@ raiseUnder2 :: ∀ e2 e3 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': r) a
 raiseUnder2 = hoistSem $ hoist raiseUnder2 . weakenUnder2
   where
     weakenUnder2 ::  ∀ m x. Union (e1 ': r) m x -> Union (e1 ': e2 ': e3 ': r) m x
-    weakenUnder2 (Union Here a) = Union Here a
-    weakenUnder2 (Union (There n) a) = Union (There (There (There n))) a
+    weakenUnder2 (Union (UnionDetails Here a)) = Union $ UnionDetails Here a
+    weakenUnder2 (Union (UnionDetails (There n) a)) = Union $
+      UnionDetails (There (There (There n))) a
     {-# INLINE weakenUnder2 #-}
 {-# INLINE raiseUnder2 #-}
 
@@ -383,8 +385,9 @@ raiseUnder3 :: ∀ e2 e3 e4 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': e4
 raiseUnder3 = hoistSem $ hoist raiseUnder3 . weakenUnder3
   where
     weakenUnder3 ::  ∀ m x. Union (e1 ': r) m x -> Union (e1 ': e2 ': e3 ': e4 ': r) m x
-    weakenUnder3 (Union Here a) = Union Here a
-    weakenUnder3 (Union (There n) a) = Union (There (There (There (There n)))) a
+    weakenUnder3 (Union (UnionDetails Here a)) = Union $ UnionDetails Here a
+    weakenUnder3 (Union (UnionDetails (There n) a)) = Union $
+      UnionDetails (There (There (There (There n)))) a
     {-# INLINE weakenUnder3 #-}
 {-# INLINE raiseUnder3 #-}
 
@@ -421,7 +424,7 @@ subsumeUsing pr =
   let
     go :: forall x. Sem (e ': r) x -> Sem r x
     go = hoistSem $ \u -> hoist go $ case decomp u of
-      Right w -> Union pr w
+      Right w -> Union $ UnionDetails pr w
       Left  g -> g
     {-# INLINE go #-}
   in
@@ -469,7 +472,7 @@ 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 (WeavingDetails e s _ f _) -> do
       a <- unEmbed e
       pure $ f $ a <$ s
 {-# INLINE runM #-}

src/Polysemy/Internal.hs-boot

@@ -0,0 +1,11 @@
+{-# LANGUAGE RoleAnnotations #-}
+module Polysemy.Internal where
+
+import Polysemy.Internal.Kind
+
+type role Sem nominal nominal
+data Sem (r :: EffectRow) (a :: *)
+
+instance Functor (Sem r)
+instance Applicative (Sem r)
+instance Monad (Sem r)

src/Polysemy/Internal/Combinators.hs

@@ -81,12 +81,11 @@ interpretH
 interpretH f (Sem m) = m $ \u ->
   case decomp u of
     Left  x -> liftSem $ hoist (interpretH f) x
-    Right (Weaving e s d y v) -> do
+    Right (Weaving (WeavingDetails e s d y v)) -> do
       a <- runTactics s d v $ f e
       pure $ y a
 {-# INLINE interpretH #-}
 
-
 ------------------------------------------------------------------------------
 -- | A highly-performant combinator for interpreting an effect statefully. See
 -- 'stateful' for a more user-friendly variety of this function.
@@ -105,7 +104,7 @@ interpretInStateT f s (Sem m) = Sem $ \k ->
                     (uncurry $ interpretInStateT f)
                     (Just . snd)
             $ x
-        Right (Weaving e z _ y _) ->
+        Right (Weaving (WeavingDetails e z _ y _)) ->
           fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e
 {-# INLINE interpretInStateT #-}
 
@@ -127,7 +126,7 @@ interpretInLazyStateT f s (Sem m) = Sem $ \k ->
                     (uncurry $ interpretInLazyStateT f)
                     (Just . snd)
             $ x
-        Right (Weaving e z _ y _) ->
+        Right (Weaving (WeavingDetails e z _ y _)) ->
           fmap (y . (<$ z)) $ LS.mapStateT (usingSem k) $ f e
 {-# INLINE interpretInLazyStateT #-}
 
@@ -160,14 +159,14 @@ lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap swap . f e
 -- See the notes on 'Tactical' for how to use this function.
 reinterpretH
     :: forall e1 e2 r a
-     . (∀ m x. e1 m x -> Tactical e1 m (e2 ': r) x)
+     . (∀ m x. Monad m => e1 m x -> Tactical e1 m (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 m) = Sem $ \k -> m $ \u ->
   case decompCoerce u of
     Left x  -> k $ hoist (reinterpretH f) $ x
-    Right (Weaving e s d y v) -> do
+    Right (Weaving (WeavingDetails e s d y v)) -> do
       a <- usingSem k $ runTactics s (raiseUnder . d) v $ f e
       pure $ y a
 {-# INLINE[3] reinterpretH #-}
@@ -197,14 +196,14 @@ reinterpret = firstOrder reinterpretH
 -- See the notes on 'Tactical' for how to use this function.
 reinterpret2H
     :: forall e1 e2 e3 r a
-     . (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': r) x)
+     . (∀ m x. Monad m => e1 m x -> Tactical e1 m (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 s d y v) -> do
+    Right (Weaving (WeavingDetails e s d y v)) -> do
       a <- usingSem k $ runTactics s (raiseUnder2 . d) v $ f e
       pure $ y a
 {-# INLINE[3] reinterpret2H #-}
@@ -229,14 +228,14 @@ reinterpret2 = firstOrder reinterpret2H
 -- See the notes on 'Tactical' for how to use this function.
 reinterpret3H
     :: forall e1 e2 e3 e4 r a
-     . (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': e4 ': r) x)
+     . (∀ m x. Monad m => e1 m x -> Tactical e1 m (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 s d y v) -> do
+    Right (Weaving (WeavingDetails e s d y v)) -> do
       a <- usingSem k $ runTactics s (raiseUnder3 . d) v $ f e
       pure $ y a
 {-# INLINE[3] reinterpret3H #-}
@@ -279,7 +278,7 @@ intercept f = interceptH $ \(e :: e m x) -> liftT @m $ f e
 -- See the notes on 'Tactical' for how to use this function.
 interceptH
     :: Member e r
-    => (∀ x m. e m x -> Tactical e m r x)
+    => (∀ x m. Monad m => e m x -> Tactical e m r x)
        -- ^ A natural transformation from the handled effect to other effects
        -- already in 'Sem'.
     -> Sem r a
@@ -326,15 +325,15 @@ interceptUsingH
        -- ^ A proof that the handled effect exists in @r@.
        -- This can be retrieved through 'Polysemy.Membership.membership' or
        -- 'Polysemy.Membership.tryMembership'.
-    -> (∀ x m. e m x -> Tactical e m r x)
+    -> (∀ x m. Monad m => e m x -> Tactical e m 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 s d y v) ->
+    Just (Weaving (WeavingDetails e s d y v)) ->
       usingSem k $ fmap y $ runTactics s (raise . d) v $ f e
     Nothing -> k $ hoist (interceptUsingH pr f) u
 {-# INLINE interceptUsingH #-}
@@ -352,7 +351,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 (WeavingDetails e s d n y)) ->
+      Union $ UnionDetails Here $ Weaving $ WeavingDetails (f e) s d n y
 
 
 ------------------------------------------------------------------------------
@@ -369,5 +369,6 @@ 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 (WeavingDetails e s wv ex ins)) ->
+      injWeaving (Weaving $ WeavingDetails (f e) s wv ex ins)
 

src/Polysemy/Internal/Forklift.hs

@@ -36,7 +36,7 @@ runViaForklift
     -> IO a
 runViaForklift chan = usingSem $ \u -> do
   case prj u of
-    Just (Weaving (Embed m) s _ ex _) ->
+    Just (Weaving (WeavingDetails (Embed m) s _ ex _)) ->
       ex . (<$ s) <$> m
     _ -> do
       mvar <- newEmptyMVar

src/Polysemy/Internal/Tactics.hs

@@ -190,11 +190,11 @@ runTactics
 runTactics s d v (Sem m) = m $ \u ->
   case decomp u of
     Left x -> liftSem $ hoist (runTactics s d v) x
-    Right (Weaving GetInitialState s' _ y _) ->
+    Right (Weaving (WeavingDetails GetInitialState s' _ y _)) ->
       pure $ y $ s <$ s'
-    Right (Weaving (HoistInterpretation na) s' _ y _) -> do
+    Right (Weaving (WeavingDetails (HoistInterpretation na) s' _ y _)) -> do
       pure $ y $ (d . fmap na) <$ s'
-    Right (Weaving GetInspector s' _ y _) -> do
+    Right (Weaving (WeavingDetails GetInspector s' _ y _)) -> do
       pure $ y $ Inspector v <$ s'
 {-# INLINE runTactics #-}