GetInspectorT (#71)

* Evacuation wip

* Two other uses of weave

* Evacuator -> Inspector

* Inspector test

polysemy-plugin/test/InlineRecursiveCallsSpec.hs

@@ -44,9 +44,11 @@ recursive f s (Sem m) = Sem $ \k ->
     case decomp u of
         Left x -> S.StateT $ \s' ->
           k . fmap swap
-            . weave (s', ()) (uncurry $ recursive f)
+            . weave (s', ())
+                    (uncurry $ recursive f)
+                    (Just . snd)
             $ x
-        Right (Yo e z _ y) ->
+        Right (Yo e z _ y _) ->
           fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e
 
 
@@ -61,9 +63,11 @@ mutual f s (Sem m) = Sem $ \k ->
     case decomp u of
         Left x -> S.StateT $ \s' ->
           k . fmap swap
-            . weave (s', ()) (uncurry $ mutual2 f)
+            . weave (s', ())
+                    (uncurry $ mutual2 f)
+                    (Just . snd)
             $ x
-        Right (Yo e z _ y) ->
+        Right (Yo e z _ y _) ->
           fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e
 {-# INLINE mutual #-}
 

polysemy.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: d24941def9c13073c8c65e68d2cb76cddd1df3fad645148e5dfffa914a749250
+-- hash: b20555250cc9624a2c4d56da690b1e2a110f7a0b6e8411f31fc8dbc544e10856
 
 name:           polysemy
 version:        0.2.1.0
@@ -91,6 +91,7 @@ test-suite polysemy-test
       AlternativeSpec
       FusionSpec
       HigherOrderSpec
+      InspectorSpec
       OutputSpec
       Paths_polysemy
   hs-source-dirs:

src/Polysemy.hs

@@ -107,6 +107,8 @@ module Polysemy
   , pureT
   , runT
   , bindT
+  , getInspectorT
+  , Inspector (..)
 
   -- * Deprecated Names
   -- | The following exports are deprecated, and are exposed only for

src/Polysemy/Error.hs

@@ -31,6 +31,11 @@ data Error e m a where
 makeSem ''Error
 
 
+hush :: Either e a -> Maybe a
+hush (Right a) = Just a
+hush (Left _) = Nothing
+
+
 ------------------------------------------------------------------------------
 -- | Run an 'Error' effect in the style of
 -- 'Control.Monad.Trans.Except.ExceptT'.
@@ -40,9 +45,12 @@ runError
 runError (Sem m) = Sem $ \k -> E.runExceptT $ m $ \u ->
   case decomp u of
     Left x -> E.ExceptT $ k $
-      weave (Right ()) (either (pure . Left) runError_b) x
-    Right (Yo (Throw e) _ _ _) -> E.throwE e
-    Right (Yo (Catch try handle) s d y) ->
+      weave (Right ())
+            (either (pure . Left) runError_b)
+            hush
+            x
+    Right (Yo (Throw e) _ _ _ _) -> E.throwE e
+    Right (Yo (Catch try handle) s d y _) ->
       E.ExceptT $ usingSem k $ do
         ma <- runError_b $ d $ try <$ s
         case ma of

src/Polysemy/Internal.hs

@@ -334,7 +334,7 @@ run (Sem m) = runIdentity $ m absurdU
 runM :: Monad m => Sem '[Lift m] a -> m a
 runM (Sem m) = m $ \z ->
   case extract z of
-    Yo e s _ f -> do
+    Yo e s _ f _ -> do
       a <- unLift e
       pure $ f $ a <$ s
 {-# INLINE runM #-}

src/Polysemy/Internal/Combinators.hs

@@ -64,8 +64,8 @@ interpretH
 interpretH f (Sem m) = m $ \u ->
   case decomp u of
     Left  x -> liftSem $ hoist (interpretH_b f) x
-    Right (Yo e s d y) -> do
-      a <- runTactics s d (f e)
+    Right (Yo e s d y v) -> do
+      a <- runTactics s d v $ f e
       pure $ y a
 {-# INLINE interpretH #-}
 
@@ -82,9 +82,11 @@ interpretInStateT f s (Sem m) = Sem $ \k ->
     case decomp u of
         Left x -> S.StateT $ \s' ->
           k . fmap swap
-            . weave (s', ()) (uncurry $ interpretInStateT_b f)
+            . weave (s', ())
+                    (uncurry $ interpretInStateT_b f)
+                    (Just . snd)
             $ x
-        Right (Yo e z _ y) ->
+        Right (Yo e z _ y _) ->
           fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e
 {-# INLINE interpretInStateT #-}
 
@@ -101,9 +103,11 @@ interpretInLazyStateT f s (Sem m) = Sem $ \k ->
     case decomp u of
         Left x -> LS.StateT $ \s' ->
           k . fmap swap
-            . weave (s', ()) (uncurry $ interpretInLazyStateT_b f)
+            . weave (s', ())
+                    (uncurry $ interpretInLazyStateT_b f)
+                    (Just . snd)
             $ x
-        Right (Yo e z _ y) ->
+        Right (Yo e z _ y _) ->
           fmap (y . (<$ z)) $ LS.mapStateT (usingSem k) $ f e
 {-# INLINE interpretInLazyStateT #-}
 
@@ -141,8 +145,8 @@ reinterpretH
 reinterpretH f (Sem m) = Sem $ \k -> m $ \u ->
   case decompCoerce u of
     Left x  -> k $ hoist (reinterpretH_b f) $ x
-    Right (Yo e s d y) -> do
-      a <- usingSem k $ runTactics s (raiseUnder . d) $ f e
+    Right (Yo e s d y v) -> do
+      a <- usingSem k $ runTactics s (raiseUnder . d) v $ f e
       pure $ y a
 {-# INLINE[3] reinterpretH #-}
 -- TODO(sandy): Make this fuse in with 'stateful' directly.
@@ -176,8 +180,8 @@ reinterpret2H
 reinterpret2H f (Sem m) = Sem $ \k -> m $ \u ->
   case decompCoerce u of
     Left x  -> k $ weaken $ hoist (reinterpret2H_b f) $ x
-    Right (Yo e s d y) -> do
-      a <- usingSem k $ runTactics s (raiseUnder2 . d) $ f e
+    Right (Yo e s d y v) -> do
+      a <- usingSem k $ runTactics s (raiseUnder2 . d) v $ f e
       pure $ y a
 {-# INLINE[3] reinterpret2H #-}
 
@@ -206,8 +210,8 @@ reinterpret3H
 reinterpret3H f (Sem m) = Sem $ \k -> m $ \u ->
   case decompCoerce u of
     Left x  -> k . weaken . weaken . hoist (reinterpret3H_b f) $ x
-    Right (Yo e s d y) -> do
-      a <- usingSem k $ runTactics s (raiseUnder3 . d) $ f e
+    Right (Yo e s d y v) -> do
+      a <- usingSem k $ runTactics s (raiseUnder3 . d) v $ f e
       pure $ y a
 {-# INLINE[3] reinterpret3H #-}
 
@@ -256,8 +260,8 @@ interceptH
     -> Sem r a
 interceptH f (Sem m) = Sem $ \k -> m $ \u ->
   case prj u of
-    Just (Yo e s d y) ->
-      usingSem k $ fmap y $ runTactics s (raise . d) $ f e
+    Just (Yo e s d y v) ->
+      usingSem k $ fmap y $ runTactics s (raise . d) v $ f e
     Nothing -> k u
 {-# INLINE interceptH #-}
 

src/Polysemy/Internal/Effect.hs

@@ -63,6 +63,7 @@ class Effect e where
       :: (Functor s, Functor m, Functor n)
       => s ()
       -> (∀ x. s (m x) -> n (s x))
+      -> (∀ x. s x -> Maybe x)
       -> e m a
       -> e n (s a)
 
@@ -75,9 +76,10 @@ class Effect e where
          )
       => s ()
       -> (∀ x. s (m x) -> n (s x))
+      -> (∀ x. s x -> Maybe x)
       -> e m a
       -> e n (s a)
-  weave s _ = coerce . fmap' (<$ s)
+  weave s _ _ = coerce . fmap' (<$ s)
   {-# INLINE weave #-}
 
   -- | Lift a natural transformation from @m@ to @n@ over the effect. 'hoist'
@@ -118,5 +120,6 @@ defaultHoist f
   = fmap' runIdentity
   . weave (Identity ())
           (fmap Identity . f . runIdentity)
+          (Just . runIdentity)
 {-# INLINE defaultHoist #-}
 

src/Polysemy/Internal/Tactics.hs

@@ -1,10 +1,12 @@
-{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 
 {-# OPTIONS_HADDOCK not-home #-}
 
 module Polysemy.Internal.Tactics
   ( Tactics (..)
   , getInitialStateT
+  , getInspectorT
+  , Inspector (..)
   , runT
   , bindT
   , pureT
@@ -78,6 +80,7 @@ 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)
 
 
 ------------------------------------------------------------------------------
@@ -88,6 +91,40 @@ getInitialStateT :: forall f m r e. Sem (WithTactics e f m r) (f ())
 getInitialStateT = send @(Tactics _ m (e ': r)) GetInitialState
 
 
+------------------------------------------------------------------------------
+-- | Get a natural transformation capable of potentially inspecting values
+-- inside of @f@. Binding the result of 'getInspectorT' produces a function that
+-- can sometimes peek inside values returned by 'bindT'.
+--
+-- This is often useful for running callback functions that are not managed by
+-- polysemy code.
+--
+-- ==== Example
+--
+-- We can use the result of 'getInspectT' to "undo" 'pureT' (or any of the other
+-- 'Tactical' functions):
+--
+-- @
+-- ins <- 'getInspectorT'
+-- fa <- 'pureT' "hello"
+-- fb <- 'pureT' True
+-- let a = 'inspect' ins fa   -- Just "hello"
+--     b = 'inspect' ins fb   -- Just True
+-- @
+--
+-- We
+getInspectorT :: forall e f m r. Sem (WithTactics e f m r) (Inspector f)
+getInspectorT = send @(Tactics _ m (e ': r)) GetInspector
+
+
+------------------------------------------------------------------------------
+-- | A container for 'inspect'. See the documentation for 'getInspectorT'.
+newtype Inspector f = Inspector
+  { inspect :: forall x. f x -> Maybe x
+    -- ^ See the documnetation for 'getInspectorT'.
+  }
+
+
 ------------------------------------------------------------------------------
 -- | Lift a value into 'Tactical'.
 pureT :: a -> Tactical e m r a
@@ -150,15 +187,18 @@ runTactics
    :: Functor f
    => f ()
    -> (∀ x. f (m x) -> Sem r2 (f x))
+   -> (∀ x. f x -> Maybe x)
    -> Sem (Tactics f m r2 ': r) a
    -> Sem r a
-runTactics s d (Sem m) = m $ \u ->
+runTactics s d v (Sem m) = m $ \u ->
   case decomp u of
-    Left x -> liftSem $ hoist (runTactics_b s d) x
-    Right (Yo GetInitialState s' _ y) ->
+    Left x -> liftSem $ hoist (runTactics_b s d v) x
+    Right (Yo GetInitialState s' _ y _) ->
       pure $ y $ s <$ s'
-    Right (Yo (HoistInterpretation na) s' _ y) -> do
+    Right (Yo (HoistInterpretation na) s' _ y _) -> do
       pure $ y $ (d . fmap na) <$ s'
+    Right (Yo GetInspector s' _ y _) -> do
+      pure $ y $ Inspector v <$ s'
 {-# INLINE runTactics #-}
 
 
@@ -166,6 +206,7 @@ runTactics_b
    :: Functor f
    => f ()
    -> (∀ x. f (m x) -> Sem r2 (f x))
+   -> (∀ x. f x -> Maybe x)
    -> Sem (Tactics f m r2 ': r) a
    -> Sem r a
 runTactics_b = runTactics

src/Polysemy/Internal/Union.hs

@@ -31,6 +31,7 @@ module Polysemy.Internal.Union
   , Nat (..)
   ) where
 
+import Control.Monad
 import Data.Functor.Compose
 import Data.Functor.Identity
 import Data.Type.Equality
@@ -61,24 +62,26 @@ data Yo e m a where
      -> f ()
      -> (forall x. f (m x) -> n (f x))
      -> (f a -> b)
+     -> (forall x. f x -> Maybe x)
      -> Yo e n b
 
 instance Functor (Yo e m) where
-  fmap f (Yo e s d f') = Yo e s d (f . f')
+  fmap f (Yo e s d f' v) = Yo e s d (f . f') v
   {-# INLINE fmap #-}
 
 instance Effect (Yo e) where
-  weave s' d (Yo e s nt f) =
+  weave s' d v' (Yo e s nt f v) =
     Yo e (Compose $ s <$ s')
          (fmap Compose . d . fmap nt . getCompose)
          (fmap f . getCompose)
+         (v <=< v' . getCompose)
   {-# INLINE weave #-}
 
   hoist = defaultHoist
   {-# INLINE hoist #-}
 
 liftYo :: Functor m => e m a -> Yo e m a
-liftYo e = Yo e (Identity ()) (fmap Identity . runIdentity) runIdentity
+liftYo e = Yo e (Identity ()) (fmap Identity . runIdentity) runIdentity (Just . runIdentity)
 {-# INLINE liftYo #-}
 
 
@@ -88,7 +91,7 @@ instance Functor (Union r m) where
 
 
 instance Effect (Union r) where
-  weave s f (Union w e) = Union w $ weave s f e
+  weave s f v (Union w e) = Union w $ weave s f v e
   {-# INLINE weave #-}
 
   hoist f (Union w e) = Union w $ hoist f e

src/Polysemy/NonDet.hs

@@ -10,6 +10,7 @@ module Polysemy.NonDet
   ) where
 
 import Control.Applicative
+import Data.Maybe
 import Polysemy.Internal
 import Polysemy.Internal.NonDet
 import Polysemy.Internal.Union
@@ -58,10 +59,14 @@ runNonDet :: Alternative f => Sem (NonDet ': r) a -> Sem r (f a)
 runNonDet (Sem m) = Sem $ \k -> runNonDetC $ m $ \u ->
   case decomp u of
     Left x  -> NonDetC $ \cons nil -> do
-      z <- k $ weave [()] (fmap concat . traverse runNonDet) x
+      z <- k $ weave [()]
+                     (fmap concat . traverse runNonDet)
+                     -- TODO(sandy): Is this the right semantics?
+                     listToMaybe
+                     x
       foldr cons nil z
-    Right (Yo Empty _ _ _) -> empty
-    Right (Yo (Choose ek) s _ y) -> do
+    Right (Yo Empty _ _ _ _) -> empty
+    Right (Yo (Choose ek) s _ y _) -> do
       z <- pure (ek False) <|> pure (ek True)
       pure $ y $ z <$ s
 

src/Polysemy/State.hs

@@ -105,9 +105,10 @@ hoistStateIntoStateT (Sem m) = m $ \u ->
               . weave (s, ())
                       (\(s', m') -> fmap swap
                                   $ S.runStateT m' s')
+                      (Just . snd)
               $ hoist hoistStateIntoStateT_b x
-    Right (Yo Get z _ y)     -> fmap (y . (<$ z)) $ S.get
-    Right (Yo (Put s) z _ y) -> fmap (y . (<$ z)) $ S.put s
+    Right (Yo Get z _ y _)     -> fmap (y . (<$ z)) $ S.get
+    Right (Yo (Put s) z _ y _) -> fmap (y . (<$ z)) $ S.put s
 {-# INLINE hoistStateIntoStateT #-}
 
 

test/InspectorSpec.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module InspectorSpec where
+
+import Control.Monad
+import Data.IORef
+import Polysemy
+import Polysemy.Error
+import Polysemy.State
+import Test.Hspec
+
+
+
+data Callback m a where
+  Callback :: m String -> Callback m ()
+
+makeSem ''Callback
+
+
+
+spec :: Spec
+spec = describe "Inspector" $ do
+  it "should inspect State effects" $ do
+    withNewTTY $ \ref -> do
+      void . (runM .@ runCallback ref)
+           . runState False
+           $ do
+        sendM $ pretendPrint ref "hello world"
+        callback $ show <$> get @Bool
+        modify not
+        callback $ show <$> get @Bool
+
+      result <- readIORef ref
+      result `shouldContain` ["hello world"]
+      result `shouldContain` ["False", "True"]
+
+  it "should not inspect thrown Error effects" $ do
+    withNewTTY $ \ref -> do
+      void . (runM .@ runCallback ref)
+           . runError @()
+           $ do
+        callback $ throw ()
+        callback $ pure "nice"
+
+      result <- readIORef ref
+      result `shouldContain` [":(", "nice"]
+
+
+runCallback
+    :: Member (Lift IO) r
+    => IORef [String]
+    -> (forall x. Sem r x -> IO x)
+    -> Sem (Callback ': r) a
+    -> Sem r a
+runCallback ref lower = interpretH $ \case
+  Callback cb -> do
+    cb' <- runT cb
+    ins <- getInspectorT
+    sendM $ doCB ref $ do
+      v <- lower .@ runCallback ref $ cb'
+      pure $ maybe ":(" id $ inspect ins v
+    getInitialStateT
+
+
+doCB :: IORef [String] -> IO String -> IO ()
+doCB ref m = m >>= pretendPrint ref
+
+
+pretendPrint :: IORef [String] -> String -> IO ()
+pretendPrint ref msg = modifyIORef ref (++ [msg])
+
+
+withNewTTY :: (IORef [String] -> IO a) -> IO a
+withNewTTY f = do
+  ref <- newIORef []
+  f ref
+