Powerful interpretNew

polysemy.cabal

@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 754ab355722062c11ee014b832c3c95ddeea81fec4242a5938436c0ca64383c8
+-- hash: d7bfeced9fb04f06fed1d7d70c5ba8bbb99be9e4bf37c0b6e514fca6891a1405
 
 name:           polysemy
 version:        1.4.0.0
@@ -64,6 +64,7 @@ library
       Polysemy.Internal.CustomErrors.Redefined
       Polysemy.Internal.Fixpoint
       Polysemy.Internal.Forklift
+      Polysemy.Internal.Interpretation
       Polysemy.Internal.Kind
       Polysemy.Internal.NonDet
       Polysemy.Internal.Strategy
@@ -73,6 +74,7 @@ library
       Polysemy.Internal.Union
       Polysemy.Internal.WeaveClass
       Polysemy.Internal.Writer
+      Polysemy.Interpretation
       Polysemy.IO
       Polysemy.Law
       Polysemy.Membership

src/Polysemy.hs

@@ -107,6 +107,7 @@ module Polysemy
   , transform
 
     -- * Combinators for Interpreting Higher-Order Effects
+  , EffHandlerH
   , interpretNew
   , interceptNew
   , reinterpretNew
@@ -135,9 +136,15 @@ module Polysemy
     -- | When interpreting higher-order effects using 'interpretNew'
     -- and friends, you can't execute higher-order \"thunks\" given by
     -- the interpreted effect directly. Instead, these must be executed
-    -- using 'runH'.
+    -- using 'runH' or 'runH''.
+    --
+    -- These functions are enough for most purposes when using
+    -- 'interpretNew'. However, "Polysemy.Interpretation" offers
+    -- additional, more complicated features which are occassionally
+    -- needed.
   , RunH
   , runH
+  , runH'
 
     -- * Tactics
     -- | Higher-order effects need to explicitly thread /other effects'/ state
@@ -164,6 +171,7 @@ module Polysemy
 import Polysemy.Final
 import Polysemy.Internal
 import Polysemy.Internal.Combinators
+import Polysemy.Internal.Interpretation
 import Polysemy.Internal.Forklift
 import Polysemy.Internal.Kind
 import Polysemy.Internal.Tactics

src/Polysemy/Async.hs

@@ -21,6 +21,7 @@ module Polysemy.Async
 import qualified Control.Concurrent.Async as A
 import           Polysemy
 import           Polysemy.Final
+import           Polysemy.Interpretation
 
 
 
