--------------------------------------------------------------------------------
-- | Produce pretty, thread-safe logs
{-# LANGUAGE Rank2Types #-}
module Hakyll.Core.Logger
    ( Verbosity (..)
    , Logger
    , new
    , flush
    , error
    , header
    , message
    , debug

    -- * Testing utilities
    , newInMem
    ) where


--------------------------------------------------------------------------------
import           Control.Concurrent      (forkIO)
import           Control.Concurrent.Chan (newChan, readChan, writeChan)
import           Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import           Control.Monad           (forever, when)
import           Control.Monad.Trans     (MonadIO, liftIO)
import qualified Data.IORef              as IORef
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
$c== :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
/= :: 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
$ccompare :: Verbosity -> Verbosity -> Ordering
compare :: Verbosity -> Verbosity -> Ordering
$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
>= :: Verbosity -> Verbosity -> Bool
$cmax :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
min :: Verbosity -> Verbosity -> 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
$cshowsPrec :: Int -> Verbosity -> ShowS
showsPrec :: Int -> Verbosity -> ShowS
$cshow :: Verbosity -> String
show :: Verbosity -> String
$cshowList :: [Verbosity] -> ShowS
showList :: [Verbosity] -> ShowS
Show)


--------------------------------------------------------------------------------
data Logger = Logger
    { -- | Flush the logger (blocks until flushed)
      Logger -> forall (m :: * -> *). MonadIO m => m ()
flush  :: forall m. MonadIO m => m ()
    , Logger
-> forall (m :: * -> *). MonadIO m => Verbosity -> String -> m ()
string :: forall m. MonadIO m => Verbosity -> String -> m ()
    }


--------------------------------------------------------------------------------
-- | Create a new logger
new :: Verbosity -> IO Logger
new :: Verbosity -> IO Logger
new Verbosity
vbty = do
    chan <- IO (Chan (Maybe String))
forall a. IO (Chan a)
newChan
    sync <- newEmptyMVar
    _    <- forkIO $ forever $ do
        msg <- readChan chan
        case msg of
            -- Stop: sync
            Maybe String
Nothing -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
sync ()
            -- Print and continue
            Just String
m  -> String -> IO ()
putStrLn String
m
    return $ Logger
        { flush = liftIO $ do
            writeChan chan Nothing
            () <- takeMVar sync
            return ()
        , string = \Verbosity
v String
m -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
vbty Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
v) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            IO () -> m ()
forall a. IO a -> m a
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 Chan (Maybe String)
chan (String -> Maybe String
forall a. a -> Maybe a
Just String
m)
        }


--------------------------------------------------------------------------------
error :: MonadIO m => Logger -> String -> m ()
error :: forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
error Logger
l String
m = Logger
-> forall (m :: * -> *). MonadIO m => 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 :: forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
header Logger
l = Logger
-> forall (m :: * -> *). MonadIO m => 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 = Logger
-> forall (m :: * -> *). MonadIO m => 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 :: forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
debug Logger
l String
m = Logger
-> forall (m :: * -> *). MonadIO m => 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


--------------------------------------------------------------------------------
-- | Create a new logger that just stores all the messages, useful for writing
-- tests.
newInMem :: IO (Logger, IO [(Verbosity, String)])
newInMem :: IO (Logger, IO [(Verbosity, String)])
newInMem = do
    ref <- [(Verbosity, String)] -> IO (IORef [(Verbosity, String)])
forall a. a -> IO (IORef a)
IORef.newIORef []
    pure
        ( Logger
            { string = \Verbosity
vbty String
msg -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [(Verbosity, String)]
-> ([(Verbosity, String)] -> ([(Verbosity, String)], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef [(Verbosity, String)]
ref (([(Verbosity, String)] -> ([(Verbosity, String)], ())) -> IO ())
-> ([(Verbosity, String)] -> ([(Verbosity, String)], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$
                \[(Verbosity, String)]
msgs -> ((Verbosity
vbty, String
msg) (Verbosity, String)
-> [(Verbosity, String)] -> [(Verbosity, String)]
forall a. a -> [a] -> [a]
: [(Verbosity, String)]
msgs, ())
            , flush  = pure ()
            }
        , reverse <$> IORef.readIORef ref
        )