--------------------------------------------------------------------------------
-- | 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
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
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
Ord, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a. IO (Chan a)
newChan forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IO (MVar a)
newEmptyMVar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure String -> IO ()
putStrLn forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
vbty
    ThreadId
_      <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall {b}. Logger -> IO b
loggerThread Logger
logger
    forall (m :: * -> *) a. Monad m => a -> m a
return Logger
logger
  where
    loggerThread :: Logger -> IO b
loggerThread Logger
logger = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
        Maybe String
msg <- forall a. Chan a -> IO a
readChan forall a b. (a -> b) -> a -> b
$ Logger -> Chan (Maybe String)
loggerChan Logger
logger
        case Maybe String
msg of
            -- Stop: sync
            Maybe String
Nothing -> 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
    forall a. Chan a -> a -> IO ()
writeChan (Logger -> Chan (Maybe String)
loggerChan Logger
logger) forall a. Maybe a
Nothing
    () <- forall a. MVar a -> IO a
takeMVar forall a b. (a -> b) -> a -> b
$ Logger -> MVar ()
loggerSync Logger
logger
    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 :: forall (m :: * -> *).
MonadIO m =>
Logger -> Verbosity -> String -> m ()
string Logger
l Verbosity
v String
m
    | Logger -> Verbosity
loggerVerbosity Logger
l forall a. Ord a => a -> a -> Bool
>= Verbosity
v = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> a -> IO ()
writeChan (Logger -> Chan (Maybe String)
loggerChan Logger
l) (forall a. a -> Maybe a
Just String
m)
    | Bool
otherwise              = forall (m :: * -> *) a. Monad m => a -> m a
return ()


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


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


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


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


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