    {-# 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
      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
      pure (formatLog threadName lvl 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 ()