{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ViewPatterns #-}
module Test.DocTest.Internal.Logging where
import Control.Applicative (Alternative((<|>)))
import Control.Concurrent (ThreadId, myThreadId)
import Control.DeepSeq (NFData)
import Data.Char (toLower, toUpper)
import Data.List (intercalate)
import GHC.Generics (Generic)
import System.IO (hPutStrLn, stderr)
import Text.Printf (printf)
type DebugLogger = String -> IO ()
noLogger :: DebugLogger
noLogger :: DebugLogger
noLogger = IO () -> DebugLogger
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
data LogLevel
= Debug
| Verbose
| Info
| Warning
| Error
deriving (Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogLevel -> ShowS
showsPrec :: Int -> LogLevel -> ShowS
$cshow :: LogLevel -> String
show :: LogLevel -> String
$cshowList :: [LogLevel] -> ShowS
showList :: [LogLevel] -> ShowS
Show, LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
/= :: LogLevel -> LogLevel -> Bool
Eq, Int -> LogLevel
LogLevel -> Int
LogLevel -> [LogLevel]
LogLevel -> LogLevel
LogLevel -> LogLevel -> [LogLevel]
LogLevel -> LogLevel -> LogLevel -> [LogLevel]
(LogLevel -> LogLevel)
-> (LogLevel -> LogLevel)
-> (Int -> LogLevel)
-> (LogLevel -> Int)
-> (LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> LogLevel -> [LogLevel])
-> Enum LogLevel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: LogLevel -> LogLevel
succ :: LogLevel -> LogLevel
$cpred :: LogLevel -> LogLevel
pred :: LogLevel -> LogLevel
$ctoEnum :: Int -> LogLevel
toEnum :: Int -> LogLevel
$cfromEnum :: LogLevel -> Int
fromEnum :: LogLevel -> Int
$cenumFrom :: LogLevel -> [LogLevel]
enumFrom :: LogLevel -> [LogLevel]
$cenumFromThen :: LogLevel -> LogLevel -> [LogLevel]
enumFromThen :: LogLevel -> LogLevel -> [LogLevel]
$cenumFromTo :: LogLevel -> LogLevel -> [LogLevel]
enumFromTo :: LogLevel -> LogLevel -> [LogLevel]
$cenumFromThenTo :: LogLevel -> LogLevel -> LogLevel -> [LogLevel]
enumFromThenTo :: LogLevel -> LogLevel -> LogLevel -> [LogLevel]
Enum, (forall x. LogLevel -> Rep LogLevel x)
-> (forall x. Rep LogLevel x -> LogLevel) -> Generic LogLevel
forall x. Rep LogLevel x -> LogLevel
forall x. LogLevel -> Rep LogLevel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LogLevel -> Rep LogLevel x
from :: forall x. LogLevel -> Rep LogLevel x
$cto :: forall x. Rep LogLevel x -> LogLevel
to :: forall x. Rep LogLevel x -> LogLevel
Generic, LogLevel -> ()
(LogLevel -> ()) -> NFData LogLevel
forall a. (a -> ()) -> NFData a
$crnf :: LogLevel -> ()
rnf :: LogLevel -> ()
NFData, Eq LogLevel
Eq LogLevel =>
(LogLevel -> LogLevel -> Ordering)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> LogLevel)
-> (LogLevel -> LogLevel -> LogLevel)
-> Ord LogLevel
LogLevel -> LogLevel -> Bool
LogLevel -> LogLevel -> Ordering
LogLevel -> LogLevel -> LogLevel
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LogLevel -> LogLevel -> Ordering
compare :: LogLevel -> LogLevel -> Ordering
$c< :: LogLevel -> LogLevel -> Bool
< :: LogLevel -> LogLevel -> Bool
$c<= :: LogLevel -> LogLevel -> Bool
<= :: LogLevel -> LogLevel -> Bool
$c> :: LogLevel -> LogLevel -> Bool
> :: LogLevel -> LogLevel -> Bool
$c>= :: LogLevel -> LogLevel -> Bool
>= :: LogLevel -> LogLevel -> Bool
$cmax :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
min :: LogLevel -> LogLevel -> LogLevel
Ord, LogLevel
LogLevel -> LogLevel -> Bounded LogLevel
forall a. a -> a -> Bounded a
$cminBound :: LogLevel
minBound :: LogLevel
$cmaxBound :: LogLevel
maxBound :: LogLevel
Bounded)
parseLogLevel :: String -> Maybe LogLevel
parseLogLevel :: String -> Maybe LogLevel
parseLogLevel ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower -> String
level) =
(Maybe LogLevel -> Maybe LogLevel -> Maybe LogLevel)
-> Maybe LogLevel -> [Maybe LogLevel] -> Maybe LogLevel
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe LogLevel -> Maybe LogLevel -> Maybe LogLevel
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) Maybe LogLevel
forall a. Maybe a
Nothing ((LogLevel -> Maybe LogLevel) -> [LogLevel] -> [Maybe LogLevel]
forall a b. (a -> b) -> [a] -> [b]
map LogLevel -> Maybe LogLevel
go [LogLevel
forall a. Bounded a => a
minBound..])
where
go :: LogLevel -> Maybe LogLevel
go :: LogLevel -> Maybe LogLevel
go LogLevel
l
| (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (LogLevel -> String
forall a. Show a => a -> String
show LogLevel
l) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
level = LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
l
| Bool
otherwise = Maybe LogLevel
forall a. Maybe a
Nothing
showJustifiedLogLevel :: LogLevel -> String
showJustifiedLogLevel :: LogLevel -> String
showJustifiedLogLevel = Int -> Char -> ShowS
forall a. Int -> a -> [a] -> [a]
justifyLeft Int
maxSizeLogLevel Char
' ' ShowS -> (LogLevel -> String) -> LogLevel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> String
forall a. Show a => a -> String
show
where
maxSizeLogLevel :: Int
maxSizeLogLevel :: Int
maxSizeLogLevel = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((LogLevel -> Int) -> [LogLevel] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (LogLevel -> String) -> LogLevel -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> String
forall a. Show a => a -> String
show) [(LogLevel
forall a. Bounded a => a
minBound :: LogLevel)..])
justifyLeft :: Int -> a -> [a] -> [a]
justifyLeft :: forall a. Int -> a -> [a] -> [a]
justifyLeft Int
n a
c [a]
s = [a]
s [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s) a
c
formatLog :: ThreadId -> LogLevel -> String -> String
formatLog :: ThreadId -> LogLevel -> ShowS
formatLog ThreadId
threadId LogLevel
lvl String
msg = do
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
forall {t} {t}. (PrintfArg t, PrintfType t) => t -> t
go (String -> [String]
lines String
msg))
where
go :: t -> t
go t
line =
String -> String -> String -> t -> t
forall r. PrintfType r => String -> r
printf
String
"[%s] [%s] %s"
((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (LogLevel -> String
showJustifiedLogLevel LogLevel
lvl))
(ThreadId -> String
forall a. Show a => a -> String
show ThreadId
threadId)
t
line
formatLogHere :: LogLevel -> String -> IO String
formatLogHere :: LogLevel -> String -> IO String
formatLogHere LogLevel
lvl String
msg = do
ThreadId
threadId <- IO ThreadId
myThreadId
String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreadId -> LogLevel -> ShowS
formatLog ThreadId
threadId LogLevel
lvl String
msg)
shouldLog :: (?verbosity :: LogLevel) => LogLevel -> Bool
shouldLog :: (?verbosity::LogLevel) => LogLevel -> Bool
shouldLog LogLevel
lvl = ?verbosity::LogLevel
LogLevel
?verbosity LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= LogLevel
lvl
log :: (?verbosity :: LogLevel) => LogLevel -> String -> IO ()
log :: (?verbosity::LogLevel) => LogLevel -> DebugLogger
log LogLevel
lvl String
msg
| (?verbosity::LogLevel) => LogLevel -> Bool
LogLevel -> Bool
shouldLog LogLevel
lvl = Handle -> DebugLogger
hPutStrLn Handle
stderr DebugLogger -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LogLevel -> String -> IO String
formatLogHere LogLevel
lvl String
msg
| Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()