{-# 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)

-- | 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 -> 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)

-- | Case insensitive
--
-- >>> parseLogLevel "Info"
-- Just Info
-- >>> parseLogLevel "info"
-- Just Info
-- >>> parseLogLevel "errox"
-- Nothing
--
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

-- | 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 -> 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)..])

-- | 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

-- | /Prettily/ format a log message
--
-- > threadId <- myThreadId
-- > formatLog Debug threadId "some debug message"
-- "[DEBUG  ] [ThreadId 1277462] some debug message"
--
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

-- | 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 -> 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)

-- | 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 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 ()