-- |
-- Module: Staversion.Internal.Log
-- Description: types and functions about logging
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- 
module Staversion.Internal.Log
       ( LogLevel(..),
         LogEntry(..),
         Logger(loggerThreshold),
         defaultLogger,
         putLog,
         putLogEntry,
         logDebug,
         logInfo,
         logWarn,
         logError,
         -- * For tests
         _mockLogger
       ) where

import Control.Monad (when)
import Data.IORef (IORef, newIORef, modifyIORef)
import System.IO (Handle, stderr, hPutStrLn)

data LogLevel = LogDebug
              | LogInfo
              | LogWarn
              | LogError
              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,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,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,LogLevel
LogLevel -> LogLevel -> Bounded LogLevel
forall a. a -> a -> Bounded a
$cminBound :: LogLevel
minBound :: LogLevel
$cmaxBound :: LogLevel
maxBound :: LogLevel
Bounded)

data LogEntry = LogEntry { LogEntry -> LogLevel
logLevel :: LogLevel,
                           LogEntry -> String
logMessage :: String
                         } deriving (Int -> LogEntry -> ShowS
[LogEntry] -> ShowS
LogEntry -> String
(Int -> LogEntry -> ShowS)
-> (LogEntry -> String) -> ([LogEntry] -> ShowS) -> Show LogEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogEntry -> ShowS
showsPrec :: Int -> LogEntry -> ShowS
$cshow :: LogEntry -> String
show :: LogEntry -> String
$cshowList :: [LogEntry] -> ShowS
showList :: [LogEntry] -> ShowS
Show,LogEntry -> LogEntry -> Bool
(LogEntry -> LogEntry -> Bool)
-> (LogEntry -> LogEntry -> Bool) -> Eq LogEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogEntry -> LogEntry -> Bool
== :: LogEntry -> LogEntry -> Bool
$c/= :: LogEntry -> LogEntry -> Bool
/= :: LogEntry -> LogEntry -> Bool
Eq,Eq LogEntry
Eq LogEntry =>
(LogEntry -> LogEntry -> Ordering)
-> (LogEntry -> LogEntry -> Bool)
-> (LogEntry -> LogEntry -> Bool)
-> (LogEntry -> LogEntry -> Bool)
-> (LogEntry -> LogEntry -> Bool)
-> (LogEntry -> LogEntry -> LogEntry)
-> (LogEntry -> LogEntry -> LogEntry)
-> Ord LogEntry
LogEntry -> LogEntry -> Bool
LogEntry -> LogEntry -> Ordering
LogEntry -> LogEntry -> LogEntry
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 :: LogEntry -> LogEntry -> Ordering
compare :: LogEntry -> LogEntry -> Ordering
$c< :: LogEntry -> LogEntry -> Bool
< :: LogEntry -> LogEntry -> Bool
$c<= :: LogEntry -> LogEntry -> Bool
<= :: LogEntry -> LogEntry -> Bool
$c> :: LogEntry -> LogEntry -> Bool
> :: LogEntry -> LogEntry -> Bool
$c>= :: LogEntry -> LogEntry -> Bool
>= :: LogEntry -> LogEntry -> Bool
$cmax :: LogEntry -> LogEntry -> LogEntry
max :: LogEntry -> LogEntry -> LogEntry
$cmin :: LogEntry -> LogEntry -> LogEntry
min :: LogEntry -> LogEntry -> LogEntry
Ord)

data Logger = Logger { Logger -> Maybe LogLevel
loggerThreshold :: Maybe LogLevel,
                       -- ^ If 'Nothing', logging is disabled.
                       Logger -> LogLevel -> String -> IO ()
loggerPutLogRaw :: LogLevel -> String -> IO ()
                     }

instance Show Logger where
  show :: Logger -> String
show Logger
l = String
"Logger { loggerThreshold = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe LogLevel -> String
forall a. Show a => a -> String
show (Logger -> Maybe LogLevel
loggerThreshold Logger
l) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"

defaultLogger :: Logger
defaultLogger :: Logger
defaultLogger = Logger { loggerThreshold :: Maybe LogLevel
loggerThreshold = LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
LogInfo,
                         loggerPutLogRaw :: LogLevel -> String -> IO ()
loggerPutLogRaw = \LogLevel
_ String
msg -> Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
                       }

