diff --git a/src/Control/Monad/Freer/Trace.hs b/src/Control/Monad/Freer/Trace.hs index d617732..77147c7 100644 --- a/src/Control/Monad/Freer/Trace.hs +++ b/src/Control/Monad/Freer/Trace.hs @@ -20,15 +20,16 @@ module Control.Monad.Freer.Trace ( Trace(..) , trace , runTrace + , handleTrace ) where -import Control.Monad ((>>), return) +import Control.Monad ((>>),(>>=), return) 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 ())