{-|
Module      : Log
Description : Logging system for the CLI
Copyright   : (c) 2017 Patrick Champion
License     : see LICENSE file
Maintainer  : chlablak@gmail.com
Stability   : provisional
Portability : portable
-}
module Log
    ( Logger
    , LoggerIO
    -- ** High-API
    , start
    , ok
    , setLevel
    , getLevel
    , flushAll
    , flushOutOnly
    , flushOutToFile
    , pushTag
    , popTag
    , pushTask
    , popTask
    , autoFlush
    -- ** Low-API
    , pushMsg
    , pushOut
    -- **Shortcuts
    , io
    , none
    , off
    , fatal
    , err
    , warn
    , info
    , debug
    , trace
    , abort
    , out
    , getLog
    , task
    ) where

import           Control.Monad.State
import           Data.Char
import           System.Clock

-- |Alias
type Tag = String
type Level = Int
type Task = String

-- |Logging messages
data Message
  = PushMsg Level String  -- ^Push a new message with a specific level
  | PushOut String        -- ^Push a new message to output
  | PushTag Tag           -- ^Push a new tag
  | PopTag                -- ^Pop the top tag
  | SetLevel Level        -- ^Set veborsity level
  | AutoFlush Bool        -- ^Set auto flush on/off
  | None                  -- ^Nothing to do
    deriving Show

-- |Logger
type Log = (Bool, Level, [Tag], [(Task, TimeSpec)], [Message], Bool)
type Logger = StateT Log IO ()
type LoggerIO a = StateT Log IO a

-- |IO operation
io :: IO a -> LoggerIO a
io = liftIO

-- |Pre-defined shortcuts
off = setLevel 1000
fatal m = do { pushTag "fatal"; pushMsg 60 m; popTag; ko }
err m = do { pushTag "error"; pushMsg 50 m; popTag }
warn m = do { pushTag "warning"; pushMsg 40 m; popTag }
info m = do { pushTag "info"; pushMsg 30 m; popTag }
debug m = do { pushTag "debug"; pushMsg 20 m; popTag }
trace m = do { pushTag "trace"; pushMsg 10 m; popTag }
abort = fatal "aborting..."
out = pushOut
getLog = (False, 0 :: Int, [], [], [], True)
task x = x `seq` x

-- |Start a new logger
start :: Level -> Tag -> Logger
start l t = put (False, l, [t], [], [], True)

-- |Is the logger ok ?
ok :: LoggerIO Bool
ok = do
  (_, _, _, _, _, v) <- get
  Log.io $ return v

-- |Set logger to KO
ko :: Logger
ko = do
  (af, l, ts, ks, ms, _) <- get
  put (af, l, ts, ks, ms, False)

-- |Get level
getLevel :: LoggerIO Int
getLevel = do
  (_, l, _, _, _, _) <- get
  Log.io $ return l

-- |Nothing to do
none :: Logger
none = do
  (af, l, ts, ks, ms, v) <- get
  put (af, l, ts, ks, None : ms, v)

-- |Push a new tag
pushTag :: Tag -> Logger
pushTag t = do
  (af, l, ts, ks, ms, v) <- get
  put (af, l, ts, ks, PushTag t : ms, v)

-- |Pop the top tag
popTag :: Logger
popTag = do
  (af, l, ts, ks, ms, v) <- get
  put (af, l, ts, ks, PopTag : ms, v)

-- |Push a new message with a specific level
pushMsg :: Level -> String -> Logger
pushMsg l m = do
  (af, l2, ts, ks, ms, v) <- get
  put (af, l2, ts, ks, PushMsg l m : ms, v)
  when af flushAll

-- |Push a new message to be outputed
pushOut :: String -> Logger
pushOut m = do
  (af, l, ts, ks, ms, v) <- get
  put (af, l, ts, ks, PushOut m : ms, v)
  when af flushAll

