Simple variants of runT and bindT

ChangeLog.md

@@ -2,7 +2,8 @@
 
 
 ## Unreleased changes
-* Added `InterpretersFor` as a shorthand for interpreters consuming multiple effects
+- Added `InterpretersFor` as a shorthand for interpreters consuming multiple effects
+- Added `runTSimple` and `bindTSimple`, which are simplified variants of `runT` and `bindT`
 
 ## 1.4.0.0 (2020-10-31)
 

polysemy.cabal

@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 5b7f95eb8e97177f60ae7387f50e8594297ee64259fcac3310f3cc83edef6531
+-- hash: 9d61a6c298262f3e765c48ccc01f30cd9c328104777970c3529931c4d5c4ca22
 
 name:           polysemy
 version:        1.4.0.0
@@ -143,6 +143,7 @@ test-suite polysemy-test
       KnownRowSpec
       LawsSpec
       OutputSpec
+      TacticsSpec
       ThEffectSpec
       TypeErrors
       ViewSpec

src/Polysemy.hs

@@ -137,6 +137,8 @@ module Polysemy
   , WithTactics
   , getInitialStateT
   , pureT
+  , runTSimple
+  , bindTSimple
   , runT
   , bindT
   , getInspectorT

src/Polysemy/Internal/Combinators.hs