toLabel :: LogLevel -> String
toLabel :: LogLevel -> String
toLabel LogLevel
l = case LogLevel
l of
  LogLevel
LogDebug -> String
"[debug]"
  LogLevel
LogInfo ->  String
"[info]"
  LogLevel
LogWarn ->  String
"[warn]"
  LogLevel
LogError -> String
"[error]"

putLog :: Logger -> LogLevel -> String -> IO ()
putLog :: Logger -> LogLevel -> String -> IO ()
putLog Logger
logger LogLevel
level String
raw_msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((LogLevel -> Bool) -> Maybe LogLevel -> Maybe Bool
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>=) Maybe LogLevel
mthreshold Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> LogLevel -> String -> IO ()
loggerPutLogRaw Logger
logger LogLevel
level String
msg where
  mthreshold :: Maybe LogLevel
mthreshold = Logger -> Maybe LogLevel
loggerThreshold Logger
logger
  msg :: String
msg = LogLevel -> String
toLabel LogLevel
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
raw_msg

putLogEntry :: Logger -> LogEntry -> IO ()
putLogEntry :: Logger -> LogEntry -> IO ()
putLogEntry Logger
logger LogEntry
entry = Logger -> LogLevel -> String -> IO ()
putLog Logger
logger (LogEntry -> LogLevel
logLevel LogEntry
entry) (LogEntry -> String
logMessage LogEntry
entry)

logDebug :: Logger -> String -> IO ()
logDebug :: Logger -> String -> IO ()
logDebug = (Logger -> LogLevel -> String -> IO ())
-> LogLevel -> Logger -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Logger -> LogLevel -> String -> IO ()
putLog (LogLevel -> Logger -> String -> IO ())
-> LogLevel -> Logger -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ LogLevel
LogDebug

logInfo :: Logger -> String -> IO ()
logInfo :: Logger -> String -> IO ()
logInfo = (Logger -> LogLevel -> String -> IO ())
-> LogLevel -> Logger -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Logger -> LogLevel -> String -> IO ()
putLog (LogLevel -> Logger -> String -> IO ())
-> LogLevel -> Logger -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ LogLevel
LogInfo

logWarn :: Logger -> String -> IO ()
logWarn :: Logger -> String -> IO ()
logWarn = (Logger -> LogLevel -> String -> IO ())
-> LogLevel -> Logger -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Logger -> LogLevel -> String -> IO ()
putLog (LogLevel -> Logger -> String -> IO ())
-> LogLevel -> Logger -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ LogLevel
LogWarn

logError :: Logger -> String -> IO ()
logError :: Logger -> String -> IO ()
logError = (Logger -> LogLevel -> String -> IO ())
-> LogLevel -> Logger -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Logger -> LogLevel -> String -> IO ()
putLog (LogLevel -> Logger -> String -> IO ())
-> LogLevel -> Logger -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ LogLevel
LogError

-- | FOR TEST: the IORef is the history of logged messages.
_mockLogger :: IO (Logger, IORef [LogEntry])
_mockLogger :: IO (Logger, IORef [LogEntry])
_mockLogger = do
  IORef [LogEntry]
history <- [LogEntry] -> IO (IORef [LogEntry])
forall a. a -> IO (IORef a)
newIORef []
  let puts :: LogLevel -> String -> IO ()
puts LogLevel
level String
msg = IORef [LogEntry] -> ([LogEntry] -> [LogEntry]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [LogEntry]
history ([LogEntry] -> [LogEntry] -> [LogEntry]
forall a. [a] -> [a] -> [a]
++ [LogLevel -> String -> LogEntry
LogEntry LogLevel
level String
msg])
  (Logger, IORef [LogEntry]) -> IO (Logger, IORef [LogEntry])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Logger, IORef [LogEntry]) -> IO (Logger, IORef [LogEntry]))
-> (Logger, IORef [LogEntry]) -> IO (Logger, IORef [LogEntry])
forall a b. (a -> b) -> a -> b
$ (Logger
defaultLogger { loggerPutLogRaw = puts }, IORef [LogEntry]
history)