Logger.hs

{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

{-# OPTIONS_GHC -Wall            #-}

{-|

Provides logging for analyses. 'MonadLogger' is a type class for monads which
support logging. 'LoggerT' is a concrete monad transformer instantiating the
class.

As a logger runs, it may print out log messages on the fly (depending on the
provided 'LogOutput' function). It also collects logs to be inspected at the end
of the computation.

A log message must usually include an 'Origin', which describes where in a
Fortran source file the message originated. This is made more convenient via
functions such as 'logWarn\'', which produces an 'Origin' based on a piece of
Fortran syntax, along with a default source file stored in the environment.

Log messages each come with an associated 'LogLevel':

- 'LogError' is for hard errors which will often cause the computation to fail.
- 'LogWarn' is for messages about things that are likely to cause problems.
- 'LogInfo' is for general information about what the computation is doing.
- 'LogDebug' is for extra-verbose output that helps with debugging, but which
  will be uninteresting to most users.

-}
module Camfort.Analysis.Logger
  (
  -- * Conversion to text description
    Describe(..)
  , tellDescribe
  , describeShow
  , builderToStrict
  , Builder
  , Text
  , (<>)
  -- * Messages
  , Origin(..)
  , ParsedOrigin(..)
  , parseOrigin
  , oFile
  , oSpan
  , LogLevel(..)
  , LogMessage(..)
  , lmOrigin
  , lmMsg
  , SomeMessage(..)
  , _MsgError
  , _MsgWarn
  , _MsgInfo
  , _MsgDebug
  -- * Logging monad
  , MonadLogger(..)
  , atSpanned
  , atSpannedInFile
  , LoggerT
  , mapLoggerT
  -- * Running a logger
  , LogOutput
  , logOutputStd
  , logOutputNone
  , runLoggerT
  ) where

import qualified Data.Semigroup                 as SG
import           Data.Void                      (Void)

import           Control.DeepSeq
import           Control.Lens

import           Control.Monad.Except
import           Control.Monad.Morph
import           Control.Monad.Reader
import           Control.Monad.RWS
import qualified Control.Monad.State            as Lazy
import           Control.Monad.State.Strict
import           Control.Monad.Writer
import           Control.Monad.Fail

import           Data.Text                      (Text)
import qualified Data.Text.IO                   as Text
import qualified Data.Text.Lazy                 as Lazy
import           Data.Text.Lazy.Builder         (Builder)
import qualified Data.Text.Lazy.Builder         as Builder

import           GHC.Generics

import           Text.Read                      (readMaybe)
import qualified Language.Fortran.Util.Position as F

--------------------------------------------------------------------------------
--  'Describe' class
--------------------------------------------------------------------------------

-- TODO: More 'Describe' instances for built-in types.

-- | A type class for efficiently converting values to human-readable output.
-- Can be automatically instantiated for 'Show' types, but this will not be very
-- human-readable for a lot of types.
class Describe a where
  -- | Convert the value to a human-readable output as a strict 'Text' value.
  describe :: a -> Text

  -- | Convert the value to human-readable output in a text 'Builder' which can
  -- be efficiently concatenated with other 'Builder's.
  describeBuilder :: a -> Builder

  default describeBuilder :: Show a => a -> Builder
  describe = builderToStrict . describeBuilder
  describeBuilder = Builder.fromString . show

instance Describe F.SrcSpan
instance Describe Text where
  describeBuilder = Builder.fromText
instance Describe [Char] where
  describeBuilder = Builder.fromString
instance Describe () where
  describeBuilder = const mempty
instance Describe Int
instance Describe Integer
instance Describe Float
instance Describe Double
instance Describe Void

-- | A convenience combinator to directly convert a lazy text 'Builder' to a
-- strict 'Text' value.
builderToStrict :: Builder -> Text
builderToStrict = Lazy.toStrict . Builder.toLazyText

-- | Write a 'Describe'-able value directly into a writer monad.
tellDescribe :: (MonadWriter Builder m, Describe a) => a -> m ()
tellDescribe = tell . describeBuilder

-- | Convert a 'Show'-able value directly to strict 'Text'. Useful when you have
-- a 'Show' instance but not a 'Describe' instance.
describeShow :: (Show a) => a -> Text
describeShow = describe . show

--------------------------------------------------------------------------------
--  Messages
--------------------------------------------------------------------------------

-- | A message origin, containing a file and a source span.
data Origin =
  Origin
  { _oFile :: FilePath
  , _oSpan :: F.SrcSpan
  }
  deriving (Show, Eq, Ord, Generic)

makeLenses ''Origin

instance NFData Origin

instance Describe Origin where
  describeBuilder origin =
    "at [" <> Builder.fromString (origin ^. oFile) <>
    ", " <> describeBuilder (origin ^. oSpan) <> "]"

data ParsedOrigin = ParsedOrigin FilePath (Int, Int) (Int, Int)
  deriving (Show, Eq, Ord)

-- | Extract information about filename and source span from a string.
parseOrigin :: String -> Maybe ParsedOrigin
parseOrigin str
  | not (null filename)
  , Just (pos1, rest) <- parsePos comma
  , Just (pos2, _)    <- parsePos rest = Just (ParsedOrigin filename pos1 pos2)
  | otherwise                          = Nothing
  where
    lbrack            = dropWhile (/= '[') str
    (filename, comma) = break (==',') (drop 1 lbrack)

parsePos :: String -> Maybe ((Int, Int), String)
parsePos str
  | Just l <- readMaybe line
  , Just c <- readMaybe col  = Just ((l, c), rest)
  | otherwise                = Nothing
  where
    lparen        = dropWhile (/= '(') str
    (line, colon) = break (== ':') (drop 1 lparen)
    (col, rest)   = span (/= ')') (drop 1 colon)

-- | A logging level. At each logging level, only produce output at that level or lower.
data LogLevel
  = LogError
  -- ^ At level 'LogError', only error messages are shown.
  | LogWarn
  -- ^ At level 'LogWarn', error and warning messages are shown.
  | LogInfo
  -- ^ At level 'LogInfo', error, warning and information messages are shown.
  | LogDebug
  -- ^ At level 'LogDebug', error, warning, information and debug output is
  -- shown.
  deriving (Show, Eq, Ord)

instance Describe LogLevel where
  describeBuilder LogError = "ERROR"
  describeBuilder LogWarn  = "WARN"
  describeBuilder LogInfo  = "INFO"
  describeBuilder LogDebug = "DEBUG"

-- | A logged message with an origin and a message value.
data LogMessage a =
  LogMessage
  { _lmOrigin :: Maybe Origin
  , _lmMsg    :: a
  }
  deriving (Show, Eq, Functor, Foldable, Traversable, Generic)

makeLenses ''LogMessage

instance NFData a => NFData (LogMessage a)

instance Describe a => Describe (LogMessage a) where
  describeBuilder msg =
    maybe "" describeBuilder (msg ^. lmOrigin) <>
    ": " <> describeBuilder (msg ^. lmMsg)

-- | A message at one of the four 'LogLevel's.
data SomeMessage e w
  = MsgError (LogMessage e)
  | MsgWarn (LogMessage w)
  | MsgInfo (LogMessage Text)
  | MsgDebug (LogMessage Text)
  deriving (Show, Eq, Generic)

makePrisms ''SomeMessage

instance (NFData e, NFData w) => NFData (SomeMessage e w)

someMessageOrigin :: Lens' (SomeMessage e w) (Maybe Origin)
someMessageOrigin =
  lens
  (preview $
    (_MsgError . lmOrigin `failing`
     _MsgWarn  . lmOrigin `failing`
     _MsgInfo  . lmOrigin `failing`
     _MsgDebug . lmOrigin
    ) . _Just)
  (flip $ \o ->
   set (_MsgError . lmOrigin) o .
   set (_MsgWarn  . lmOrigin) o .
   set (_MsgInfo  . lmOrigin) o .
   set (_MsgDebug . lmOrigin) o)


instance (Describe e, Describe w) => Describe (SomeMessage e w) where
  describeBuilder msg = case msg of
    MsgError m -> "ERROR: " <> describeBuilder m
    MsgWarn  m -> "WARN: "  <> describeBuilder m
    MsgInfo  m -> "INFO: "  <> describeBuilder m
    MsgDebug m -> "DEBUG: " <> describeBuilder m

--------------------------------------------------------------------------------
--  'MonadLogger' class
--------------------------------------------------------------------------------

-- | Make an origin at the source span of a piece of Fortran syntax, in the
-- current file.
atSpanned :: (MonadLogger e w m, F.Spanned a) => a -> m Origin
atSpanned astElem = do
  sf <- getDefaultSourceFile
  let sp = F.getSpan astElem
  return $ Origin sf sp

-- | Make an origin at the source span of a piece of Fortran syntax, in the given
-- file.
atSpannedInFile :: (F.Spanned a) => FilePath -> a -> Origin
atSpannedInFile sf = Origin sf . F.getSpan

-- | MTL-style type class for monads that support logging.
class Monad m => MonadLogger e w m | m -> e w where
  -- | Set the default source file, i.e. the file in which messages originate by
  -- default.
  setDefaultSourceFile :: FilePath -> m ()

  -- | Get the current default source file, i.e. the file in which messages
  -- originate by default.
  getDefaultSourceFile :: m FilePath

  -- | Record a log message. Output it based on the 'LogOutput' function used
  -- and store it in the collected logs.
  recordLogMessage :: SomeMessage e w -> m ()

  -- | Log an error message at the given 'Origin'.
  logError :: Origin -> e -> m ()
  logError = logGeneral MsgError

  -- | Log an error message. The origin is the current default source file, with
  -- the source span of the given piece of Fortran syntax.
  logError' :: (F.Spanned a) => a -> e -> m ()
  logError' = withSpannedOrigin logError


  -- | Log a warning message at the given 'Origin'.
  logWarn :: Origin -> w -> m ()
  logWarn = logGeneral MsgWarn

  -- | Log a warning message. The origin is the current default source file, with
  -- the source span of the given piece of Fortran syntax.
  logWarn' :: (F.Spanned a) => a -> w -> m ()
  logWarn' = withSpannedOrigin logWarn


  -- | Log an information message at the given 'Origin'.
  logInfo :: Origin -> Text -> m ()
  logInfo = logGeneral MsgInfo

  -- | Log an information message. The origin is the current default source
  -- file, with the source span of the given piece of Fortran syntax.
  logInfo' :: (F.Spanned a) => a -> Text -> m ()
  logInfo' = withSpannedOrigin logInfo

  -- | Log an information message with no origin. For example, use this when
  -- printing output about the progress of an analysis which cannot be
  -- associated with a particular bit of source code.
  logInfoNoOrigin :: Text -> m ()
  logInfoNoOrigin msg = recordLogMessage (MsgInfo (LogMessage Nothing msg))


  -- | Log a debugging message at the given 'Origin'.
  logDebug :: Origin -> Text -> m ()
  logDebug = logGeneral MsgDebug

  -- | Log a debugging message. The origin is the current default source
  -- file, with the source span of the given piece of Fortran syntax.
  logDebug' :: (F.Spanned a) => a -> Text -> m ()
  logDebug' = withSpannedOrigin logDebug

  default recordLogMessage
    :: (MonadTrans t, MonadLogger e w m', m ~ t m') => SomeMessage e w -> m ()
  default setDefaultSourceFile
    :: (MonadTrans t, MonadLogger e w m', m ~ t m') => FilePath -> m ()
  default getDefaultSourceFile
    :: (MonadTrans t, MonadLogger e w m', m ~ t m') => m FilePath

  recordLogMessage = lift . recordLogMessage
  setDefaultSourceFile = lift . setDefaultSourceFile
  getDefaultSourceFile = lift getDefaultSourceFile

logGeneral :: (MonadLogger e w m) => (LogMessage a -> SomeMessage e w) -> Origin -> a -> m ()
logGeneral mkMsg origin msg =
  recordLogMessage (mkMsg (LogMessage (Just origin) msg))

withSpannedOrigin
  :: (MonadLogger e w m, F.Spanned a)
  => (Origin -> b -> m c) -> a -> b -> m c
withSpannedOrigin f x m = do
  origin <- atSpanned x
  f origin m

instance MonadLogger e w m => MonadLogger e w (ReaderT r m)
instance MonadLogger e w m => MonadLogger e w (ExceptT e' m)
instance MonadLogger e w m => MonadLogger e w (StateT s m)
instance (MonadLogger e w m, Monoid w') => MonadLogger e w (WriterT w' m)
instance MonadLogger e w m => MonadLogger e w (Lazy.StateT s m)
-- instance (MonadLogger e w m, Monoid w') => MonadLogger e w (Lazy.WriterT w' m)
instance (MonadLogger e w m, Monoid w') => MonadLogger e w (RWST r w' s m)
-- instance (MonadLogger e w m, Monoid w') => MonadLogger e w (Lazy.RWST r w' s m)

--------------------------------------------------------------------------------
--  'LoggerT' monad
--------------------------------------------------------------------------------

data LoggerState =
  LoggerState
  { _lsLogLevel          :: !LogLevel
  , _lsDefaultSourceFile :: !FilePath
  , _lsPreviousOrigin    :: !(Maybe Origin)
  }

data OpMonoid a = OpMonoid { getOpMonoid :: a }

makeWrapped ''OpMonoid

instance SG.Semigroup a => SG.Semigroup (OpMonoid a) where
  OpMonoid x <> OpMonoid y = OpMonoid (y SG.<> x)

instance (SG.Semigroup a, Monoid a) => Monoid (OpMonoid a) where
  mempty = OpMonoid mempty
  mappend = (SG.<>)

data LoggerEnv m =
  LoggerEnv
  { _leLogFunc :: !(Bool -> LogLevel -> LogLevel -> Text -> Text -> m ())
  }

makeLenses ''LoggerState
makeLenses ''LoggerEnv

hoistEnv :: (m () -> n ()) -> LoggerEnv m -> LoggerEnv n
hoistEnv f = leLogFunc %~ \logFunc b l1 l2 m1 m2 -> f $ logFunc b l1 l2 m1 m2

-- | The logging monad transformer, containing errors of type @e@ and warnings
-- of type @w@.
newtype LoggerT e w m a =
  LoggerT (RWST (LoggerEnv m) (OpMonoid [SomeMessage e w]) LoggerState m a)
  deriving
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadError e'
    , MonadFail
    )

instance MonadTrans (LoggerT e w) where
  lift = LoggerT . lift

instance (MonadState s m) => MonadState s (LoggerT e w m) where
  get = lift get
  put = lift . put
  state = lift . state

instance (MonadReader r m) => MonadReader r (LoggerT e w m) where
  ask = lift ask
  local f (LoggerT (RWST k)) = LoggerT $ RWST $ \e -> local f . k e

instance (MonadWriter w' m) => MonadWriter w' (LoggerT e w m) where
  tell = lift . tell

  listen (LoggerT (RWST k)) = LoggerT $ RWST $ \e s -> do
    ((x, w, s'), w') <- listen (k e s)
    return ((x, w'), w, s')

  pass (LoggerT (RWST k)) = LoggerT $ RWST $ \e s ->
    pass $ (\((x, f), w, s') -> ((x, w, s'), f)) <$> k e s

instance (Monad m, Describe e, Describe w) =>
         MonadLogger e w (LoggerT e w m) where
  setDefaultSourceFile = LoggerT . (lsDefaultSourceFile .=)
  getDefaultSourceFile = LoggerT (use lsDefaultSourceFile)

  recordLogMessage msg = do
    LoggerT $ tell (OpMonoid [msg])
    logSomeMessage msg


-- | This doesn't behave quite as you may think. When a 'LoggerT' is hoisted,
-- the resulting 'LoggerT' cannot output as it goes. It still collects logs to
-- be inspected when it finishes.
instance MFunctor (LoggerT e w) where
  hoist f (LoggerT (RWST k)) = LoggerT $ RWST $ \e s ->
    let e' = hoistEnv (const (return ())) e
    in f (k e' s)


-- | A function to output logs in a particular monad @m@.
data LogOutput m = LogOutput
  { _loConciseOutput :: Bool
  , _loPrintFunc     :: Text -> m ()
  }


-- | Output logs to standard output (i.e. the console).
logOutputStd
  :: MonadIO m
  => Bool
  -- ^ If 'True', print more concise output when message origin is repeated.
  -> LogOutput m
logOutputStd b = LogOutput
  { _loConciseOutput = b
  , _loPrintFunc = liftIO . Text.putStrLn
  }


-- | Output no logs.
logOutputNone
  :: Monad m
  => Bool
  -- ^ If 'True', print more concise output when message origin is repeated.
  -> LogOutput m
logOutputNone b = LogOutput
  { _loConciseOutput = b
  , _loPrintFunc = const (return ())
  }


-- | Run the logging monad transformer. Returns the action's result value and a
-- list of logs which were collected as it ran.
runLoggerT
  :: (Monad m, Describe e, Describe w)
  => FilePath
  -- ^ The initial default source file. This is only used for displaying message
  -- origins.
  -> LogOutput m
  -- ^ The logging output function. E.g. 'logOutputStd' or 'logOutputNone'.
  -> LogLevel
  -- ^ The log level for on-the-fly logging. Doesn't affect which logs are
  -- collected at the end.
  -> LoggerT e w m a
  -- ^ The logging action to run.
  -> m (a, [SomeMessage e w])
runLoggerT sourceFile output logLevel (LoggerT action) = do
  let st = LoggerState
        { _lsLogLevel = logLevel
        , _lsDefaultSourceFile = sourceFile
        , _lsPreviousOrigin = Nothing
        }

      env = LoggerEnv
        { _leLogFunc = logFuncFrom output
        }

  (x, _, logs) <- runRWST action env st

  return (x, reverse (getOpMonoid logs))


-- | Change the error and warning types in a logger computation. To change the
-- underlying monad use 'hoist'.
mapLoggerT
  :: (Functor m)
  => (e -> e') -> (w -> w')
  -> LoggerT e w m a -> LoggerT e' w' m a
mapLoggerT mapErr mapWarn (LoggerT x) = LoggerT (mapRWST mapInner x)
  where
    mapInner =
      let messages ty = _3 . _Wrapped . traverse . ty . lmMsg
      in fmap (over (messages _MsgWarn) mapWarn . over (messages _MsgError) mapErr)

--------------------------------------------------------------------------------
--  Internal
--------------------------------------------------------------------------------

logFuncFrom
  :: (Monad m)
  => LogOutput m
  -> (Bool -> LogLevel -> LogLevel -> Text -> Text -> m ())
logFuncFrom LogOutput{ _loConciseOutput, _loPrintFunc } = lf
  where
    lf repeatedOrigin maxLevel level originMsg actualMsg
      | level <= maxLevel =
        let outputMsg =
              describeBuilder level <>
              (if not _loConciseOutput || not repeatedOrigin
               then " " <> describeBuilder originMsg else "") <> ": " <>
              describeBuilder actualMsg
        in _loPrintFunc (builderToStrict outputMsg)
      | otherwise = return ()


someLogLevel :: SomeMessage e w -> LogLevel
someLogLevel (MsgError _) = LogError
someLogLevel (MsgWarn _)  = LogWarn
someLogLevel (MsgInfo _)  = LogInfo
someLogLevel (MsgDebug _) = LogDebug

someMsgText :: (Describe e, Describe w) => SomeMessage e w -> Text
someMsgText (MsgError msg) = describe (msg ^. lmMsg)
someMsgText (MsgWarn msg)  = describe (msg ^. lmMsg)
someMsgText (MsgInfo msg)  = msg ^. lmMsg
someMsgText (MsgDebug msg) = msg ^. lmMsg


logSomeMessage
  :: (Monad m, Describe e, Describe w)
  => SomeMessage e w -> LoggerT e w m ()
logSomeMessage msg = do
  let msgText = someMsgText msg
      msgLevel = someLogLevel msg
      msgOrigin = msg ^. someMessageOrigin
      originText = maybe "" describe msgOrigin

  prevOrigin <- LoggerT $ use lsPreviousOrigin
  LoggerT $ lsPreviousOrigin .= msg ^. someMessageOrigin

  let repeatedOrigin = msgOrigin == prevOrigin

  logFunc <- LoggerT $ view leLogFunc
  logLevel <- LoggerT $ use lsLogLevel

  lift $ logFunc repeatedOrigin logLevel msgLevel originText msgText