WIP: v2

polysemy-plugin/test/ExampleSpec.hs

@@ -34,7 +34,7 @@ program = catch @CustomException work $ \e -> writeTTY ("Caught " ++ show e)
 
 foo :: IO (Either CustomException ())
 foo =
-    runFinal
+    runM
   . embedToFinal @IO
   . resourceToIOFinal
   . errorToIOFinal @CustomException

polysemy.cabal

@@ -3,6 +3,8 @@ cabal-version: 2.0
 -- This file has been generated from package.yaml by hpack version 0.34.4.
 --
 -- see: https://github.com/sol/hpack
+--
+-- hash: 296ffb3e340f4324417e4d774a6aad757fa372fe33fd4551b4321bab6ff6564c
 
 name:           polysemy
 version:        1.6.0.0
@@ -52,6 +54,7 @@ library
       Polysemy.Error
       Polysemy.Fail
       Polysemy.Fail.Type
+      Polysemy.Fatal
       Polysemy.Final
       Polysemy.Fixpoint
       Polysemy.Input
@@ -60,30 +63,28 @@ library
       Polysemy.Internal.Combinators
       Polysemy.Internal.CustomErrors
       Polysemy.Internal.CustomErrors.Redefined
+      Polysemy.Internal.Final
       Polysemy.Internal.Fixpoint
-      Polysemy.Internal.Forklift
       Polysemy.Internal.Index
+      Polysemy.Internal.Interpretation
       Polysemy.Internal.Kind
       Polysemy.Internal.NonDet
       Polysemy.Internal.Sing
-      Polysemy.Internal.Strategy
-      Polysemy.Internal.Tactics
       Polysemy.Internal.TH.Common
       Polysemy.Internal.TH.Effect
       Polysemy.Internal.Union
+      Polysemy.Internal.WeaveClass
       Polysemy.Internal.Writer
+      Polysemy.Interpretation
       Polysemy.IO
-      Polysemy.Law
       Polysemy.Membership
       Polysemy.NonDet
       Polysemy.Output
       Polysemy.Reader
       Polysemy.Resource
       Polysemy.State
-      Polysemy.State.Law
       Polysemy.Tagged
       Polysemy.Trace
-      Polysemy.View
       Polysemy.Writer
   other-modules:
       Polysemy.Internal.PluginLookup
@@ -152,15 +153,11 @@ test-suite polysemy-test
       FixpointSpec
       FusionSpec
       HigherOrderSpec
-      InspectorSpec
       InterceptSpec
       KnownRowSpec
-      LawsSpec
       OutputSpec
-      TacticsSpec
       ThEffectSpec
       TypeErrors
-      ViewSpec
       WriterSpec
       Paths_polysemy
       Build_doctests

src/Polysemy.hs

@@ -8,7 +8,6 @@ module Polysemy
     -- * Running Sem
   , run
   , runM
-  , runFinal
 
     -- * Type synonyms for user convenience
   , InterpreterFor
@@ -109,15 +108,13 @@ module Polysemy
   , transform
 
     -- * Combinators for Interpreting Higher-Order Effects
+  , EffHandlerH
   , interpretH
   , interceptH
   , reinterpretH
   , reinterpret2H
   , reinterpret3H
 
-    -- * Combinators for Interpreting Directly to IO
-  , withLowerToIO
-
     -- * Kind Synonyms
   , Effect
   , EffectRow
@@ -126,31 +123,25 @@ module Polysemy
   , (.@)
   , (.@@)
 
-    -- * Tactics
-    -- | Higher-order effects need to explicitly thread /other effects'/ state
-    -- through themselves. Tactics are a domain-specific language for describing
-    -- exactly how this threading should take place.
+    -- * 'RunH'
+    -- | When interpreting higher-order effects using 'interpretH'
+    -- and friends, you can't execute higher-order \"thunks\" given by
+    -- the interpreted effect directly. Instead, these must be executed
+    -- using 'runH' or 'runH''.
     --