-- |Set verbosity level
setLevel :: Int -> Logger
setLevel l = do
  (af, l, ts, ks, ms, v) <- get
  put (af, l, ts, ks, SetLevel l : ms, v)

-- |Set auto flush on/off
autoFlush :: Bool -> Logger
autoFlush value = do
  (af, l, ts, ks, ms, v) <- get
  put (af, l, ts, ks, AutoFlush value : ms, v)
  when value flushAll

-- |Push a new task
pushTask :: Task -> Logger
pushTask k = do
  (af, l, ts, ks, ms, v) <- get
  start <- io $ getTime Monotonic
  put (af, l, ts, (k,start):ks, ms, v)
  pushTag "task"
  pushTag "start"
  pushMsg 30 k
  popTag
  popTag

-- |Pop the top task
popTask :: Logger
popTask = do
  (af, l, ts, (k,start):ks, ms, v) <- get
  put (af, l, ts, ks, ms, v)
  end <- io $ getTime Monotonic
  let TimeSpec { sec = _, nsec = nsec } = diffTimeSpec start end
  pushTag "task"
  pushTag "end"
  pushMsg 30 $ "in " ++ show (div nsec 1000000) ++ "ms, " ++ k
  popTag
  popTag

-- |Flush the logger to output
flushAll :: Logger
flushAll = do
  (af, l, ts, ks, ms, v) <- get
  flushAll' (af, l, ts, ks, reverse ms, v)
  where
    flushAll' l@(_, _, _, _, [], v) = put l
    flushAll' (af, l, ts, ks, PushMsg l2 m:ms, v) = do
      when (l <= l2) $ do
        io $ putTag ts
        io $ putStrLn m
      flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, l, ts, ks, PushOut m:ms, v) = do
      io $ putStrLn m
      flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, l, ts, ks, PushTag t:ms, v) = flushAll' (af, l, t:ts, ks, ms, v)
    flushAll' (af, l, _:ts, ks, PopTag:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, _, ts, ks, SetLevel l:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (_, l, ts, ks, AutoFlush af:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, l, ts, ks, None:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    putTag ts =
      putStr $ concatMap (\t -> "[" ++ map toUpper t ++ "]") (reverse ts) ++ " "

-- |Flush the output to a file
flushOutToFile :: FilePath -> Logger
flushOutToFile f = do
  (af, l, ts, ks, ms, v) <- get
  io $ writeFile f ""
  flushAll' (af, l, ts, ks, reverse ms, v)
  where
    flushAll' l@(_, _, _, _, [], v) = put l
    flushAll' (af, l, ts, ks, PushMsg l2 m:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, l, ts, ks, PushOut m:ms, v) = do
      io $ appendFile f $ m ++ "\n"
      flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, l, ts, ks, PushTag t:ms, v) = flushAll' (af, l, t:ts, ks, ms, v)
    flushAll' (af, l, _:ts, ks, PopTag:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, _, ts, ks, SetLevel l:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (_, l, ts, ks, AutoFlush af:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, l, ts, ks, None:ms, v) = flushAll' (af, l, ts, ks, ms, v)

-- |Flush output only
flushOutOnly :: Logger
flushOutOnly = do
  (af, l, ts, ks, ms, v) <- get
  flushAll' (af, l, ts, ks, reverse ms, v)
  where
    flushAll' l@(_, _, _, _, [], v) = put l
    flushAll' (af, l, ts, ks, PushMsg l2 m:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, l, ts, ks, PushOut m:ms, v) = do
      io $ putStrLn m
      flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, l, ts, ks, PushTag t:ms, v) = flushAll' (af, l, t:ts, ks, ms, v)
    flushAll' (af, l, _:ts, ks, PopTag:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, _, ts, ks, SetLevel l:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (_, l, ts, ks, AutoFlush af:ms, v) = flushAll' (af, l, ts, ks, ms, v)
    flushAll' (af, l, ts, ks, None:ms, v) = flushAll' (af, l, ts, ks, ms, v)