--------------------------------------------------------------------------------
-- | 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 (Eq, Ord, Show)


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


--------------------------------------------------------------------------------
-- | Create a new logger
new :: Verbosity -> IO Logger
new vbty = do
    chan <- newChan
    sync <- newEmptyMVar
    _    <- forkIO $ forever $ do
        msg <- readChan chan
        case msg of
            -- Stop: sync
            Nothing -> putMVar sync ()
            -- Print and continue
            Just m  -> putStrLn m
    return $ Logger
        { flush = liftIO $ do
            writeChan chan Nothing
            () <- takeMVar sync
            return ()
        , string = \v m -> when (vbty >= v) $
            liftIO $ writeChan chan (Just m)
        }


--------------------------------------------------------------------------------
error :: MonadIO m => Logger -> String -> m ()
error l m = string l Error $ "  [ERROR] " ++ indent m


--------------------------------------------------------------------------------
header :: MonadIO m => Logger -> String -> m ()
header l = string l Message


--------------------------------------------------------------------------------
message :: MonadIO m => Logger -> String -> m ()
message l m = string l Message $ "  " ++ indent m


--------------------------------------------------------------------------------
debug :: MonadIO m => Logger -> String -> m ()
debug l m = string l Debug $ "  [DEBUG] " ++ indent m


--------------------------------------------------------------------------------
indent :: String -> String
indent = intercalate "\n    " . lines


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