module Test.Sandwich.Interpreters.RunTree.Logging (
  logToMemory
  , logToMemoryAndFile
  , LogFn
  , LogEntryFormatter
  ) where

import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Logger
import qualified Data.ByteString.Char8 as BS8
import Data.Sequence
import Data.Time.Clock
import System.IO
import Test.Sandwich.Types.RunTree

logToMemory :: Maybe LogLevel -> TVar (Seq LogEntry) -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logToMemory :: Maybe LogLevel
-> TVar (Seq LogEntry)
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> IO ()
logToMemory Maybe LogLevel
Nothing TVar (Seq LogEntry)
_ Loc
_ LogSource
_ LogLevel
_ LogStr
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
logToMemory (Just LogLevel
minLevel) TVar (Seq LogEntry)
logs Loc
loc LogSource
logSrc LogLevel
logLevel LogStr
logStr =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
logLevel LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
minLevel) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
ts <- IO UTCTime
getCurrentTime
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Seq LogEntry) -> (Seq LogEntry -> Seq LogEntry) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Seq LogEntry)
logs (Seq LogEntry -> LogEntry -> Seq LogEntry
forall a. Seq a -> a -> Seq a
|> UTCTime -> Loc -> LogSource -> LogLevel -> LogStr -> LogEntry
LogEntry UTCTime
ts Loc
loc LogSource
logSrc LogLevel
logLevel LogStr
logStr)

logToMemoryAndFile :: Maybe LogLevel -> Maybe LogLevel -> LogEntryFormatter -> TVar (Seq LogEntry) -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logToMemoryAndFile :: Maybe LogLevel
-> Maybe LogLevel
-> LogEntryFormatter
-> TVar (Seq LogEntry)
-> Handle
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> IO ()
logToMemoryAndFile Maybe LogLevel
maybeMemLogLevel Maybe LogLevel
maybeSavedLogLevel LogEntryFormatter
formatter TVar (Seq LogEntry)
logs Handle
h Loc
loc LogSource
logSrc LogLevel
logLevel LogStr
logStr = do
  Maybe UTCTime
maybeTs <- case Maybe LogLevel
maybeMemLogLevel of
    Just LogLevel
x | LogLevel
x LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= LogLevel
logLevel -> do
      UTCTime
ts <- IO UTCTime
getCurrentTime
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Seq LogEntry) -> (Seq LogEntry -> Seq LogEntry) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Seq LogEntry)
logs (Seq LogEntry -> LogEntry -> Seq LogEntry
forall a. Seq a -> a -> Seq a
|> UTCTime -> Loc -> LogSource -> LogLevel -> LogStr -> LogEntry
LogEntry UTCTime
ts Loc
loc LogSource
logSrc LogLevel
logLevel LogStr
logStr)
      Maybe UTCTime -> IO (Maybe UTCTime)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UTCTime -> IO (Maybe UTCTime))
-> Maybe UTCTime -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
ts
    Maybe LogLevel
_ -> Maybe UTCTime -> IO (Maybe UTCTime)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing

  case Maybe LogLevel
maybeSavedLogLevel of
    Just LogLevel
x | LogLevel
x LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= LogLevel
logLevel -> do
      UTCTime
ts <- IO UTCTime
-> (UTCTime -> IO UTCTime) -> Maybe UTCTime -> IO UTCTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO UTCTime
getCurrentTime UTCTime -> IO UTCTime
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
maybeTs
      Handle -> ByteString -> IO ()
BS8.hPutStr Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ LogEntryFormatter
formatter UTCTime
ts Loc
loc LogSource
logSrc LogLevel
logLevel LogStr
logStr
    Maybe LogLevel
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()