Core rewrite for new family of easy higher-order interpreters

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

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 by
+    -- 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

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 #-}

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 #-}
 
 ------------------------------------------------------------------------------

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

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)

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 #-}