{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Test.Sandwich.Formatters.LogSaver (
defaultLogSaverFormatter
, logSaverPath
, logSaverLogLevel
, LogPath(..)
) 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
}
data LogPath =
LogPathRelativeToRunRoot FilePath
| LogPathAbsolute FilePath
defaultLogSaverFormatter :: LogSaverFormatter
defaultLogSaverFormatter :: LogSaverFormatter
defaultLogSaverFormatter = LogSaverFormatter :: LogPath -> LogLevel -> LogEntryFormatter -> LogSaverFormatter
LogSaverFormatter {
logSaverPath :: LogPath
logSaverPath = FilePath -> LogPath
LogPathRelativeToRunRoot FilePath
"logs.txt"
, logSaverLogLevel :: LogLevel
logSaverLogLevel = LogLevel
LevelWarn
, logSaverFormatter :: LogEntryFormatter
logSaverFormatter = LogEntryFormatter
defaultLogEntryFormatter
}
instance Formatter LogSaverFormatter where
formatterName :: LogSaverFormatter -> FilePath
formatterName LogSaverFormatter
_ = FilePath
"log-saver-formatter"
runFormatter :: LogSaverFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runFormatter = LogSaverFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogSaverFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runApp
finalizeFormatter :: LogSaverFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
finalizeFormatter LogSaverFormatter
_ [RunNode BaseContext]
_ BaseContext
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runApp :: (MonadIO m, MonadLogger m) => LogSaverFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()
runApp :: 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 FilePath
maybePath = case LogPath
logSaverPath of
LogPathAbsolute FilePath
p -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
p
LogPathRelativeToRunRoot FilePath
p -> case BaseContext -> Maybe FilePath
baseContextRunRoot BaseContext
bc of
Maybe FilePath
Nothing -> Maybe FilePath
forall a. Maybe a
Nothing
Just FilePath
rr -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
rr FilePath -> FilePath -> FilePath
</> FilePath
p)
Maybe FilePath -> (FilePath -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe FilePath
maybePath ((FilePath -> m ()) -> m ()) -> (FilePath -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
path ->
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
path IOMode
AppendMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
ReaderT (LogSaverFormatter, Handle) IO ()
-> (LogSaverFormatter, Handle) -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ((RunNode BaseContext -> ReaderT (LogSaverFormatter, Handle) IO ())
-> [RunNode BaseContext]
-> ReaderT (LogSaverFormatter, Handle) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunNode BaseContext -> ReaderT (LogSaverFormatter, Handle) IO ()
forall context.
RunNode context -> ReaderT (LogSaverFormatter, Handle) IO ()
run [RunNode BaseContext]
rts) (LogSaverFormatter
lsf, Handle
h)
run :: RunNode context -> ReaderT (LogSaverFormatter, Handle) IO ()
run :: 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 context s l t.
RunNodeWithStatus context s l t -> ExampleT context IO ()
runNodeCommon :: forall context s l t.
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
FilePath
Maybe FilePath
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 FilePath
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 -> FilePath
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe FilePath
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: FilePath
..} = RunNodeCommonWithStatus
(Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
Result
_ <- IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result)
-> IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result
forall a b. (a -> b) -> a -> b
$ RunNode context -> IO Result
forall context. RunNode context -> IO Result
waitForTree RunNode context
node
Var (Seq LogEntry) -> ReaderT (LogSaverFormatter, Handle) IO ()
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
FilePath
Maybe FilePath
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe FilePath
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: FilePath
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 FilePath
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 -> FilePath
..} = RunNode context
-> RunNodeCommonWithStatus
(Var Status) (Var (Seq LogEntry)) (Var Bool)
forall context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node
Result
_ <- IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result)
-> IO Result -> ReaderT (LogSaverFormatter, Handle) IO Result
forall a b. (a -> b) -> a -> b
$ RunNode context -> IO Result
forall context. RunNode context -> IO Result
waitForTree RunNode context
node
Var (Seq LogEntry) -> ReaderT (LogSaverFormatter, Handle) IO ()
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 :: 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) <- m (LogSaverFormatter, Handle)
forall r (m :: * -> *). MonadReader r m => m r
ask
t LogEntry
logEntries <- IO (t LogEntry) -> m (t LogEntry)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (t LogEntry) -> m (t LogEntry))
-> IO (t LogEntry) -> m (t LogEntry)
forall a b. (a -> b) -> a -> b
$ TVar (t LogEntry) -> IO (t LogEntry)
forall a. TVar a -> IO a
readTVarIO TVar (t LogEntry)
runTreeLogs
t LogEntry -> (LogEntry -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t LogEntry
logEntries ((LogEntry -> m ()) -> m ()) -> (LogEntry -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(LogEntry {LogSource
UTCTime
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
..}) ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
logEntryLevel LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
logSaverLogLevel) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS8.hPutStr Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
LogEntryFormatter
logSaverFormatter UTCTime
logEntryTime Loc
logEntryLoc LogSource
logEntrySource LogLevel
logEntryLevel LogStr
logEntryStr