{-# LANGUAGE RecordWildCards #-}
module Test.Mockery.Logging (
  captureLogMessages
, captureLogMessages_
, LogLevel(..)
) where

import           Control.Exception
import           Data.IORef.Compat
import           Prelude ()
import           Prelude.Compat
import           System.Logging.Facade.Types
import           System.Logging.Facade.Sink

-- | Capture all log messages produced by an IO action.
-- Logs are kept in memory.
captureLogMessages :: IO a -> IO ([(LogLevel, String)], a)
captureLogMessages :: forall a. IO a -> IO ([(LogLevel, String)], a)
captureLogMessages IO a
action = IO LogSink
-> (LogSink -> IO ())
-> (LogSink -> IO ([(LogLevel, String)], a))
-> IO ([(LogLevel, String)], a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO LogSink
getLogSink LogSink -> IO ()
setLogSink LogSink -> IO ([(LogLevel, String)], a)
forall {p}. p -> IO ([(LogLevel, String)], a)
act
  where
    logToRef :: IORef [a] -> a -> IO ()
logToRef IORef [a]
ref a
record = IORef [a] -> ([a] -> ([a], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [a]
ref (([a] -> ([a], ())) -> IO ()) -> ([a] -> ([a], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[a]
logs -> (a
record a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
logs, ())
    unwrap :: LogRecord -> (LogLevel, String)
unwrap LogRecord{String
Maybe Location
LogLevel
logRecordLevel :: LogLevel
logRecordLocation :: Maybe Location
logRecordMessage :: String
logRecordMessage :: LogRecord -> String
logRecordLocation :: LogRecord -> Maybe Location
logRecordLevel :: LogRecord -> LogLevel
..} = (LogLevel
logRecordLevel, String
logRecordMessage)
    act :: p -> IO ([(LogLevel, String)], a)
act p
_  = do
      ref <- [LogRecord] -> IO (IORef [LogRecord])
forall a. a -> IO (IORef a)
newIORef []
      setLogSink $ logToRef ref
      val <- action
      logs <- readIORef ref
      return (unwrap <$> reverse logs, val)

-- | Like 'captureLogsMessages', but ignores the result.
captureLogMessages_ :: IO a -> IO [(LogLevel, String)]
captureLogMessages_ :: forall a. IO a -> IO [(LogLevel, String)]
captureLogMessages_ IO a
action = ([(LogLevel, String)], a) -> [(LogLevel, String)]
forall a b. (a, b) -> a
fst (([(LogLevel, String)], a) -> [(LogLevel, String)])
-> IO ([(LogLevel, String)], a) -> IO [(LogLevel, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> IO ([(LogLevel, String)], a)
forall a. IO a -> IO ([(LogLevel, String)], a)
captureLogMessages IO a
action