{-# LANGUAGE CPP #-}
{-# 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 Data.Maybe (fromMaybe)
import GHC.Generics (Generic)
import System.IO (hPutStrLn, stderr)
import Text.Printf (printf)

#if MIN_VERSION_base(4,18,0)
import GHC.Conc.Sync (threadLabel)
#endif

#if !MIN_VERSION_base(4,18,0)
threadLabel :: ThreadId -> IO (Maybe String)
threadLabel _ = pure Nothing
#endif

-- | Convenience type alias - not used in this module, but sprinkled across the
-- project.
type DebugLogger = String -> IO ()

-- | Discards any log message
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
  -- ^ Intended for debug runs
  | Verbose
  -- ^ Intended for debug runs, but without flooding the user with internal messages
  | Info
  -- ^ Default log level - print messages user is likely wanting to see
  | Warning
  -- ^ Only print warnings
  | Error
  -- ^ Only print errors
  deriving (Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> [Char]
(Int -> LogLevel -> ShowS)
-> (LogLevel -> [Char]) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogLevel -> ShowS
showsPrec :: Int -> LogLevel -> ShowS
$cshow :: LogLevel -> [Char]
show :: LogLevel -> [Char]
$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)

-- | Case insensitive
--
-- >>> parseLogLevel "Info"
-- Just Info
-- >>> parseLogLevel "info"
-- Just Info
-- >>> parseLogLevel "errox"
-- Nothing
--
parseLogLevel :: String -> Maybe LogLevel
parseLogLevel :: [Char] -> Maybe LogLevel
parseLogLevel ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower -> [Char]
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 -> [Char]
forall a. Show a => a -> [Char]
show LogLevel
l) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
level = LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
l
    | Bool
otherwise = Maybe LogLevel
forall a. Maybe a
Nothing

-- | Pretty print a 'LogLevel' in a justified manner, i.e., all outputs take the
-- same amount of characters to display.
--
-- >>> showJustifiedLogLevel Debug
-- "Debug  "
-- >>> showJustifiedLogLevel Verbose
-- "Verbose"
-- >>> showJustifiedLogLevel Info
-- "Info   "
-- >>> showJustifiedLogLevel Warning
-- "Warning"
-- >>> showJustifiedLogLevel Error
-- "Error  "
--
showJustifiedLogLevel :: LogLevel -> String
showJustifiedLogLevel :: LogLevel -> [Char]
showJustifiedLogLevel = Int -> Char -> ShowS
forall a. Int -> a -> [a] -> [a]
justifyLeft Int
maxSizeLogLevel Char
' ' ShowS -> (LogLevel -> [Char]) -> LogLevel -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> [Char]
forall a. Show a => a -> [Char]
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 ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> (LogLevel -> [Char]) -> LogLevel -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> [Char]
forall a. Show a => a -> [Char]
show) [(LogLevel
forall a. Bounded a => a
minBound :: LogLevel)..])

-- | Justify a list with a custom fill symbol
--
-- >>> justifyLeft 10 'x' "foo"
-- "fooxxxxxxx"
-- >>> justifyLeft 3 'x' "foo"
-- "foo"
-- >>> justifyLeft 2 'x' "foo"
-- "foo"
--
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

-- | Pretty name for a 'ThreadId'. Uses 'threadLabel' if available, otherwise
-- falls back to 'show'.
getThreadName :: ThreadId -> IO String
getThreadName :: ThreadId -> IO [Char]
getThreadName ThreadId
threadId = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe (ThreadId -> [Char]
forall a. Show a => a -> [Char]
show ThreadId
threadId) (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThreadId -> IO (Maybe [Char])
threadLabel ThreadId
threadId

-- | /Prettily/ format a log message
--
-- > threadId <- myThreadId
-- > formatLog Debug (show threadId) "some debug message"
-- "[DEBUG  ] [ThreadId 1277462] some debug message"
--
formatLog :: String -> LogLevel -> String -> String
formatLog :: [Char] -> LogLevel -> ShowS
formatLog [Char]
nm LogLevel
lvl [Char]
msg =
  [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" (ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
go ([Char] -> [[Char]]
lines [Char]
msg))
 where
  go :: ShowS
go = [Char] -> [Char] -> [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"[%s] [%s] %s" ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (LogLevel -> [Char]
showJustifiedLogLevel LogLevel
lvl)) [Char]
nm

-- | Like 'formatLog', but instantiates the /thread/ argument with the current 'ThreadId'
--
-- > formatLogHere Debug "some debug message"
-- "[DEBUG  ] [ThreadId 1440849] some debug message"
--
formatLogHere :: LogLevel -> String -> IO String
formatLogHere :: LogLevel -> [Char] -> IO [Char]
formatLogHere LogLevel
lvl [Char]
msg = do
  [Char]
threadName <- ThreadId -> IO [Char]
getThreadName (ThreadId -> IO [Char]) -> IO ThreadId -> IO [Char]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ThreadId
myThreadId
  [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> LogLevel -> ShowS
formatLog [Char]
threadName LogLevel
lvl [Char]
msg)

-- | Should a message be printed? For a given verbosity level and message log level.
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

-- | Basic logging function. Uses 'formatLogHere'. Is not thread-safe.
log :: (?verbosity :: LogLevel) => LogLevel -> String -> IO ()
log :: (?verbosity::LogLevel) => LogLevel -> DebugLogger
log LogLevel
lvl [Char]
msg
  | (?verbosity::LogLevel) => LogLevel -> Bool
LogLevel -> Bool
shouldLog LogLevel
lvl = Handle -> DebugLogger
hPutStrLn Handle
stderr DebugLogger -> IO [Char] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LogLevel -> [Char] -> IO [Char]
formatLogHere LogLevel
lvl [Char]
msg
  | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()