From de715879265832506b6f377a31f47dd787bb59e1 Mon Sep 17 00:00:00 2001
From: Alex Mason <Alex.Mason@data61.csiro.au>
Date: Fri, 9 Jun 2017 21:53:55 +1000
Subject: [PATCH 1/2] Add key handler functions for dealing with Writers and
 Trace interactively

---
 src/Control/Monad/Freer/Trace.hs  | 10 +++++++++-
 src/Control/Monad/Freer/Writer.hs | 29 ++++++++++++++++++++++++++++-
 2 files changed, 37 insertions(+), 2 deletions(-)

diff --git a/src/Control/Monad/Freer/Trace.hs b/src/Control/Monad/Freer/Trace.hs
index d617732..435f43f 100644
--- a/src/Control/Monad/Freer/Trace.hs
+++ b/src/Control/Monad/Freer/Trace.hs
@@ -20,6 +20,7 @@ module Control.Monad.Freer.Trace
     ( Trace(..)
     , trace
     , runTrace
+    , handleTrace
     )
   where
 
@@ -28,7 +29,7 @@ import Data.Function ((.))
 import Data.String (String)
 import System.IO (IO, putStrLn)
 
-import Control.Monad.Freer.Internal (Eff(E, Val), Member, extract, qApp, send)
+import Control.Monad.Freer.Internal (Eff(E, Val), Member, extract, qApp, send, handleRelay)
 
 
 -- | A Trace effect; takes a 'String' and performs output.
@@ -44,3 +45,10 @@ runTrace :: Eff '[Trace] a -> IO a
 runTrace (Val x) = return x
 runTrace (E u q) = case extract u of
     Trace s -> putStrLn s >> runTrace (qApp q ())
+
+
+-- | Handle trace messages using another effect, such as IO
+--
+-- > runM . handleTrace putStrLn == runTrace
+handleTrace :: (Member m effs) => (String -> m ()) -> Eff (Trace ': effs) a -> Eff effs a
+handleTrace f = handleRelay return (\(Trace s) k -> send (f s) >> k ())
diff --git a/src/Control/Monad/Freer/Writer.hs b/src/Control/Monad/Freer/Writer.hs
index 1c73987..d0c71d7 100644
--- a/src/Control/Monad/Freer/Writer.hs
+++ b/src/Control/Monad/Freer/Writer.hs
@@ -21,10 +21,12 @@ module Control.Monad.Freer.Writer
     ( Writer(..)
     , tell
     , runWriter
+    , handleWriter
+    , ignoreWriter
     )
   where
 
-import Control.Applicative (pure)
+import Control.Applicative (pure,(*>))
 import Control.Arrow (second)
 import Data.Function (($))
 import Data.Functor ((<$>))
@@ -45,3 +47,28 @@ tell w = send $ Writer w
 runWriter :: Monoid w => Eff (Writer w ': effs) a -> Eff effs (a, w)
 runWriter = handleRelay (\a -> pure (a, mempty)) $ \(Writer w) k ->
     second (w <>) <$> k ()
+
+-- | Process written values as they happen - useful for logging while interpreting an
+-- application instead of gathering all values:
+-- 
+-- >  handleWriter print :: (Member IO effs, Show a) => Eff (Writer a ': effs) b -> Eff effs b
+--
+-- This allows for multiple writers to be handled differently:
+--
+-- @
+-- newtype Debug = Debug String
+-- newtype Info  = Info String
+--
+-- ignoreDebug :: Member IO effs => Eff (Writer Debug : effs) a -> Eff effs a
+-- ignoreDebug = handleWriter (const (pure ()))
+--
+-- printInfo :: Member IO effs => Eff (Writer Info : effs) a -> Eff effs a
+-- printInfo = handleWriter (\(Info s) -> putStrLn s)
+-- @
+
+handleWriter :: (Member m effs) => (w -> m b) -> Eff (Writer w ': effs) a -> Eff effs a
+handleWriter prnt = handleRelay pure (\(Writer w) k -> send (prnt w) *> k ())
+
+-- | Ignore written values of a particular type.
+ignoreWriter :: proxy w -> Eff (Writer w ': effs) a -> Eff effs a
+ignoreWriter _ = handleRelay pure (\(Writer _) k -> k ())

From 6e906c97f7664f3d9790a1211e3a3ad50f00c48f Mon Sep 17 00:00:00 2001
From: Alex Mason <Alex.Mason@data61.csiro.au>
Date: Fri, 9 Jun 2017 22:05:34 +1000
Subject: [PATCH 2/2] Use >>= because bottoms shouldn't be ignored if wanted

---
 src/Control/Monad/Freer/Trace.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Control/Monad/Freer/Trace.hs b/src/Control/Monad/Freer/Trace.hs
index 435f43f..77147c7 100644
--- a/src/Control/Monad/Freer/Trace.hs
+++ b/src/Control/Monad/Freer/Trace.hs
@@ -24,7 +24,7 @@ module Control.Monad.Freer.Trace
     )
   where
 
-import Control.Monad ((>>), return)
+import Control.Monad ((>>),(>>=), return)
 import Data.Function ((.))
 import Data.String (String)
 import System.IO (IO, putStrLn)
@@ -51,4 +51,4 @@ runTrace (E u q) = case extract u of
 --
 -- > runM . handleTrace putStrLn == runTrace
 handleTrace :: (Member m effs) => (String -> m ()) -> Eff (Trace ': effs) a -> Eff effs a
-handleTrace f = handleRelay return (\(Trace s) k -> send (f s) >> k ())
+handleTrace f = handleRelay return (\(Trace s) k -> send (f s) >>= k)