--------------------------------------------------------------------------------
-- | Produce pretty, thread-safe logs
module Hakyll.Core.Logger
    ( Verbosity (..)
    , Logger
    , new
    , flush
    , error
    , header
    , message
    , debug
    ) where


--------------------------------------------------------------------------------
import           Control.Concurrent      (forkIO)
import           Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import           Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
import           Control.Monad           (forever)
import           Control.Monad.Trans     (MonadIO, liftIO)
import           Data.List               (intercalate)
import           Prelude                 hiding (error)


--------------------------------------------------------------------------------
data Verbosity
    = Error
    | Message
    | Debug
    deriving (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Eq Verbosity
-> (Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
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
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
$cp1Ord :: Eq Verbosity
Ord, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show)


--------------------------------------------------------------------------------
-- | Logger structure. Very complicated.
data Logger = Logger
    { Logger -> Chan (Maybe String)
loggerChan      :: Chan (Maybe String)  -- ^ Nothing marks the end
    , Logger -> MVar ()
loggerSync      :: MVar ()              -- ^ Used for sync on quit
    , Logger -> String -> IO ()
loggerSink      :: String -> IO ()      -- ^ Out sink
    , Logger -> Verbosity
loggerVerbosity :: Verbosity            -- ^ Verbosity
    }


--------------------------------------------------------------------------------
-- | Create a new logger
new :: Verbosity -> IO Logger
new :: Verbosity -> IO Logger
new Verbosity
vbty = do
    Logger
logger <- Chan (Maybe String)
-> MVar () -> (String -> IO ()) -> Verbosity -> Logger
Logger (Chan (Maybe String)
 -> MVar () -> (String -> IO ()) -> Verbosity -> Logger)
-> IO (Chan (Maybe String))
-> IO (MVar () -> (String -> IO ()) -> Verbosity -> Logger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        IO (Chan (Maybe String))
forall a. IO (Chan a)
newChan IO (MVar () -> (String -> IO ()) -> Verbosity -> Logger)
-> IO (MVar ()) -> IO ((String -> IO ()) -> Verbosity -> Logger)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar IO ((String -> IO ()) -> Verbosity -> Logger)
-> IO (String -> IO ()) -> IO (Verbosity -> Logger)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> IO ()) -> IO (String -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure String -> IO ()
putStrLn IO (Verbosity -> Logger) -> IO Verbosity -> IO Logger
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Verbosity -> IO Verbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
vbty
    ThreadId
_      <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Logger -> IO ()
forall b. Logger -> IO b
loggerThread Logger
logger
    Logger -> IO Logger
forall (m :: * -> *) a. Monad m => a -> m a
return Logger
logger
  where
    loggerThread :: Logger -> IO b
loggerThread Logger
logger = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
        Maybe String
msg <- Chan (Maybe String) -> IO (Maybe String)
forall a. Chan a -> IO a
readChan (Chan (Maybe String) -> IO (Maybe String))
-> Chan (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Logger -> Chan (Maybe String)
loggerChan Logger
logger
        case Maybe String
msg of
            -- Stop: sync
            Maybe String
Nothing -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (Logger -> MVar ()
loggerSync Logger
logger) ()
            -- Print and continue
            Just String
m  -> Logger -> String -> IO ()
loggerSink Logger
logger String
m


--------------------------------------------------------------------------------
-- | Flush the logger (blocks until flushed)
flush :: Logger -> IO ()
flush :: Logger -> IO ()
flush Logger
logger = do
    Chan (Maybe String) -> Maybe String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (Logger -> Chan (Maybe String)
loggerChan Logger
logger) Maybe String
forall a. Maybe a
Nothing
    () <- MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar (MVar () -> IO ()) -> MVar () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> MVar ()
loggerSync Logger
logger
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


--------------------------------------------------------------------------------
string :: MonadIO m
       => Logger     -- ^ Logger
       -> Verbosity  -- ^ Verbosity of the string
       -> String     -- ^ Section name
       -> m ()       -- ^ No result
string :: Logger -> Verbosity -> String -> m ()
string Logger
l Verbosity
v String
m
    | Logger -> Verbosity
loggerVerbosity Logger
l Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
v = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Chan (Maybe String) -> Maybe String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (Logger -> Chan (Maybe String)
loggerChan Logger
l) (String -> Maybe String
forall a. a -> Maybe a
Just String
m)
    | Bool
otherwise              = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


--------------------------------------------------------------------------------
error :: MonadIO m => Logger -> String -> m ()
error :: Logger -> String -> m ()
error Logger
l String
m = Logger -> Verbosity -> String -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Verbosity -> String -> m ()
string Logger
l Verbosity
Error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"  [ERROR] " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
indent String
m


--------------------------------------------------------------------------------
header :: MonadIO m => Logger -> String -> m ()
header :: Logger -> String -> m ()
header Logger
l = Logger -> Verbosity -> String -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Verbosity -> String -> m ()
string Logger
l Verbosity
Message


--------------------------------------------------------------------------------
message :: MonadIO m => Logger -> String -> m ()
message :: Logger -> String -> m ()
message Logger
l String
m = Logger -> Verbosity -> String -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Verbosity -> String -> m ()
string Logger
l Verbosity
Message (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
indent String
m


--------------------------------------------------------------------------------
debug :: MonadIO m => Logger -> String -> m ()
debug :: Logger -> String -> m ()
debug Logger
l String
m = Logger -> Verbosity -> String -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Verbosity -> String -> m ()
string Logger
l Verbosity
Debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"  [DEBUG] " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
indent String
m


--------------------------------------------------------------------------------
indent :: String -> String
indent :: ShowS
indent = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n    " ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines