Extracting context for tracing/logging via haskell meta programming - haskell

In our haskell code base, business logic is interlaved with tracing and logging code. This can obscure the business logic and make it harder to understand and debug. I am looking for ideas how to reduce the code footprint of logging and tracing to make the business logic stick out more.
Our code currently mostly looks roughly like this:
someFunction a b cs =
withTaggedSpan tracer "TRACE_someFunction" [("arg_b", show b)] $ do
logDebug logger $ "someFunction start: " <> show (trimDownC <$> cs)
result <- do ... some business logic ...
if isError result then
logError logger $ "someFunction error: " <> show result
else
logDebug logger $ "someFunction success: " <> show (trimDownResult result)
One observation is that whe mostly trace the entire function body and log at beginning and end. This should allow combining tracing and logging into single helper and automatically extract function name and names of captured values via meta programming. I have used AST transforming compile time macros and runtime introspection in other languges before but not Haskell.
What are good ways to do this using Template Haskell, HasCallStack or other options?
(Cross posted at https://www.reddit.com/r/haskell/comments/gdfu52/extracting_context_for_tracinglogging_via_haskell/)

Let's assume for simplicity that the functions in your business logic are of the form:
_foo :: Int -> String -> ReaderT env IO ()
_bar :: Int -> ExceptT String (ReaderT env IO) Int
That is, they return values in a ReaderT transformer over IO, or perhaps also throw errors using ExceptT. (Actually that ReaderT transformer isn't required right now, but it'll come in handy later).
We could define a traced function like this:
{-# LANGUAGE FlexibleInstances #-}
import Data.Void (absurd)
import Control.Monad.IO.Class
import Control.Monad.Reader -- from "mtl"
import Control.Monad.Trans -- from "transformers"
import Control.Monad.Trans.Except
traced :: Traceable t => Name -> t -> t
traced name = _traced name []
type Name = String
type Arg = String
class Traceable t where
_traced :: Name -> [Arg] -> t -> t
instance Show r => Traceable (ReaderT env IO r) where
_traced msg args t = either absurd id <$> runExceptT (_traced msg args (lift t))
instance (Show e, Show r) => Traceable (ExceptT e (ReaderT env IO) r) where
_traced msg args t =
do
liftIO $ putStrLn $ msg ++ " invoked with args " ++ show args
let mapExits m = do
e <- m
case e of
Left err -> do
liftIO $ putStrLn $ msg ++ " failed with error " ++ show err
return $ Left err
Right r -> do
liftIO $ putStrLn $ msg ++ " exited with value " ++ show r
return $ Right r
mapExceptT (mapReaderT mapExits) t
instance (Show arg, Traceable t) => Traceable (arg -> t) where
_traced msg args f = \arg -> _traced msg (args ++ [show arg]) (f arg)
This solution is still a bit unsatisfactory because, for functions that call other functions, we must decide at the outset if we want the traced version of the called functions or not.
One thing we could try—although more invasive to the code—is to put our functions in a record, and make the environment of the ReaderT equal to that same record. Something like this:
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
import GHC.Generics
-- from "red-black-record"
import Data.RBR (FromRecord (..), IsRecordType, ToRecord (..))
data MyAPI = MyAPI
{ foo :: Int -> String -> ReaderT MyAPI IO (),
bar :: Int -> ExceptT String (ReaderT MyAPI IO) Int,
baz :: Bool -> ExceptT String (ReaderT MyAPI IO) ()
}
deriving (Generic, FromRecord, ToRecord)
An then use some generics utility library (here red-black-record) to write a function that says: "if every function in your record is Traceable, I will give you another record where all the functions are traced":
import Data.Kind
import Data.Proxy
import Data.Monoid (Endo(..))
import GHC.TypeLits
import Data.RBR
( I (..),
KeyValueConstraints,
KeysValuesAll,
Maplike,
cpure'_Record,
liftA2_Record,
)
traceAPI ::
( IsRecordType r t,
Maplike t,
KeysValuesAll (KeyValueConstraints KnownSymbol Traceable) t
) =>
r ->
r
traceAPI =
let transforms =
cpure'_Record (Proxy #Traceable) $
\fieldName -> Endo (traced fieldName)
applyTraced (Endo endo) (I v) = I (endo v)
in fromRecord . liftA2_Record applyTraced transforms . toRecord
-- small helper function to help invoke the functions in the record
call :: MonadReader env m => (env -> f) -> (f -> m r) -> m r
call getter execute = do
f <- asks getter
execute f
Alternatively, in order to avoid magic, such function could we written by hand for each particular API record.
Putting it to work:
main :: IO ()
main = do
let api =
traceAPI $
MyAPI
{ foo = \_ _ ->
do liftIO $ putStrLn "this is foo",
bar = \_ ->
do
liftIO $ putStrLn "this is bar"
return 5,
baz = \_ ->
do
call foo $ \f -> lift $ f 0 "fooarg"
call bar $ \f -> f 23
throwE "oops"
}
flip runReaderT api $ runExceptT $ baz api False
pure ()
-- baz invoked with args ["False"]
-- foo invoked with args ["0","\"fooarg\""]
-- this is foo
-- foo exited with value ()
-- bar invoked with args ["23"]
-- this is bar
-- bar exited with value 5
-- baz failed with error "oops"

Pure functions are deterministic. If you know what went into them, you can always reproduce the result. Thus, you shouldn't need a lot of logging inside the main parts of a functional code base.
Log the impure actions only, and architect your code into a pure core with a small imperative shell. Log only the impure actions that take place in the shell. I've described the technique in a blog post here.

Related

How to integrate/lift/inject custom monad stack with HSpec?

Context
I have some monadic functions for an interpreter that I'm trying to test with HSpec. They run with the following monad stack:
type AppState = StateT InterpreterState (ExceptT Events IO)
type AppReturn a = Either Events (a, PState)
runApp :: AppState a -> IO (AppReturn a)
runApp f = runExceptT (runStateT f new)
Here's an example of a simple one:
mustEvalExpr :: Expr -> S.AppState (S.Value)
mustEvalExpr e = do
val <- evalExpr e
case val of
Just val' -> return val'
Nothing -> throw $ S.CannotEval e
The problem is that HSpec has its own context (IO ()), so I have to translate between the two contexts.
Current Approach
I'm using HSpec, and I wrote a transformer function to get a runApp context from within the HSpec context.
-- imports omitted
extract :: S.AppReturn a -> a
extract st = case st of
Right (a, _) -> a
Left ev -> throw ev
run :: (S.AppReturn a -> b) -> S.AppState a -> IO b
run extractor fn = do
state <- S.runApp fn
return $ extractor state
So my Spec looks like this:
spec :: Spec
spec = do
describe "mustEvalExpr" $ do
let badExpr = D.VarExpr $ D.Id "doesntExist"
goodExpr = D.IntExpr 1
val = S.IntValue 1
it "should evaluate and return expression if its a Just" $ do
(run extract $ do
I.mustEvalExpr goodExpr
) >>= (`shouldBe` val)
it "should throw error if it gets a Nothing" $ do
(run extract $ do
I.mustEvalExpr badExpr
) `shouldThrow` anyException
Question
Is this the best I can do? I feel like run extract $ do is fine, and I think it's good to be explicit when things are complicated.
But I was wondering if there was a way I can integrate with HSpec, or if there's a best-practice for this problem that doesn't require custom code?

Memoizing and repeating IO monads

EDITED 2015-11-29: see bottom
I'm trying to write an application that has a do-last-action-again button. The command in question can ask for input, and my thought for how to accomplish this was to just rerun the resulting monad with memoized IO.
There are lots of posts on SO with similar questions, but none of the solutions seem to work here.
I lifted the memoIO code from this SO answer, and changed the implementation to run over MonadIO.
-- Memoize an IO function
memoIO :: MonadIO m => m a -> m (m a)
memoIO action = do
ref <- liftIO $ newMVar Nothing
return $ do
x <- maybe action return =<< liftIO (takeMVar ref)
liftIO . putMVar ref $ Just x
return x
I've got a small repro of my app's approach, the only real difference being my app has a big transformer stack instead of just running in IO:
-- Global variable to contain the action we want to repeat
actionToRepeat :: IORef (IO String)
actionToRepeat = unsafePerformIO . newIORef $ return ""
-- Run an action and store it as the action to repeat
repeatable :: IO String -> IO String
repeatable action = do
writeIORef actionToRepeat action
action
-- Run the last action stored by repeatable
doRepeat :: IO String
doRepeat = do
x <- readIORef actionToRepeat
x
The idea being I can store an action with memoized IO in an IORef (via repeatable) when I record what was last done, and then do it again it out with doRepeat.
I test this via:
-- IO function to memoize
getName :: IO String
getName = do
putStr "name> "
getLine
main :: IO ()
main = do
repeatable $ do
memoized <- memoIO getName
name <- memoized
putStr "hello "
putStrLn name
return name
doRepeat
return ()
with expected output:
name> isovector
hello isovector
hello isovector
but actual output:
name> isovector
hello isovector
name> wasnt memoized
hello wasnt memoized
I'm not entirely sure what the issue is, or even how to go about debugging this. Gun to my head, I'd assume lazy evaluation is biting me somewhere, but I can't figure out where.
Thanks in advance!
EDIT 2015-11-29: My intended use case for this is to implement the repeat last change operator in a vim-clone. Each action can perform an arbitrary number of arbitrary IO calls, and I would like it to be able to specify which ones should be memoized (reading a file, probably not. asking the user for input, yes).
the problem is in main you are creating a new memo each time you call the action
you need to move memoized <- memoIO getName up above the action
main :: IO ()
main = do
memoized <- memoIO getName --moved above repeatable $ do
repeatable $ do
--it was here
name <- memoized
putStr "hello "
putStrLn name
return name
doRepeat
return ()
edit: is this acceptable
import Data.IORef
import System.IO.Unsafe
{-# NOINLINE actionToRepeat #-}
actionToRepeat :: IORef (IO String)
actionToRepeat = unsafePerformIO . newIORef $ return ""
type Repeatable a = IO (IO a)
-- Run an action and store the Repeatable part of the action
repeatable :: Repeatable String -> IO String
repeatable action = do
repeatAction <- action
writeIORef actionToRepeat repeatAction
repeatAction
-- Run the last action stored by repeatable
doRepeat :: IO String
doRepeat = do
x <- readIORef actionToRepeat
x
-- everything before (return $ do) is run just once
hello :: Repeatable String
hello = do
putStr "name> "
name <- getLine
return $ do
putStr "hello "
putStrLn name
return name
main :: IO ()
main = do
repeatable hello
doRepeat
return ()
I came up with a solution. It requires wrapping the original monad in a new transformer which records the results of IO and injects them the next time the underlying monad is run.
Posting it here so my answer is complete.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
import Control.Applicative (Applicative(..))
import Data.Dynamic
import Data.Maybe (fromJust)
import Control.Monad.RWS
-- | A monad transformer adding the ability to record the results
-- of IO actions and later replay them.
newtype ReplayT m a =
ReplayT { runReplayT :: RWST () [Dynamic] [Dynamic] m a }
deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadState [Dynamic]
, MonadWriter [Dynamic]
, MonadTrans
)
-- | Removes the first element from a list State and returns it.
dequeue :: MonadState [r] m
=> m (Maybe r)
dequeue = do
get >>= \case
[] -> return Nothing
(x:xs) -> do
put xs
return $ Just x
-- | Marks an IO action to be memoized after its first invocation.
sample :: ( MonadIO m
, Typeable r)
=> IO r
-> ReplayT m r
sample action = do
a <- dequeue >>= \case
Just x -> return . fromJust $ fromDynamic x
Nothing -> liftIO action
tell [toDyn a]
return a
-- | Runs an action and records all of its sampled IO. Returns a
-- action which when invoked will use the recorded IO.
record :: Monad m
=> ReplayT m a
-> m (m a)
record action = do
(a, w) <- evalRWST (runReplayT action) () []
return $ do
evalRWST (runReplayT action) () w
return a

Data.ConfigFile not using the Bool instance of get

According to https://hackage.haskell.org/package/ConfigFile-1.0.5/docs/Data-ConfigFile.html, the package will convert a value in a config. file to a Bool. The following code:
{-# LANGUAGE FlexibleContexts #-}
import qualified Data.ConfigFile as DC
import qualified Control.Monad.Except as CME
-- | The foundation object
data JRState = JRState {
secureOnly :: Bool -- ^ restrict connections to HTTPS
}
main :: IO ()
main = (CME.runExceptT $ pipe (JRState False)) >>= estate
estate :: Show t => Either t JRState -> IO ()
estate (Right state) = return ()
estate (Left err) = do
putStrLn $ "<<" ++ show err ++ ">>"
return ()
pipe :: (CME.MonadError DC.CPError m, CME.MonadIO m) => JRState -> m JRState
pipe site = do
cp <- CME.join $ CME.liftIO $ return $ DC.readstring DC.emptyCP{DC.optionxform=id} "secureSession = True\n"
DC.get cp "DEFAULT" "secureSession" >>= return . nubb where
nubb (Left err) = error err
nubb (Right value) = site{secureOnly = value}
when run, produces
<<(ParseError "couldn't parse value True from (DEFAULT/secureSession)","genericget")>>
which has obviously come from the putStrLn in estate. But I would expect that the extraction of the value, in pipe and nubb (silly names, I know) would force a Boolean context and thus force the conversion of the True string to a Bool. I've tried 1 and Yes with the same result. What's going on?
Here is a more minimal program with similarly problematic behavior:
import qualified Data.ConfigFile as DC
import qualified Control.Monad.Except as CME
main = CME.runExceptT pipe >>= print
pipe = do
cp <- DC.readstring DC.emptyCP{DC.optionxform=id} "secureSession = True\n"
DC.get cp "DEFAULT" "secureSession" >>= nubb
nubb :: Either String Bool -> m Bool
nubb = undefined
When it's stripped down to this bare-bones form, it's obvious what has gone wrong: you are asking DC.get to return an Either String Bool when in fact you should simply be asking it to return a Bool. Simple fix for the stripped-down version is to eliminate the >>= nubb part of that line entirely; it should be easy to translate this fix back into your bigger context.

How to pass a field constructor parameter to a function?

1) I need to pass a field constructor parameter to a function. I made some tests but i was unable to do so. Is it possible? Otherwise, is it possible with lens package?
2) Is it possible in a MonadState to modify a field using modify? (I made a few attempts, but without success. For example: modify (second = "x") does not work.
import Control.Monad.State
data Test = Test {first :: Int, second :: String} deriving Show
dataTest = Test {first = 1, second = ""}
test1 = runStateT modif1 dataTest -- OK
test2 = runStateT (modif2 "!") dataTest -- OK
test3 = runStateT (modif3 second) dataTest -- WRONG
-- modif1 :: StateT Test IO ()
modif1 = do
st <- get
r <- lift getLine
put $ st {second = "x" ++ r}
-- modif2 :: String -> StateT Test IO ()
modif2 s = do
stat <- get
r <- lift getLine
put $ stat {second = "x" ++ r ++ s}
-- modif3 :: ???? -> StateT Test IO ()
modif3 fc = do
stat <- get
r <- lift getLine
put $ stat {fc = "x" ++ r}
-- When i try to load the module, this is the result:
-- ghc > Failed:
-- ProvaRecord.hs:33:16:`fc' is not a (visible) constructor field name
As you said, you're probably looking for lenses. A lens is a value that allows to read, set or modify a given field. Usually with Control.Lens, you define fields with underscores and you use makeLenses to create full-featured lenses.
There are many combinators that allow lenses to be used together within MonadState. In your case we can use %=, which in this case would be specialized to type
(MonadState s m) => Lens' s b -> (b -> b) -> m ()
which modifies a state value using a given lens and a function that operates on the inside value.
Your example could be rewritten using lenses as follows:
{-# LANGUAGE TemplateHaskell, RankNTypes #-}
import Control.Lens
import Control.Monad.State
data Test = Test { _first :: Int
, _second :: String
}
deriving Show
-- Generate `first` and `second` lenses.
$(makeLenses ''Test)
-- | An example of a universal function that modifies any lens.
-- It reads a string and appends it to the existing value.
modif :: Lens' a String -> StateT a IO ()
modif l = do
r <- lift getLine
l %= (++ r)
dataTest :: Test
dataTest = Test { _first = 1, _second = "" }
test :: IO Test
test = execStateT (modif second) dataTest

Is there a better way to implement a multi-channel Writer monad in Haskell?

Problem:
I need to compose writer monads of different types in the same Haskell monad transformer stack. Besides using tell to write debug messages I'd also like to use it to write some other data type, e.g. data packets to be transmitted in some other context.
I've checked Hackage for a channelized writer monad. What I was hoping to find was a writer-like monad that supports multiple data types, each representing a distinct "logical" channel in the runWriter result. My searches didn't turn up anything.
Solution Attempt 1:
My first approach at solving the problem was to stack WriterT twice along these lines:
type Packet = B.ByteString
newtype MStack a = MStack { unMStack :: WriterT [Packet] (WriterT [String] Identity) a }
deriving (Monad)
However, I ran into problems when declaring MStack as an instance of both MonadWriter [Packet] and MonadWriter [String]:
instance MonadWriter [String] MStack where
tell = Control.Monad.Writer.tell
listen = Control.Monad.Writer.listen
pass = Control.Monad.Writer.pass
instance MonadWriter [Packet] MStack where
tell = lift . Control.Monad.Writer.tell
listen = lift . Control.Monad.Writer.listen
pass = lift . Control.Monad.Writer.pass
Subsequent complaints from ghci:
/Users/djoyner/working/channelized-writer/Try1.hs:12:10:
Functional dependencies conflict between instance declarations:
instance MonadWriter [String] MStack
-- Defined at /Users/djoyner/working/channelized-writer/Try1.hs:12:10-36
instance MonadWriter [Packet] MStack
-- Defined at /Users/djoyner/working/channelized-writer/Try1.hs:17:10-36
Failed, modules loaded: none.
I understand why this approach is not valid as shown here but I couldn't figure out a way around the fundamental issues so I abandoned it altogether.
Solution Attempt 2:
Since it appears there can only be a single WriterT in the stack, I'm using a wrapper type over Packet and String and hiding the fact in the utility functions (runMStack, tellPacket, and tellDebug below). Here's the complete solution that does work:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad.Identity
import Control.Monad.Writer
import qualified Data.ByteString as B
type Packet = B.ByteString
data MStackWriterWrapper = MSWPacket Packet
| MSWDebug String
newtype MStack a = MStack { unMStack :: WriterT [MStackWriterWrapper] Identity a }
deriving (Monad, MonadWriter [MStackWriterWrapper])
runMStack :: MStack a -> (a, [Packet], [String])
runMStack act = (a, concatMap unwrapPacket ws, concatMap unwrapDebug ws)
where (a, ws) = runIdentity $ runWriterT $ unMStack act
unwrapPacket w = case w of
MSWPacket p -> [p]
_ -> []
unwrapDebug w = case w of
MSWDebug d -> [d]
_ -> []
tellPacket = tell . map MSWPacket
tellDebug = tell . map MSWDebug
myFunc = do
tellDebug ["Entered myFunc"]
tellPacket [B.pack [0..255]]
tellDebug ["Exited myFunc"]
main = do
let (_, ps, ds) = runMStack myFunc
putStrLn $ "Will be sending " ++ (show $ length ps) ++ " packets."
putStrLn "Debug log:"
mapM_ putStrLn ds
Yay, compiles and works!
Solution Non-Attempt 3:
It also occurred to me that this might be a time when I'd roll my own, also including error, reader, and state monad functionality that needs be present in my actual application's transformer stack type. I didn't attempt this.
Question:
Although solution 2 works, is there a better way?
Also, could a channelized writer monad with a variable number of channels be generically implemented as a package? It would seem like that would be a useful thing and I'm wondering why it doesn't already exist.
The output of the Writer monad needs to be a Monoid, but luckily tuples of monoids are monoids too! So this works:
import Control.Monad.Writer
import qualified Data.ByteString as B
import Data.Monoid
type Packet = B.ByteString
tellPacket xs = tell (xs, mempty)
tellDebug xs = tell (mempty, xs)
myFunc :: Writer ([Packet], [String]) ()
myFunc = do
tellDebug ["Entered myFunc"]
tellPacket [B.pack [0..255]]
tellDebug ["Exited myFunc"]
main = do
let (_, (ps, ds)) = runWriter myFunc
putStrLn $ "Will be sending " ++ (show $ length ps) ++ " packets."
putStrLn "Debug log:"
mapM_ putStrLn ds
For the record, it is possible to stack two WriterT's on top of each other:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad.Writer
import Control.Monad.Identity
import qualified Data.ByteString as B
type Packet = B.ByteString
newtype MStack a = MStack { unMStack :: WriterT [Packet] (WriterT [String] Identity) a }
deriving (Functor, Applicative, Monad)
tellDebug = MStack . lift . Control.Monad.Writer.tell
tellPacket = MStack . Control.Monad.Writer.tell
runMStack m =
let ((a, ps), ds) = (runIdentity . runWriterT . runWriterT . unMStack) m
in (a, ps, ds)
myFunc = do
tellDebug ["Entered myFunc"]
tellPacket [B.pack [0..255]]
tellDebug ["Exited myFunc"]
main = do
let (_, ps, ds) = runMStack myFunc
putStrLn $ "Will be sending " ++ (show $ length ps) ++ " packets."
putStrLn "Debug log:"
mapM_ putStrLn ds

Resources