@@ -80,12 +80,11 @@ interpretH
        -- already in 'Sem'.
     -> Sem (e ': r) a
     -> Sem r a
-interpretH f (Sem m) = m $ \u ->
+interpretH f (Sem m) = Sem $ \k -> m $ \u ->
   case decomp u of
-    Left  x -> liftSem $ hoist (interpretH f) x
+    Left  x -> k $ hoist (interpretH f) x
     Right (Weaving e s d y v) -> do
-      a <- runTactics s d v $ f e
-      pure $ y a
+      fmap y $ usingSem k $ runTactics s d v (interpretH f . d) $ f e
 {-# INLINE interpretH #-}
 
 ------------------------------------------------------------------------------
@@ -166,12 +165,13 @@ reinterpretH
        -- ^ 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 ->
+reinterpretH f sem = Sem $ \k -> runSem sem $ \u ->
   case decompCoerce u of
     Left x  -> k $ hoist (reinterpretH f) $ x
     Right (Weaving e s d y v) -> do
-      a <- usingSem k $ runTactics s (raiseUnder . d) v $ f e
-      pure $ y a
+      fmap y $ usingSem k
+             $ runTactics s (raiseUnder . d) v (reinterpretH f . d)
+             $ f e
 {-# INLINE[3] reinterpretH #-}
 -- TODO(sandy): Make this fuse in with 'stateful' directly.
 
@@ -208,8 +208,9 @@ 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
-      a <- usingSem k $ runTactics s (raiseUnder2 . d) v $ f e
-      pure $ y a
+      fmap y $ usingSem k
+             $ runTactics s (raiseUnder2 . d) v (reinterpret2H f . d)
+             $ f e
 {-# INLINE[3] reinterpret2H #-}
 
 
@@ -241,9 +242,10 @@ reinterpret3H
 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
-      a <- usingSem k $ runTactics s (raiseUnder3 . d) v $ f e
-      pure $ y a
+    Right (Weaving e s d y v) ->
+      fmap y $ usingSem k
+             $ runTactics s (raiseUnder3 . d) v (reinterpret3H f . d)
+             $ f e
 {-# INLINE[3] reinterpret3H #-}
 
 
@@ -342,7 +344,9 @@ interceptUsingH
 interceptUsingH pr f (Sem m) = Sem $ \k -> m $ \u ->
   case prjUsing pr u of
     Just (Weaving e s d y v) ->
-      usingSem k $ y <$> runTactics s (raise . d) v (f e)
+      fmap y $ usingSem k
+             $ runTactics s (raise . d) v (interceptUsingH pr f . d)
+             $ f e
     Nothing -> k $ hoist (interceptUsingH pr f) u
 {-# INLINE interceptUsingH #-}
 

src/Polysemy/Internal/Tactics.hs

@@ -8,7 +8,9 @@ module Polysemy.Internal.Tactics
   , getInspectorT
   , Inspector (..)
   , runT
+  , runTSimple
   , bindT
+  , bindTSimple
   , pureT
   , liftT
   , runTactics
@@ -77,9 +79,10 @@ type Tactical e m r x = ∀ f. Functor f
 type WithTactics e f m r = Tactics f m (e ': r) ': r
 
 data Tactics f n r m a where
-  GetInitialState     :: Tactics f n r m (f ())
-  HoistInterpretation :: (a -> n b) -> Tactics f n r m (f a -> Sem r (f b))
-  GetInspector        :: Tactics f n r m (Inspector f)
+  GetInitialState      :: Tactics f n r m (f ())
+  HoistInterpretation  :: (a -> n b) -> Tactics f n r m (f a -> Sem r (f b))
+  HoistInterpretationH :: (a -> n b) -> f a -> Tactics f n r m (f b)
+  GetInspector         :: Tactics f n r m (Inspector f)
 
 
 ------------------------------------------------------------------------------
@@ -146,6 +149,26 @@ runT na = do
   pure $ na' istate
 {-# INLINE runT #-}
 
+------------------------------------------------------------------------------
+-- | Run a monadic action in a 'Tactical' environment. The stateful environment
+-- used will be the same one that the effect is initally run in.
+-- Use 'bindTSimple' if you'd prefer to explicitly manage your stateful
+-- environment.
+--
+-- This is a less flexible but significantly simpler variant of 'runT'.
+-- Instead of returning a 'Sem' action corresponding to the provided action,
+-- 'runTSimple' runs the action immediately.
+--
+-- @since TODO
+runTSimple :: m a
+              -- ^ The monadic action to lift. This is usually a parameter in your
+              -- effect.
+           -> Tactical e m r a
+runTSimple na = do
+  istate <- getInitialStateT
+  bindTSimple (const na) istate
+{-# INLINE runTSimple #-}
+
 
 ------------------------------------------------------------------------------
 -- | Lift a kleisli action into the stateful environment. You can use
@@ -163,6 +186,30 @@ bindT
 bindT f = send $ HoistInterpretation f
 {-# INLINE bindT #-}
 
+------------------------------------------------------------------------------
+-- | Lift a kleisli action into the stateful environment.
+-- You can use 'bindTSimple' to execute an effect parameter of the form
+-- @a -> m b@ by providing the result of a `runTSimple` or another
+-- `bindTSimple`.
+--
+-- This is a less flexible but significantly simpler variant of 'bindT'.
+-- Instead of returning a 'Sem' kleisli action corresponding to the
+-- provided kleisli action, 'bindTSimple' runs the kleisli action immediately.
+--
+-- @since TODO
+bindTSimple
+    :: forall m f r e a b
+     . (a -> m b)
+       -- ^ The monadic continuation to lift. This is usually a parameter in
+       -- your effect.
+       --
+       -- Continuations executed via 'bindTSimple' will run in the same
+       -- environment which produced the @a@.
+    -> f a
+    -> Sem (WithTactics e f m r) (f b)
+bindTSimple f s = send @(Tactics _ _ (e ': r)) $ HoistInterpretationH f s
+{-# INLINE bindTSimple #-}
+
 
 ------------------------------------------------------------------------------
 -- | Internal function to create first-order interpreter combinators out of
@@ -185,15 +232,18 @@ runTactics
    => f ()
    -> (∀ x. f (m x) -> Sem r2 (f x))
    -> (∀ x. f x -> Maybe x)
+   -> (∀ x. f (m x) -> Sem r (f x))
    -> Sem (Tactics f m r2 ': r) a
    -> Sem r a
-runTactics s d v (Sem m) = m $ \u ->
+runTactics s d v d' (Sem m) = Sem $ \k -> m $ \u ->
   case decomp u of
-    Left x -> liftSem $ hoist (runTactics s d v) x
+    Left x -> k $ hoist (runTactics s d v d') x
     Right (Weaving GetInitialState s' _ y _) ->
       pure $ y $ s <$ s'
     Right (Weaving (HoistInterpretation na) s' _ y _) -> do
       pure $ y $ (d . fmap na) <$ s'
+    Right (Weaving (HoistInterpretationH na fa) s' _ y _) -> do
+      (y . (<$ s')) <$> runSem (d' (fmap na fa)) k
     Right (Weaving GetInspector s' _ y _) -> do
       pure $ y $ Inspector v <$ s'
 {-# INLINE runTactics #-}

test/TacticsSpec.hs

@@ -0,0 +1,22 @@
+module TacticsSpec where
+
+import Polysemy
+import Polysemy.Internal (send)
+import Test.Hspec
+
+data TestE :: Effect where
+  TestE :: m a -> (a -> m b) -> TestE m b
+
+interpretTestE :: InterpreterFor TestE r
+interpretTestE =
+  interpretH $ \case
+    TestE ma f -> do
+      a <- runTSimple ma
+      bindTSimple f a
+
+spec :: Spec
+spec = parallel $ describe "runTH and bindTH" $ do
+  it "should act as expected" $ do
+    r <- runM (interpretTestE (send (TestE (pure 5) (pure . (9 +)))))
+    print r
+    (14 :: Int) `shouldBe` r