module Test.Sandwich.Formatters.LogSaver (
defaultLogSaverFormatter
, logSaverPath
, logSaverLogLevel
, logSaverFormatter
, LogPath(..)
, LogEntryFormatter
) where
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as BS8
import System.FilePath
import System.IO
import Test.Sandwich.Interpreters.RunTree.Logging
import Test.Sandwich.Interpreters.RunTree.Util
import Test.Sandwich.Types.ArgParsing
import Test.Sandwich.Types.RunTree
import Test.Sandwich.Util
data LogSaverFormatter = LogSaverFormatter {
LogSaverFormatter -> LogPath
logSaverPath :: LogPath
, LogSaverFormatter -> LogLevel
logSaverLogLevel :: LogLevel
, LogSaverFormatter -> LogEntryFormatter
logSaverFormatter :: LogEntryFormatter
}
instance Show LogSaverFormatter where
show :: LogSaverFormatter -> String
show LogSaverFormatter
_ = String
"<LogSaverFormatter>"
data LogPath =
LogPathRelativeToRunRoot FilePath
| LogPathAbsolute FilePath
defaultLogSaverFormatter :: LogSaverFormatter
defaultLogSaverFormatter :: LogSaverFormatter
defaultLogSaverFormatter = LogSaverFormatter {
logSaverPath :: LogPath
logSaverPath = String -> LogPath
LogPathRelativeToRunRoot String
"logs.txt"
, logSaverLogLevel :: LogLevel
logSaverLogLevel = LogLevel
LevelWarn
, logSaverFormatter :: LogEntryFormatter
logSaverFormatter = LogEntryFormatter
defaultLogEntryFormatter
}
instance Formatter LogSaverFormatter where
formatterName :: LogSaverFormatter -> String
formatterName LogSaverFormatter
_ = String
"log-saver-formatter"
runFormatter :: forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m, MonadCatch m) =>
LogSaverFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runFormatter = forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogSaverFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runApp
finalizeFormatter :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
LogSaverFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
finalizeFormatter LogSaverFormatter
_ [RunNode BaseContext]
_ BaseContext
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
runApp :: (MonadIO m, MonadLogger m) => LogSaverFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()
runApp :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogSaverFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runApp lsf :: LogSaverFormatter
lsf@(LogSaverFormatter {LogLevel
LogPath
LogEntryFormatter
logSaverFormatter :: LogEntryFormatter
logSaverLogLevel :: LogLevel
logSaverPath :: LogPath
logSaverFormatter :: LogSaverFormatter -> LogEntryFormatter
logSaverLogLevel :: LogSaverFormatter -> LogLevel
logSaverPath :: LogSaverFormatter -> LogPath
..}) [RunNode BaseContext]
rts Maybe (CommandLineOptions ())
_maybeCommandLineOptions BaseContext
bc = do
let maybePath :: Maybe String
maybePath = case LogPath
logSaverPath of
LogPathAbsolute String
p -> forall a. a -> Maybe a
Just String
p
LogPathRelativeToRunRoot String
p -> case BaseContext -> Maybe String
baseContextRunRoot BaseContext
bc of
Maybe String
Nothing -> forall a. Maybe a
Nothing
Just String
rr -> forall a. a -> Maybe a
Just (String
rr String -> ShowS
</> String
p)
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
maybePath forall a b. (a -> b) -> a -> b
$ \String
path ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
AppendMode forall a b. (a -> b) -> a -> b
$ \Handle
h ->
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall context.
RunNode context -> ReaderT (LogSaverFormatter, Handle) IO ()
run [RunNode BaseContext]
rts) (LogSaverFormatter
lsf, Handle
h)
run :: RunNode context -> ReaderT (LogSaverFormatter, Handle) IO ()
run :: forall context.
RunNode context -> ReaderT (LogSaverFormatter, Handle) IO ()
run node :: RunNode context
node@(RunNodeIt {ExampleT context IO ()
RunNodeCommonWithStatus
(Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeExample :: forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeExample :: ExampleT context IO ()
runNodeCommon :: RunNodeCommonWithStatus
(Var Status) (Var (Seq LogEntry)) (Var Bool)
..}) = do
let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
..} = RunNodeCommonWithStatus
(Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
Result
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall context. RunNode context -> IO Result
waitForTree RunNode context
node
forall (m :: * -> *) (t :: * -> *).
(MonadIO m, MonadReader (LogSaverFormatter, Handle) m,
Foldable t) =>
TVar (t LogEntry) -> m ()
printLogs Var (Seq LogEntry)
runTreeLogs
run RunNode context
node = do
let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
..} = forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node
Result
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall context. RunNode context -> IO Result
waitForTree RunNode context
node
forall (m :: * -> *) (t :: * -> *).
(MonadIO m, MonadReader (LogSaverFormatter, Handle) m,
Foldable t) =>
TVar (t LogEntry) -> m ()
printLogs Var (Seq LogEntry)
runTreeLogs
printLogs :: (MonadIO m, MonadReader (LogSaverFormatter, Handle) m, Foldable t) => TVar (t LogEntry) -> m ()
printLogs :: forall (m :: * -> *) (t :: * -> *).
(MonadIO m, MonadReader (LogSaverFormatter, Handle) m,
Foldable t) =>
TVar (t LogEntry) -> m ()
printLogs TVar (t LogEntry)
runTreeLogs = do
(LogSaverFormatter {LogLevel
LogPath
LogEntryFormatter
logSaverFormatter :: LogEntryFormatter
logSaverLogLevel :: LogLevel
logSaverPath :: LogPath
logSaverFormatter :: LogSaverFormatter -> LogEntryFormatter
logSaverLogLevel :: LogSaverFormatter -> LogLevel
logSaverPath :: LogSaverFormatter -> LogPath
..}, Handle
h) <- forall r (m :: * -> *). MonadReader r m => m r
ask
t LogEntry
logEntries <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar (t LogEntry)
runTreeLogs
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t LogEntry
logEntries forall a b. (a -> b) -> a -> b
$ \(LogEntry {UTCTime
LogSource
LogStr
LogLevel
Loc
logEntryStr :: LogEntry -> LogStr
logEntryLevel :: LogEntry -> LogLevel
logEntrySource :: LogEntry -> LogSource
logEntryLoc :: LogEntry -> Loc
logEntryTime :: LogEntry -> UTCTime
logEntryStr :: LogStr
logEntryLevel :: LogLevel
logEntrySource :: LogSource
logEntryLoc :: Loc
logEntryTime :: UTCTime
..}) ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
logEntryLevel forall a. Ord a => a -> a -> Bool
>= LogLevel
logSaverLogLevel) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS8.hPutStr Handle
h forall a b. (a -> b) -> a -> b
$
LogEntryFormatter
logSaverFormatter UTCTime
logEntryTime Loc
logEntryLoc LogSource
logEntrySource LogLevel
logEntryLevel LogStr
logEntryStr