From 537b3cbaadc42a9849f68be71d536b47bea52260 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Thu, 14 Feb 2019 14:47:35 -0500
Subject: [PATCH] more combinators

---
 src/Eff/{Combinators.hs => Interpretation.hs} | 33 +++++++++++--------
 src/Eff/Type.hs                               | 10 +++++-
 src/Lib.hs                                    | 20 ++++++-----
 3 files changed, 40 insertions(+), 23 deletions(-)
 rename src/Eff/{Combinators.hs => Interpretation.hs} (89%)

diff --git a/src/Eff/Combinators.hs b/src/Eff/Interpretation.hs
similarity index 89%
rename from src/Eff/Combinators.hs
rename to src/Eff/Interpretation.hs
index 26bae94..e30abcf 100644
--- a/src/Eff/Combinators.hs
+++ b/src/Eff/Interpretation.hs
@@ -4,7 +4,7 @@
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE TypeOperators         #-}
 
-module Eff.Combinators where
+module Eff.Interpretation where
 
 import qualified Control.Monad.Trans.Except as E
 import           Control.Monad.Trans.Cont
@@ -35,12 +35,12 @@ interpret f (Freer m) = Freer $ \k -> m $ \u ->
 
 ------------------------------------------------------------------------------
 -- | Like 'interpret', but with access to intermediate state.
-interpretS
+stateful
     :: (eff ~> S.StateT s (Eff r))
     -> s
     -> Eff (eff ': r) ~> Eff r
-interpretS f s = transform (flip S.evalStateT s) f
-{-# INLINE interpretS #-}
+stateful f s = transform (flip S.evalStateT s) f
+{-# INLINE stateful #-}
 
 
 ------------------------------------------------------------------------------
@@ -48,8 +48,8 @@ interpretS f s = transform (flip S.evalStateT s) f
 -- useful for interpreters which would like to introduce some intermediate
 -- effects before immediately handling them.
 replace
-    :: (eff ~> eff')
-    -> Eff (eff ': r) ~> Eff (eff' ': r)
+    :: (eff1 ~> eff2)
+    -> Eff (eff1 ': r) ~> Eff (eff2 ': r)
 replace = naturally weaken
 {-# INLINE replace #-}
 
@@ -80,6 +80,20 @@ shortCircuit
     -> Eff (eff ': r) a
     -> Eff r (Either e a)
 shortCircuit f = transform E.runExceptT $ \e -> f e
+{-# INLINE shortCircuit #-}
+
+
+------------------------------------------------------------------------------
+-- | Intercept an effect without removing it from the effect stack.
+intercept
+    :: Member eff r
+    => (eff ~> Eff r)
+    -> Eff r ~> Eff r
+intercept f (Freer m) = Freer $ \k -> m $ \u ->
+  case prj u of
+    Nothing -> k u
+    Just e  -> runIt k $ f e
+{-# INLINE intercept #-}
 
 
 ------------------------------------------------------------------------------
@@ -116,13 +130,6 @@ naturally z f (Freer m) = Freer $ \k -> m $ \u ->
 {-# INLINE naturally #-}
 
 
-------------------------------------------------------------------------------
--- | Analogous to MTL's 'lift'.
-raise :: Eff r a -> Eff (u ': r) a
-raise = hoistEff weaken
-{-# INLINE raise #-}
-
-
 ------------------------------------------------------------------------------
 -- | Introduce a new effect directly underneath the top of the stack. This is
 -- often useful for interpreters which would like to introduce some intermediate
diff --git a/src/Eff/Type.hs b/src/Eff/Type.hs
index 5df1a42..848f2dd 100644
--- a/src/Eff/Type.hs
+++ b/src/Eff/Type.hs
@@ -58,6 +58,7 @@ liftEff :: f x -> Freer f x
 liftEff u = Freer $ \k -> k u
 {-# INLINE liftEff #-}
 
+
 type f ~> g = forall x. f x -> g x
 infixr 1 ~>
 
@@ -68,7 +69,7 @@ send t = Freer $ \k -> k $ inj t
 
 
 runM :: Monad m => Freer (Union '[m]) a -> m a
-runM z = runFreer z extract
+runM = runIt extract
 {-# INLINE runM #-}
 
 
@@ -79,3 +80,10 @@ run = runIdentity . runM
 
 runIt :: Monad m => (forall t. f t -> m t) -> Freer f a -> m a
 runIt k m = runFreer m k
+
+------------------------------------------------------------------------------
+-- | Analogous to MTL's 'lift'.
+raise :: Eff r a -> Eff (u ': r) a
+raise = hoistEff weaken
+{-# INLINE raise #-}
+
diff --git a/src/Lib.hs b/src/Lib.hs
index 2161722..c2a947b 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -12,7 +12,7 @@ module Lib where
 import qualified Control.Monad.Trans.Except as E
 import qualified Control.Monad.Trans.State.Strict as S
 import           Data.OpenUnion
-import           Eff.Combinators
+import           Eff.Interpretation
 import           Eff.Type
 
 
@@ -39,20 +39,18 @@ foom = do
   get @String
 
 
-runTeletype :: forall r a. Member IO r => Eff (State String ': r) a -> Eff r a
-runTeletype = interpret bind
-  where
-    bind :: forall x. State String x -> Eff r x
-    bind Get     = send getLine
-    bind (Put s) = send $ putStrLn s
+runTeletype :: Member IO r => Eff (State String ': r) a -> Eff r a
+runTeletype = interpret $ \case
+    Get   -> send getLine
+    Put s -> send $ putStrLn s
 
 
 -- main :: IO ()
 -- main = runM (runState "fuck" foom) >>= print
 
 
-runState :: forall s r a. s -> Eff (State s ': r) a -> Eff r a
-runState = interpretS $ \case
+runState :: s -> Eff (State s ': r) a -> Eff r a
+runState = stateful $ \case
   Get    -> S.get
   Put s' -> S.put s'
 
@@ -73,3 +71,7 @@ runError = shortCircuit $ \(Error e) -> E.throwE e
 runErrorRelay :: Eff (Error e ': r) a -> Eff r (Either e a)
 runErrorRelay = relay (pure . Right) $ \(Error e) _ -> pure $ Left e
 
+
+subsume :: Member eff r => Eff (eff ': r) ~> Eff r
+subsume = interpret send
+