-    -- The first computation to be run should use 'runT', and subsequent
-    -- computations /in the same environment/ should use 'bindT'. Any
-    -- first-order constructors which appear in a higher-order context may use
-    -- 'pureT' to satisfy the typechecker.
-  , Tactical
-  , WithTactics
-  , getInitialStateT
-  , pureT
-  , runTSimple
-  , bindTSimple
-  , runT
-  , bindT
-  , getInspectorT
-  , Inspector (..)
+    -- These functions are enough for most purposes when using
+    -- 'interpretH'. However, "Polysemy.Interpretation" offers
+    -- additional, more complicated features which are occassionally
+    -- needed.
+  , RunH
+  , runH
+  , runH'
+
   ) where
 
 import Polysemy.Final
 import Polysemy.Internal
 import Polysemy.Internal.Combinators
-import Polysemy.Internal.Forklift
+import Polysemy.Internal.Interpretation
 import Polysemy.Internal.Kind
-import Polysemy.Internal.Tactics
 import Polysemy.Internal.TH.Effect

src/Polysemy/Async.hs

@@ -13,9 +13,7 @@ module Polysemy.Async
   , sequenceConcurrently
 
     -- * Interpretations
-  , asyncToIO
   , asyncToIOFinal
-  , lowerAsync
   ) where
 
 import qualified Control.Concurrent.Async as A
@@ -48,42 +46,6 @@ sequenceConcurrently :: forall t r a. (Traversable t, Member Async r) =>
 sequenceConcurrently t = traverse async t >>= traverse await
 {-# INLINABLE sequenceConcurrently #-}
 
-------------------------------------------------------------------------------
--- | A more flexible --- though less performant ---
--- version of 'asyncToIOFinal'.
---
--- This function is capable of running 'Async' effects anywhere within an
--- effect stack, without relying on 'Final' to lower it into 'IO'.
--- Notably, this means that 'Polysemy.State.State' effects will be consistent
--- in the presence of 'Async'.
---
--- 'asyncToIO' is __unsafe__ if you're using 'await' inside higher-order actions
--- of other effects interpreted after 'Async'.
--- See <https://github.com/polysemy-research/polysemy/issues/205 Issue #205>.
---
--- Prefer 'asyncToIOFinal' unless you need to run pure, stateful interpreters
--- after the interpreter for 'Async'.
--- (Pure interpreters are interpreters that aren't expressed in terms of
--- another effect or monad; for example, 'Polysemy.State.runState'.)
---
--- @since 1.0.0.0
-asyncToIO
-    :: Member (Embed IO) r
-    => Sem (Async ': r) a
-    -> Sem r a
-asyncToIO m = withLowerToIO $ \lower _ -> lower $
-  interpretH
-    ( \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)
-    )  m
-{-# INLINE asyncToIO #-}
 
 ------------------------------------------------------------------------------
 -- | Run an 'Async' effect in terms of 'A.async' through final 'IO'.
@@ -106,36 +68,10 @@ asyncToIO m = withLowerToIO $ \lower _ -> lower $
 asyncToIOFinal :: Member (Final IO) r
                => Sem (Async ': r) a
                -> Sem r a
-asyncToIOFinal = interpretFinal $ \case
-  Async m -> do
-    ins <- getInspectorS
-    m'  <- runS m
-    liftS $ A.async (inspect ins <$> m')
-  Await a -> liftS (A.wait a)
-  Cancel a -> liftS (A.cancel a)
+asyncToIOFinal = interpretFinal @IO $ \case
+  Async m -> liftWithS $ \lower -> do
+    fmap (foldr (const . Just) Nothing) <$> A.async (lower m)
+  Await a -> embed (A.wait a)
+  Cancel a -> embed (A.cancel a)
 {-# INLINE asyncToIOFinal #-}
 
-------------------------------------------------------------------------------
--- | Run an 'Async' effect in terms of 'A.async'.
---
--- @since 1.0.0.0
-lowerAsync
-    :: Member (Embed IO) r
-    => (forall x. Sem r x -> IO x)
-       -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely
-       -- some combination of 'runM' and other interpreters composed via '.@'.
-    -> Sem (Async ': r) a
-    -> Sem r a
-lowerAsync lower m = interpretH
-    ( \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)
-    )  m
-{-# INLINE lowerAsync #-}
-{-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}

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 (extendMembershipRight @r' @r pr) $ Weaving e s wv ex ins
+  Right (Weaving (Bundle pr e) mkT lwr ex) ->
+    Union (extendMembershipRight @r' @r pr) $ Weaving e mkT lwr ex
   Left g -> weakenList @r' @r (singList @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 #-}