From 478c86e080f38334f7ea5b0259f900916db58c33 Mon Sep 17 00:00:00 2001 From: KingoftheHomeless Date: Wed, 18 Nov 2020 20:46:14 +0100 Subject: [PATCH] Simple variants of runT and bindT (#393) * Simple variants of runT and bindT * Fix accidental removal of INLINE on reinterpretH * Rename bindTH and runTH to -Simple instead. Improve docs on these. * Update changelog and add @since TODOs --- ChangeLog.md | 3 +- polysemy.cabal | 3 +- src/Polysemy.hs | 2 + src/Polysemy/Internal/Combinators.hs | 30 ++++++++------ src/Polysemy/Internal/Tactics.hs | 60 +++++++++++++++++++++++++--- test/TacticsSpec.hs | 22 ++++++++++ 6 files changed, 100 insertions(+), 20 deletions(-) create mode 100644 test/TacticsSpec.hs diff --git a/ChangeLog.md b/ChangeLog.md index 3ea7e23..766ebb7 100644 --- a/ChangeLog.md +++ b/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) diff --git a/polysemy.cabal b/polysemy.cabal index b8e380b..0c02cc2 100644 --- a/polysemy.cabal +++ b/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 diff --git a/src/Polysemy.hs b/src/Polysemy.hs index eee6004..2162f53 100644 --- a/src/Polysemy.hs +++ b/src/Polysemy.hs @@ -137,6 +137,8 @@ module Polysemy , WithTactics , getInitialStateT , pureT + , runTSimple + , bindTSimple , runT , bindT , getInspectorT diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs index 458ccbe..dd8b459 100644 --- a/src/Polysemy/Internal/Combinators.hs +++ b/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 #-} diff --git a/src/Polysemy/Internal/Tactics.hs b/src/Polysemy/Internal/Tactics.hs index ad0b92c..32bc991 100644 --- a/src/Polysemy/Internal/Tactics.hs +++ b/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 #-} diff --git a/test/TacticsSpec.hs b/test/TacticsSpec.hs new file mode 100644 index 0000000..91da893 --- /dev/null +++ b/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