module Logging.Bock
  ( debug
  , info
  , warn
  , error
  , critical
  , die

  , Logger
  , Level(..)
  , HasLogger(..)
  , setGlobalLogger
  , mkLogger
  ) where

import           Control.Monad (when)
import qualified Control.Monad.IO.Class as IOClass
import qualified Data.Char as Char
import qualified Data.IORef as IORef
import qualified GHC.Stack as GHC
import qualified System.Environment as Env
import qualified System.Exit as Exit
import qualified System.IO as IO
import qualified System.IO.Unsafe as Unsafe
import           Prelude hiding (log, error)

import           Logging.Bock.Color (supportsColor)

-- | A 'Logger' represents the current configuration of log messages,
-- and includes where to send log messages (e.g. to stderr or to
-- files) and the current severity cutoff.
data Logger = Logger
  { logUseColors :: !Bool
  , logWrite     :: !(String -> IO ())
  , logLevel     :: !Level
  }

-- | The level of severity of the log. Severity levels are used for
-- controlling which logging messages are important enough to be shown
-- and which should not be. The default severity level of the logger
-- is 'Info', which means all messages except 'Debug' messages will be
-- shown. This can be modified upwards (to show only more important
-- messages) or downwards (to show all messages.)
data Level
  = Debug
  | Info
  | Warn
  | Error
  | Critical
    deriving (Eq, Show, Ord)

-- | The default logger will
parseLevel :: String -> Maybe Level
parseLevel s = case map Char.toUpper s of
  "DEBUG"    -> Just Debug
  "INFO"     -> Just Info
  "WARN"     -> Just Warn
  "ERROR"    -> Just Error
  "CRITICAL" -> Just Critical
  _          -> Nothing

colorCode :: Level -> String
colorCode Debug    = "\x1b[94m"
colorCode Info     = ""
colorCode Warn     = "\x1b[93m"
colorCode Error    = "\x1b[91m"
colorCode Critical = "\x1b[91m"

endColorCode :: String
endColorCode = "\x1b[39m"

-- for pretty-printing the locations of the log messages
type Loc = Maybe (String, Int)

getLoc :: GHC.CallStack -> Loc
getLoc stack = case GHC.getCallStack stack of
  [] -> Nothing
  (_, loc):_ -> Just (GHC.srcLocModule loc, GHC.srcLocStartLine loc)

showLoc :: Monad m => (String -> m ()) -> Loc -> m ()
showLoc _ Nothing = pure ()
showLoc f (Just (md, ln)) = mapM_ f ["[", md, ":", show ln, "]: "]

defaultLogger :: IORef.IORef Logger
defaultLogger = Unsafe.unsafePerformIO $ do
  levelMb <- Env.lookupEnv "LOG_LEVEL"
  let level = case levelMb of
        Just str | Just lvl <- parseLevel str -> lvl
        _ -> Info
  locMb <- Env.lookupEnv "LOG_LOCATION"
  logger <- mkLogger level =<< case locMb of
    Just path -> IO.openFile path IO.WriteMode
    Nothing   -> pure IO.stderr
  IORef.newIORef logger

-- | Modify the current global logger.
setGlobalLogger :: Logger -> IO ()
setGlobalLogger = IORef.writeIORef defaultLogger

-- | Create a logger with a specified severity cutoff and a handle to
-- write to. This will automatically support message coloring if the
-- handle corresponds to a TTY (i.e. if it is pointed at
-- stdout/stderr) and otherwise will not.
mkLogger :: Level -> IO.Handle -> IO Logger
mkLogger level h = do
  useColors <- supportsColor h
  pure Logger
    { logUseColors = useColors
    , logWrite     = \ msg -> IO.hPutStr h msg >> IO.hFlush h
    , logLevel     = level
    }

-- | A typeclass for monads which support producing log
-- messages. These can piggyback on the IO instance, which uses a
-- shared global logger, or they can create a derived and locally
-- stored logger which might put its log messages in a different place
-- or use a different format
class IOClass.MonadIO m => HasLogger m where
  getLogger :: m Logger

instance HasLogger IO where
  getLogger = IORef.readIORef defaultLogger



log :: HasLogger m => Level -> Loc -> [String] -> m ()
log lvl loc msg = do
  l <- getLogger
  when (lvl >= logLevel l) $ IOClass.liftIO $ do
    when (logUseColors l) $
      logWrite l (colorCode lvl)
    showLoc (logWrite l) loc
    logWrite l (unwords msg)
    when (logUseColors l) $
      logWrite l endColorCode
    logWrite l "\n"

-- | Produce a 'Debug'-level log message.
debug :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
debug = log Debug (getLoc GHC.callStack)

-- | Produce an 'Info'-level log message.
info :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
info = log Info (getLoc GHC.callStack)

-- | Produce an 'Warn'-level log message.
warn :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
warn = log Warn (getLoc GHC.callStack)

-- | Produce an 'Error'-level log message.
error :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
error = log Error (getLoc GHC.callStack)

-- | Produce a 'Critical'-level log message.
critical :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
critical = log Critical (getLoc GHC.callStack)

-- | Produce a 'Critical'-level log message, and then exit the program
-- immediately with an error code.
die :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
die msg = do
  log Critical (getLoc GHC.callStack) msg
  IOClass.liftIO Exit.exitFailure