@@ -72,16 +73,16 @@ asyncToIO
     => Sem (Async ': r) a
     -> Sem r a
 asyncToIO m = withLowerToIO $ \lower _ -> lower $
-  interpretH
+  interpretNew
     ( \case
-        Async a -> do
-          ma  <- runT a
-          ins <- getInspectorT
-          fa  <- embed $ A.async $ lower $ asyncToIO ma
-          pureT $ inspect ins <$> fa
-
-        Await a -> pureT =<< embed (A.wait a)
-        Cancel a -> pureT =<< embed (A.cancel a)
+        Async ma -> do
+          Processor pr  <- getProcessorH'
+          fa  <- embed $ A.async $ lower $ asyncToIO (pr ma)
+          let ins = foldr (const . Just) Nothing
+          return (fmap ins fa)
+
+        Await a -> embed (A.wait a)
+        Cancel a -> embed (A.cancel a)
     )  m
 {-# INLINE asyncToIO #-}
 
@@ -126,16 +127,16 @@ lowerAsync
        -- some combination of 'runM' and other interpreters composed via '.@'.
     -> Sem (Async ': r) a
     -> Sem r a
-lowerAsync lower m = interpretH
+lowerAsync lower m = interpretNew
     ( \case
-        Async a -> do
-          ma  <- runT a
-          ins <- getInspectorT
-          fa  <- embed $ A.async $ lower $ lowerAsync lower ma
-          pureT $ inspect ins <$> fa
-
-        Await a -> pureT =<< embed (A.wait a)
-        Cancel a -> pureT =<< embed (A.cancel a)
+        Async ma -> do
+          Processor pr  <- getProcessorH
+          let ins = foldr (const . Just) Nothing
+          fa  <- embed $ A.async $ lower $ pr ma
+          return $ ins <$> fa
+
+        Await a -> embed (A.wait a)
+        Cancel a -> embed (A.cancel a)
     )  m
 {-# INLINE lowerAsync #-}
 {-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}

src/Polysemy/Error.hs

@@ -33,6 +33,7 @@ import           Data.Bifunctor (first)
 import           Data.Typeable
 import           Polysemy
 import           Polysemy.Final
+import           Polysemy.Interpretation
 import           Polysemy.Internal
 import           Polysemy.Internal.Union
 
@@ -217,21 +218,12 @@ mapError
   => (e1 -> e2)
   -> Sem (Error e1 ': r) a
   -> Sem r a
-mapError f = interpretH $ \case
+mapError f = interpretNew $ \case
   Throw e -> throw $ f e
-  Catch action handler -> do
-    a  <- runT action
-    h  <- bindT handler
-
-    mx <- raise $ runError a
-    case mx of
+  Catch action handler ->
+    runError (runH' action) >>= \case
       Right x -> pure x
-      Left e -> do
-        istate <- getInitialStateT
-        mx' <- raise $ runError $ h $ e <$ istate
-        case mx' of
-          Right x -> pure x
-          Left e' -> throw $ f e'
+      Left e  -> runH (handler e)
 {-# INLINE mapError #-}
 
 
@@ -318,13 +310,12 @@ runErrorAsExc
     => (∀ x. Sem r x -> IO x)
     -> Sem (Error e ': r) a
     -> Sem r a
-runErrorAsExc lower = interpretH $ \case
+runErrorAsExc lower = interpretNew $ \case
   Throw e -> embed $ X.throwIO $ WrappedExc e
   Catch main handle -> do
-    is <- getInitialStateT
-    m  <- runT main
-    h  <- bindT handle
-    let runIt = lower . runErrorAsExc lower
-    embed $ X.catch (runIt m) $ \(se :: WrappedExc e) ->
-      runIt $ h $ unwrapExc se <$ is
+    Processor pr  <- getProcessorH
+    let runIt = lower . pr
+    ta <- embed $ X.catch (runIt main) $ \(se :: WrappedExc e) ->
+      runIt $ handle $ unwrapExc se
+    restoreH ta
 {-# INLINE runErrorAsExc #-}

src/Polysemy/Internal/Combinators.hs

@@ -12,16 +12,6 @@ module Polysemy.Internal.Combinators
   , rewrite
   , transform
 
-    -- * Higher order
-  , RunH(..)
-  , runH
-
-  , interpretNew
-  , interceptNew
-  , reinterpretNew
-  , reinterpret2New
-  , reinterpret3New
-
     -- * Higher order with 'Tactical'
   , interpretH
   , interceptH
@@ -32,7 +22,6 @@ module Polysemy.Internal.Combinators
   -- * Conditional
   , interceptUsing
   , interceptUsingH
-  , interceptUsingNew
 
     -- * Statefulness
   , stateful
@@ -419,149 +408,3 @@ transform f (Sem m) = Sem $ \k -> m $ \u ->
     Left g -> g
     Right (Weaving e mkT lwr ex) ->
       injWeaving (Weaving (f e) mkT lwr ex)
-
-
--- | An effect for running monadic actions within a higher-order effect
--- currently being interpreted.
-newtype RunH z (m :: * -> *) a where
-  RunH :: z a -> RunH z m a
-
--- | Run a monadic action given by a higher-order effect that is currently
--- being interpreted.
---
--- @since TODO
-runH :: Member (RunH z) r => z a -> Sem r a
-runH = send . RunH
-
-------------------------------------------------------------------------------
--- | Like 'interpret', but for higher-order effects (i.e. those which make use
--- of the @m@ parameter.)
---
--- This is significantly easier to use than 'interpretH' and its corresponding
--- 'Tactical' environment.
--- Because of this, 'interpretNew' and friends are /heavily recommended/ over
--- 'interpretH' and friends /unless/ you need the extra power that the 'Tactical'
--- environment provides -- the ability to inspect and manipulate the underlying
--- effectful state.
---
--- Higher-order thunks within the effect to be interpreted can be run using
--- 'runH'. For example:
---
--- @
--- data Bind m a where
---   Bind :: m a -> (a -> m b) -> Bind m b
---
--- runBind :: Sem (Bind ': r) a -> Sem r a
--- runBind = 'interpretNew' \\case
---   Bind ma f -> do
---     a <- 'runH' ma
---     b <- 'runH' (f a)
---     return b
--- @
---
--- @since TODO
-interpretNew :: forall e r a
-              . (forall z x. e z x -> Sem (RunH z ': r) x)
-             -> Sem (e ': r) a
-             -> Sem r a
-interpretNew h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) ->
-  sem $ \u -> case decomp (hoist (interpretNew h) u) of
-    Left g -> k g
-    Right (Weaving e
-                 (mkT :: forall n x
-                       . Monad n
-                      => (forall y. Sem r y -> n y)
-                      -> z x -> t n x
-                 )
-                 lwr
-                 ex
-          ) ->
-      let
-          go1 :: forall x. Sem (RunH z ': r) x -> t m x
-          go1 = usingSem $ \u' -> case decomp u' of
-            Right (Weaving (RunH z) _ lwr' ex') ->
-              (ex' . (<$ mkInitState lwr')) <$> mkT (usingSem k) z
-            Left g -> liftHandlerWithNat go2 k g
-
-          go2 :: forall x. Sem (RunH z ': r) x -> t (Sem r) x
-          go2 = usingSem $ \u' -> case decomp (hoist go2 u') of
-            Right (Weaving (RunH z) _ lwr' ex') ->
-              (ex' . (<$ mkInitState lwr')) <$> mkT id z
-            Left g -> liftHandler liftSem g
-      in
-        fmap ex $ lwr $ go1 (h e)
-
--- TODO (KingoftheHomeless): If it matters, optimize the definitions
--- below
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret', but for higher-order effects.
---
--- This is /heavily recommended/ over 'reinterpretH' unless you need
--- the extra power that the 'Tactical' environment provides.
---
--- @since TODO
-reinterpretNew :: forall e1 e2 r a
-                . (forall z x. e1 z x -> Sem (RunH z ': e2 ': r) x)
-               -> Sem (e1 ': r) a
-               -> Sem (e2 ': r) a
-reinterpretNew h = interpretNew h . raiseUnder
-{-# INLINE reinterpretNew #-}
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret2', but for higher-order effects.
---
--- This is /heavily recommended/ over 'reinterpret2H' unless you need
--- the extra power that the 'Tactical' environment provides.
---
--- @since TODO
-reinterpret2New :: forall e1 e2 e3 r a
-                 . (forall z x. e1 z x -> Sem (RunH z ': e2 ': e3 ': r) x)
-                -> Sem (e1 ': r) a
-                -> Sem (e2 ': e3 ': r) a
-reinterpret2New h = interpretNew h . raiseUnder2
-{-# INLINE reinterpret2New #-}
-
-------------------------------------------------------------------------------
--- | Like 'reinterpret3', but for higher-order effects.
---
--- This is /heavily recommended/ over 'reinterpret3H' unless you need
--- the extra power that the 'Tactical' environment provides.
---
--- @since TODO
-reinterpret3New :: forall e1 e2 e3 e4 r a
-                 . (forall z x. e1 z x -> Sem (RunH z ': e2 ': e3 ': e4 ': r) x)
-                -> Sem (e1 ': r) a
-                -> Sem (e2 ': e3 ': e4 ': r) a
-reinterpret3New h = interpretNew h . raiseUnder3 
-{-# INLINE reinterpret3New #-}
-
-------------------------------------------------------------------------------
--- | Like 'intercept', but for higher-order effects.
---
--- This is /heavily recommended/ over 'interceptH' unless you need
--- the extra power that the 'Tactical' environment provides.
---
--- @since TODO
-interceptNew :: forall e r a
-              . Member e r
-             => (forall z x. e z x -> Sem (RunH z ': r) x)
-             -> Sem r a
-             -> Sem r a
-interceptNew h = interpretNew h . expose
-{-# INLINE interceptNew #-}
-
-------------------------------------------------------------------------------
--- | Like 'interceptUsing', but for higher-order effects.
---
--- This is /heavily recommended/ over 'interceptUsingH' unless you need
--- the extra power that the 'Tactical' environment provides.
---
--- @since TODO
-interceptUsingNew :: forall e r a
-                   . ElemOf e r
-                  -> (forall z x. e z x -> Sem (RunH z ': r) x)
-                  -> Sem r a
-                  -> Sem r a
-interceptUsingNew pr h = interpretNew h . exposeUsing pr
-{-# INLINE interceptUsingNew #-}