--------------------------------------------------------------------------------
-- | 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
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)


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


--------------------------------------------------------------------------------
-- | 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
    IORef [(Verbosity, String)]
ref <- forall a. a -> IO (IORef a)
IORef.newIORef []
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Logger
            { string :: forall (m :: * -> *). MonadIO m => Verbosity -> String -> m ()
string = \Verbosity
vbty String
msg -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef [(Verbosity, String)]
ref forall a b. (a -> b) -> a -> b
$
                \[(Verbosity, String)]
msgs -> ((Verbosity
vbty, String
msg) forall a. a -> [a] -> [a]
: [(Verbosity, String)]
msgs, ())
            , flush :: forall (m :: * -> *). MonadIO m => m ()
flush  = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            }
        , forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
IORef.readIORef IORef [(Verbosity, String)]
ref
        )