{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-------------------------------------------
-- |
-- Module      : Lumberjack
-- Copyright   : (c) Galois Inc. 2020
-- Maintainer  : kquick@galois.com
-- Stability   : experimental
-- Portability : POSIX
-- |
--
-- This module defines a general logging facility that can be used to
-- output log messages to various targets.
-------------------------------------------

module Lumberjack
  ( -- * Interface for Logging
    LogAction(..)
  , HasLog(..)
  , LoggingMonad(..)
  , writeLogM
    -- * Logging Utilities
  , safeLogAction
  , logFilter
    -- * Default LogMessage
  , Severity(..)
  , LogType(..)
  , LogMessage(..)
  , msgWith
  , WithLog
  , withLogTag
  , addLogActionTime
    -- * Output formatting for LogMessage
  , cvtLogMessageToPlainText
  , cvtLogMessageToANSITermText
    -- * Helpers and convenience functions
  , logFunctionCall, logFunctionCallM
  , logProgress, logProgressM
  , tshow
  , defaultGetIOLogAction
  )
where

import qualified Control.Monad.Catch as X
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Data.Functor.Contravariant
import           Data.Functor.Contravariant.Divisible
import           Data.Monoid hiding ( (<>) )
import           Data.Semigroup
import           Data.Text ( Text, pack, empty )
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.Text.Prettyprint.Doc as PP
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as PP_Term
import qualified Data.Text.Prettyprint.Doc.Render.Text as PP_Text
import           Data.Time.Clock ( UTCTime(..), getCurrentTime, diffUTCTime )
import           Data.Time.Format ( defaultTimeLocale, formatTime )
import           Data.Void
import           System.IO ( stderr )

import           Prelude


-- ----------------------------------------------------------------------
-- * Interface for Logging
--
-- The 'LogAction' is the fundamental operation that decides how to
-- log a provided message.
--
-- Code wishing to output a logged message simply uses the LogAction
-- object:
--
-- > writeLog action msg
--
-- For convenience, the LogAction can be stored in the local operating
-- monad context, from which it can be retrieved (and modified).  A
-- monad which can supply a LogAction is a member of the HasLog class,
-- and the 'writeLogM' function will automatically retrieve the
-- LogAction from the monad and write to it:
--
-- > writeLogM msg
--
-- LogActions can be combined via Semigroup operations (<>) and the
-- resulting LogAction will perform both actions with each message.
-- The Monoidal mempty LogAction simply does nothing.  For example,
-- logging to both a file and stdout can be done by @logToFile <>
-- logToStdout@.
--
-- LogActions are also Contravariant (and Divisible and Decidable) to
-- allow easy conversion of a LogAction for the base message type into
-- a LogAction for a different message type (or types) that can be
-- converted to (and combined into) the base message type.

-- | The LogAction holds the ability to log a message of type 'msg'
-- (the second parameter) via a monad 'm' (the first parameter).
--
-- LogActions are semigroup and monoid combineable, which results in
-- both LogActions being taken (or no action in the case of mempty),
-- and contravariant to allow the msg to be modified via function
-- prior to being logged (as well as Divisible and Decidable).
newtype LogAction m msg = LogAction { writeLog :: msg -> m () }

instance Applicative m => Semigroup (LogAction m a) where
  LogAction a1 <> LogAction a2 = LogAction $ \a -> a1 a *> a2 a

instance Applicative m => Monoid (LogAction m a) where
  mappend = (<>)
  mempty = LogAction $ \_ -> pure ()

instance Contravariant (LogAction m) where
  contramap f (LogAction a) = LogAction $ a . f

instance (Applicative m) => Divisible (LogAction m) where
  conquer = LogAction $ \_ -> pure ()
  divide splitf lLog rLog = LogAction $ \i ->
    let (l, r) = splitf i
        ll = writeLog lLog l
        rl = writeLog rLog r
    in ll *> rl

instance (Applicative m) => Decidable (LogAction m) where
  lose f = LogAction $ \a -> absurd (f a)
  choose split l r = LogAction $ either (writeLog l) (writeLog r) . split

-- | Any monad which will support retrieving or adjusting a LogAction
-- must support the 'HasLog' class.
class Monad m => HasLog msg m where
  getLogAction :: m (LogAction m msg)

class (Monad m, HasLog msg m) => LoggingMonad msg m where
  adjustLogAction :: (forall k. LogAction k msg -> LogAction k msg) -> m a -> m a


-- | This invokes the LogAction's logging handler in a monadic context
-- where the logging handler can be retrieved via the 'HasLog' class's
-- 'getLogAction' function.
writeLogM :: HasLog msg m => msg -> m ()
writeLogM m = getLogAction >>= flip writeLog m


----------------------------------------------------------------------
-- * LogAction Utilities
--
-- The following utility functions can be used to adjust or wrap
-- LogActions to provide additional functionality.

-- | Ensures that the LogAction does not fail if the logging operation
-- itself throws an exception (the exception is ignored).
safeLogAction :: X.MonadCatch m => LogAction m msg -> LogAction m msg
safeLogAction a = LogAction $ \m -> X.catch (writeLog a m) (\(_ex :: X.SomeException) -> return ())

-- | The logFilter can be used on a LogAction to determine which
-- messages the LogAction should be invoked for (only those for which
-- the filter function returns True).
logFilter :: Applicative m => (msg -> Bool) -> LogAction m msg -> LogAction m msg
logFilter f (LogAction l) = LogAction $ \m -> when (f m) (l m)



----------------------------------------------------------------------
-- * Default LogMessage
--
-- This is the default 'msg' type for the LogAction, containing the
-- various information associated with the logging to be performed.

-- | The Severity indicates the relative importance of the logging
-- message.  This can be useful for filtering log messages.
data Severity = Debug | Info | Warning | Error deriving (Ord, Eq, Show)

-- | The LogType indicates what type of message this is.  These are
-- printed on the log line and can be used for filtering different
-- types of log messages.
data LogType = Progress | FuncEntry | FuncExit | MiscLog | UserOp
  deriving (Eq, Show)

-- | Each logged output is described by a LogMessage object.
data LogMessage = LogMessage { logType :: LogType
                             , logLevel :: Severity
                             , logTime :: UTCTime
                             , logTags :: [(Text, Text)]
                             , logText :: Text
                             }

instance Semigroup LogMessage where
  a <> b = LogMessage { logType = if logType a == MiscLog then logType b else logType a
                      , logLevel = max (logLevel a) (logLevel b)
                      , logTime = max (logTime a) (logTime b)
                      , logTags = logTags a <> logTags b
                      , logText = case (T.null (logText a), T.null (logText b)) of
                                  (False, False) -> logText a <> "; " <> logText b
                                  (True, False) -> logText b
                                  _ -> logText a
                      }

instance Monoid LogMessage where
  mempty = LogMessage MiscLog Debug (UTCTime (toEnum 0) (toEnum 0)) [] empty
  mappend = (<>)

-- | Helper routine to return an empty LogMessage, whose fields can
-- then be updated.
msgWith :: LogMessage
msgWith = mempty


-- | Add the current timestamp to the LogMessage being logged
addLogActionTime :: MonadIO m => LogAction m LogMessage -> LogAction m LogMessage
addLogActionTime a = LogAction $ \m -> do t <- liftIO getCurrentTime
                                          writeLog a $ m <> mempty { logTime = t }


-- | This type is a Constraint that should be applied to any client
-- function that will perform logging in a monad context.  The 'msg'
-- is the type of message that will be logged, and the 'm' is the
-- monad under which the logging is performed.
type WithLog msg m = ({- X.MonadCatch m, -} HasLog msg m)


-- | Log messages can have any number of key/value tags applied to
-- them.  This function establishes a new key/value tag pair that will
-- be in effect for the monadic operation passed as the third
-- argument.
-- withLogTag tname tval op = local (adjustLogAction $ addLogTag tname tval) op
withLogTag :: (LoggingMonad LogMessage m) => Text -> Text -> m a -> m a
withLogTag tname tval op =
    let tagmsg = mempty { logTags = [(tname, tval)] }
    in (adjustLogAction $ contramap (tagmsg <>)) op


-- ----------------------------------------------------------------------
-- * Output formatting for LogMessage
--
-- Optimal LogMessage formatting uses prettyprinter output with a
-- 'PrettyLogAnn' annotation type which assigns different annotations
-- to different parts of the log message.  This is achieved by calling
-- 'prettyLogMessage'.
--
-- Alternatively, the 'Pretty' class 'pretty'
-- method can be used to get log message formatting for generic
-- annotation types, but the different parts of the message will not
-- be distinguished via annotation values.

data PrettyLogAnn = AnnLogType LogType
                  | AnnSeverity Severity
                  | AnnTime
                  | AnnTimeMinSec
                  | AnnTag
                  | AnnTagVal

-- Use prettyLogType instead
instance PP.Pretty LogType where pretty = anyPrettyLogType

anyPrettyLogType :: LogType -> PP.Doc ann
anyPrettyLogType Progress  = PP.pretty ("progress" :: Text)
anyPrettyLogType FuncEntry = PP.pretty ("entered" :: Text)
anyPrettyLogType FuncExit  = PP.pretty ("completed" :: Text)
anyPrettyLogType UserOp    = PP.pretty ("User-Op" :: Text)
anyPrettyLogType MiscLog   = PP.pretty ("misc" :: Text)

prettyLogType :: LogType -> PP.Doc PrettyLogAnn
prettyLogType t = PP.annotate (AnnLogType t) $ anyPrettyLogType t

-- Use prettySev instead
instance PP.Pretty Severity where pretty = anyPrettySev

anyPrettySev :: Severity -> PP.Doc ann
anyPrettySev Error   = PP.pretty ("ERR " :: Text)
anyPrettySev Warning = PP.pretty ("Warn" :: Text)
anyPrettySev Info    = PP.pretty ("I   " :: Text)
anyPrettySev Debug   = PP.pretty ("Dbg " :: Text)

prettySev :: Severity -> PP.Doc PrettyLogAnn
prettySev s = PP.annotate (AnnSeverity s) $ anyPrettySev s

-- Use prettyTime instead
instance PP.Pretty UTCTime where
  pretty t = PP.hcat [ PP.pretty (formatTime defaultTimeLocale "%Z-%F:%H:" t)
                     , PP.pretty (formatTime defaultTimeLocale "%M:%S" t)
                     , PP.pretty (take 4 (formatTime defaultTimeLocale ".%q" t))
                     ]

prettyTime :: UTCTime -> PP.Doc PrettyLogAnn
prettyTime t =
  if t == UTCTime (toEnum 0) (toEnum 0)
  then PP.annotate AnnTime $ PP.emptyDoc
  else PP.hcat
       [ PP.annotate AnnTime $ PP.pretty (formatTime defaultTimeLocale "%Z-%F_%H:" t)
       , PP.annotate AnnTimeMinSec $ PP.pretty (formatTime defaultTimeLocale "%M:%S" t)
       , PP.annotate AnnTime $ PP.pretty (take 4 (formatTime defaultTimeLocale ".%q" t))
       ]

anyPrettyTags :: [(Text, Text)] -> PP.Doc ann
anyPrettyTags =
  let anyPrettyTag (tag, val) = PP.group $ PP.cat [ PP.pretty tag
                                                  , PP.equals
                                                  , PP.pretty val
                                                  ]
  in foldl (\acc tagval -> acc PP.<+> (anyPrettyTag tagval)) mempty

prettyTags :: [(Text, Text)] -> PP.Doc PrettyLogAnn
prettyTags =
  let ppTag (tag, val) = PP.group $ PP.hcat [ PP.annotate AnnTag $ PP.pretty tag
                                            , PP.equals
                                            , PP.annotate AnnTagVal $ PP.pretty val
                                            ]
  in foldl (\acc tagval -> acc PP.<+> (ppTag tagval)) mempty

-- | Format the log message with annotation values designating the
-- different portions of the pretty-printed value.
--
-- The 'Pretty' class 'pretty' method can be used for generic
-- annotations, but this yields less information for output management.
prettyLogMessage :: LogMessage -> PP.Doc PrettyLogAnn
prettyLogMessage (LogMessage {..}) = PP.hsep [ prettyTime logTime
                                             , prettySev logLevel
                                             , PP.brackets (prettyLogType logType)
                                             , prettyTags logTags
                                             , PP.pretty logText
                                             ]

instance PP.Pretty LogMessage where
  pretty (LogMessage {..}) = PP.hsep [ PP.pretty logTime
                                     , PP.pretty logLevel
                                     , PP.brackets (PP.pretty logType)
                                     , anyPrettyTags logTags
                                     , PP.pretty logText
                                     ]


-- | The 'termStyle' converts the LogMessage annotations into ANSI
-- terminal styles to add colors and other effects such as bolding to
-- various portions of log messages (for use with
-- prettyprinter-ansi-terminal).
termStyle :: PrettyLogAnn -> PP_Term.AnsiStyle
termStyle (AnnLogType Progress)  = PP_Term.colorDull PP_Term.Green
termStyle (AnnLogType FuncEntry) = PP_Term.colorDull PP_Term.Magenta
termStyle (AnnLogType FuncExit)  = PP_Term.colorDull PP_Term.Cyan
termStyle (AnnLogType UserOp)    = PP_Term.bold <> PP_Term.color PP_Term.Green
termStyle (AnnLogType MiscLog)   = mempty
termStyle (AnnSeverity Error)   = PP_Term.bold <> PP_Term.color PP_Term.Red <> PP_Term.bgColor PP_Term.Yellow
termStyle (AnnSeverity Warning) = PP_Term.bold <> PP_Term.colorDull PP_Term.Red
termStyle (AnnSeverity Info)    = mempty
termStyle (AnnSeverity Debug)   = PP_Term.color PP_Term.Blue
termStyle AnnTime       = mempty
termStyle AnnTimeMinSec = PP_Term.color PP_Term.White <> PP_Term.bold
termStyle AnnTag    = PP_Term.color PP_Term.Black <> PP_Term.bold
termStyle AnnTagVal = PP_Term.color PP_Term.Black <> PP_Term.bold


-- | Standard function to convert a LogMessage into Text with ANSI
-- terminal colors and bolding and other styling.  This can be used as
-- the default converter for a logger (via contramap).
cvtLogMessageToANSITermText :: LogMessage -> Text
cvtLogMessageToANSITermText = PP_Term.renderStrict .
                              PP.reAnnotateS termStyle .
                              PP.layoutSmart PP.defaultLayoutOptions .
                              prettyLogMessage

-- | Standard function for converting a LogMessage into plain Text (no
-- colors or bolding, just text).  This can be used as the default
-- converter for a logger (via contramap).
cvtLogMessageToPlainText :: LogMessage -> Text
cvtLogMessageToPlainText = PP_Text.renderStrict .
                           PP.layoutSmart PP.defaultLayoutOptions .
                           prettyLogMessage

-- ----------------------------------------------------------------------
-- * Helpers and convenience functions
--
-- These functions are not part of the core Logging implementation,
-- but can be useful to clients to perform common or default
-- operations.

-- | A wrapper for a monadic function call that will log on entry
-- (Debug) and exit (Info) from the function, and note the total
-- amount of time taken during execution of the function.  Note that
-- no strictness is applied to the internal monadic operation, so the
-- time taken may be misleading.  Like 'logFunctionCallM' but needs an
-- explicit 'LogAction' whereas 'logFunctionCallM' will retrieve the
-- 'LogAction' from the current monadic context.
logFunctionCall :: (MonadIO m) => LogAction m LogMessage -> Text -> m a -> m a
logFunctionCall = logFunctionCallWith . writeLog

-- | A wrapper for a monadic function call that will log on entry
-- (Debug) and exit (Info) from the function, and note the total
-- amount of time taken during execution of the function.  Note that
-- no strictness is applied to the internal monadic operation, so the
-- time taken may be misleading.
logFunctionCallM :: (MonadIO m, WithLog LogMessage m) => Text -> m a -> m a
logFunctionCallM = logFunctionCallWith writeLogM

-- | Internal function implementing the body for 'logFunctionCall' or
-- 'logFunctionCallM'
logFunctionCallWith :: (MonadIO m) => (LogMessage -> m ()) -> Text -> m a -> m a
logFunctionCallWith logger fName f =
  do logger $ msgWith { logType = FuncEntry, logText = fName }
     t <- liftIO getCurrentTime
     r <- f
     t' <- liftIO getCurrentTime
     let dt = diffUTCTime t' t
     logger $ msgWith { logType = FuncExit, logLevel = Info
                      , logText = fName <> ", executed for " <> pack (show dt) }
     return r


-- | Called to output a log message to indicate that some progress has
-- been made.
logProgress :: (MonadIO m) => LogAction m LogMessage -> Text -> m ()
logProgress action txt = writeLog action $ msgWith { logLevel = Info, logType = Progress, logText = txt }


-- | Called to output a log message within a Logging monad to indicate
-- that some progress has been made.
logProgressM :: (MonadIO m, WithLog LogMessage m) => Text -> m ()
logProgressM txt = writeLogM $ msgWith { logLevel = Info, logType = Progress, logText = txt }


-- | This is a helper because the LogMessage normally wants a Text,
-- but show delivers a String.
tshow :: (Show a) => a -> Text
tshow = pack . show


-- | When using a simple IO monad, there is no ability to store a
-- LogAction in the base monad.  The client can specify a specific
-- HasLog instance for IO that is appropriate to that client, and that
-- HasLog can optionally use the 'defaultGetIOLogAction' as the
-- 'getLogAction' implementation to log pretty messages with ANSI
-- styling to stdout.
--
--  > instance HasLog Env Text IO where
--  >     getLogAction = return defaultGetIOLogAction
--  >     ...
defaultGetIOLogAction :: MonadIO m => LogAction m T.Text
defaultGetIOLogAction = LogAction $ liftIO . TIO.hPutStrLn stderr