Trace in the Oven

changelog.md

@@ -29,6 +29,9 @@ All notable changes to this project will be documented in this file.
 * Introduced `raise` to weaken an effect stack.
   [PR #41](https://github.com/IxpertaSolutions/freer-effects/pull/41)
   (**new**)
+* Generalized `Trace` effect.
+  [PR #30](https://github.com/IxpertaSolutions/freer-effects/pull/30)
+  (**breaking-change**)
 
 ## [0.3.0.1] (April 16, 2017)
 

examples/src/Fresh.hs

@@ -1,13 +1,14 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 module Fresh (module Fresh) where
 
-import Data.Function (($), flip)
+import Data.Function (($), (.), flip)
 import Data.Monoid ((<>))
 import System.IO (IO)
 import Text.Show (show)
 
+import Control.Monad.Freer (runM)
 import Control.Monad.Freer.Fresh (evalFresh, fresh)
-import Control.Monad.Freer.Trace (runTrace, trace)
+import Control.Monad.Freer.Trace (runTraceIO, trace)
 
 
 -- | Generate two fresh values.
@@ -16,7 +17,7 @@ import Control.Monad.Freer.Trace (runTrace, trace)
 -- Fresh 0
 -- Fresh 1
 traceFresh :: IO ()
-traceFresh = runTrace $ flip evalFresh 0 $ do
+traceFresh = runM . runTraceIO $ flip evalFresh 0 $ do
     n <- fresh
     trace $ "Fresh " <> show n
     n' <- fresh

examples/src/Trace.hs

@@ -1,57 +1,110 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeOperators #-}
 module Trace (module Trace) where
 
-import Prelude ((+))
+import Prelude (Bounded, Enum, Integer, (*), (-), (^), maxBound, minBound)
 
-import Control.Applicative ((<$>), (<*>), pure)
-import Data.Function (($))
-import Data.Int (Int)
+import Control.Applicative (pure)
+import Control.Monad (forM_, void, when)
+import Data.Eq (Eq)
+import Data.Function (($), (.))
 import Data.Monoid ((<>))
-import System.IO (IO)
+import Data.Ord (Ord, (<), (<=))
+import Data.Proxy (Proxy(Proxy))
+import Data.String (String)
+import System.IO (IO, print, putStrLn)
 import Text.Show (Show(show))
 
-import Control.Monad.Freer (Eff, Member)
-import Control.Monad.Freer.Reader (ask, runReader)
-import Control.Monad.Freer.Trace (Trace, runTrace, trace)
-
-
--- Higher-order effectful function
--- The inferred type shows that the Trace affect is added to the effects
--- of r
-mapMdebug:: (Show a, Member Trace r) =>
-     (a -> Eff r b) -> [a] -> Eff r [b]
-mapMdebug _ [] = pure []
-mapMdebug f (h:t) = do
-  trace $ "mapMdebug: " <> show h
-  h' <- f h
-  t' <- mapMdebug f t
-  pure (h':t')
-
-tMd :: IO [Int]
-tMd = runTrace $ runReader (mapMdebug f [1..5]) (10::Int)
- where f x = (+) <$> ask <*> pure x
-{-
-mapMdebug: 1
-mapMdebug: 2
-mapMdebug: 3
-mapMdebug: 4
-mapMdebug: 5
-[11,12,13,14,15]
--}
-
--- duplicate layers
-tdup :: IO ()
-tdup = runTrace $ runReader m (10::Int)
- where
- m = do
-     runReader tr (20::Int)
-     tr
- tr = do
-      v <- ask
-      trace $ "Asked: " <> show (v::Int)
-{-
-Asked: 20
-Asked: 10
--}
+import Control.Monad.Freer (Eff, Member, Members, run, runM, send)
+import Control.Monad.Freer.State (State, execState, get, modify)
+import Control.Monad.Freer.Trace (Trace, runTrace, runTraceSilent, trace)
+
+
+data LogLevel = Debug | Info | Warn | Error
+  deriving (Bounded, Enum, Eq, Ord, Show)
+
+data LogItem = forall a . Show a => LogItem
+    { level :: LogLevel
+    , item :: a
+    }
+
+type Logger = Trace LogItem
+
+newtype Msg = Msg String
+
+instance Show Msg where
+    show (Msg s) = s
+
+debug :: (Member Logger effs, Show a) => a -> Eff effs ()
+debug = trace . LogItem Debug
+
+info :: (Member Logger effs, Show a) => a -> Eff effs ()
+info = trace . LogItem Info
+
+warn :: (Member Logger effs, Show a) => a -> Eff effs ()
+warn = trace . LogItem Warn
+
+debugMsg :: Member Logger effs => String -> Eff effs ()
+debugMsg = debug . Msg
+
+infoMsg :: Member Logger effs => String -> Eff effs ()
+infoMsg = info . Msg
+
+warnMsg :: Member Logger effs => String -> Eff effs ()
+warnMsg = warn . Msg
+
+runLogger
+    :: Member IO effs
+    => LogLevel -> Eff (Logger ': effs) a -> Eff effs a
+runLogger l = runTrace f
+  where
+    f LogItem{..} = when (l <= level) . send $ print item
+
+data FactState = FactState
+    { bits :: Integer
+    , currentValue :: Integer
+    }
+  deriving Show
+
+_bits :: (Integer -> Integer) -> FactState -> FactState
+_bits f s@FactState{..} = s{bits=f bits}
+
+_currentValue :: (Integer -> Integer) -> FactState -> FactState
+_currentValue f s@FactState{..} = s{currentValue=f currentValue}
+
+example :: IO ()
+example = do
+    forM_ [minBound..maxBound] $ \ ll -> do
+        putStrLn $ "Running `factDebug 10` with LogLevel = " <> show ll
+        void . runM . runLogger ll $ factDebug 10
+        putStrLn "Done...\n\n"
+    putStrLn "Fact as a pure function: "
+    print $ fact 10
+
+fact :: Integer -> Integer
+fact = purify . factDebug
+  where
+    purify = run . runTraceSilent (Proxy :: Proxy LogItem)
+
+factDebug :: Member Logger effs => Integer -> Eff effs Integer
+factDebug n = do
+    val@FactState{..} <- execState (factDebug' n) (FactState 8 1)
+    info (Msg "Result", val)
+    pure currentValue
+
+factDebug' :: Members [State FactState, Logger] effs => Integer -> Eff effs ()
+factDebug' n = forM_ [1..n] $ \m -> do
+    modify $ _currentValue (m*)
+    FactState{..} <- get
+    debug (Msg "current step", m, currentValue)
+    when (maxFromBits bits < currentValue) $ do
+        warnMsg $ "Value too large for " <> show bits <> " bit store"
+        modify $ _bits (2*)
+  where
+    maxFromBits b = 2^(b - 1) - 1

freer-effects.cabal

@@ -150,6 +150,7 @@ test-suite unit
       Tests.NonDet
       Tests.Reader
       Tests.State
+      Tests.Trace
   default-language: Haskell2010
 
 benchmark core