-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE CPP        #-}
{-# LANGUAGE RankNTypes #-}
-- | This is a compatibility module that abstracts over the
-- concrete choice of logging framework so users can plug in whatever
-- framework they want to.
module Development.IDE.Types.Logger
  ( Priority(..)
  , Logger(..)
  , Recorder(..)
  , logError, logWarning, logInfo, logDebug
  , noLogging
  , WithPriority(..)
  , logWith
  , cmap
  , cmapIO
  , cfilter
  , withDefaultRecorder
  , makeDefaultStderrRecorder
  , priorityToHsLoggerPriority
  , LoggingColumn(..)
  , cmapWithPrio
  , withBacklog
  , lspClientMessageRecorder
  , lspClientLogRecorder
  , module PrettyPrinterModule
  , renderStrict
  , toCologActionWithPrio
  ) where

import           Control.Concurrent                    (myThreadId)
import           Control.Concurrent.Extra              (Lock, newLock, withLock)
import           Control.Concurrent.STM                (atomically,
                                                        flushTBQueue,
                                                        isFullTBQueue,
                                                        newTBQueueIO, newTVarIO,
                                                        readTVarIO,
                                                        writeTBQueue, writeTVar)
import           Control.Exception                     (IOException)
import           Control.Monad                         (forM_, unless, when,
                                                        (>=>))
import           Control.Monad.IO.Class                (MonadIO (liftIO))
import           Data.Foldable                         (for_)
import           Data.Functor.Contravariant            (Contravariant (contramap))
import           Data.Maybe                            (fromMaybe)
import           Data.Text                             (Text)
import qualified Data.Text                             as T
import qualified Data.Text                             as Text
import qualified Data.Text.IO                          as Text
import           Data.Time                             (defaultTimeLocale,
                                                        formatTime,
                                                        getCurrentTime)
import           GHC.Stack                             (CallStack, HasCallStack,
                                                        SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),
                                                        callStack, getCallStack,
                                                        withFrozenCallStack)
import           Language.LSP.Server
import qualified Language.LSP.Server                   as LSP
import           Language.LSP.Types                    (LogMessageParams (..),
                                                        MessageType (..),
                                                        SMethod (SWindowLogMessage, SWindowShowMessage),
                                                        ShowMessageParams (..))
#if MIN_VERSION_prettyprinter(1,7,0)
import           Prettyprinter                         as PrettyPrinterModule
import           Prettyprinter.Render.Text             (renderStrict)
#else
import           Data.Text.Prettyprint.Doc             as PrettyPrinterModule
import           Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
#endif
import           Colog.Core                            (LogAction (..),
                                                        Severity,
                                                        WithSeverity (..))
import qualified Colog.Core                            as Colog
import           System.IO                             (Handle,
                                                        IOMode (AppendMode),
                                                        hClose, hFlush,
                                                        hSetEncoding, openFile,
                                                        stderr, utf8)
import qualified System.Log.Formatter                  as HSL
import qualified System.Log.Handler                    as HSL
import qualified System.Log.Handler.Simple             as HSL
import qualified System.Log.Logger                     as HsLogger
import           UnliftIO                              (MonadUnliftIO,
                                                        displayException,
                                                        finally, try)

data Priority
-- Don't change the ordering of this type or you will mess up the Ord
-- instance
    = Debug -- ^ Verbose debug logging.
    | Info  -- ^ Useful information in case an error has to be understood.
    | Warning
      -- ^ These error messages should not occur in a expected usage, and
      -- should be investigated.
    | Error -- ^ Such log messages must never occur in expected usage.
    deriving (Priority -> Priority -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Priority -> Priority -> Bool
$c/= :: Priority -> Priority -> Bool
== :: Priority -> Priority -> Bool
$c== :: Priority -> Priority -> Bool
Eq, Int -> Priority -> ShowS
[Priority] -> ShowS
Priority -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Priority] -> ShowS
$cshowList :: [Priority] -> ShowS
show :: Priority -> String
$cshow :: Priority -> String
showsPrec :: Int -> Priority -> ShowS
$cshowsPrec :: Int -> Priority -> ShowS
Show, Eq Priority
Priority -> Priority -> Bool
Priority -> Priority -> Ordering
Priority -> Priority -> Priority
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Priority -> Priority -> Priority
$cmin :: Priority -> Priority -> Priority
max :: Priority -> Priority -> Priority
$cmax :: Priority -> Priority -> Priority
>= :: Priority -> Priority -> Bool
$c>= :: Priority -> Priority -> Bool
> :: Priority -> Priority -> Bool
$c> :: Priority -> Priority -> Bool
<= :: Priority -> Priority -> Bool
$c<= :: Priority -> Priority -> Bool
< :: Priority -> Priority -> Bool
$c< :: Priority -> Priority -> Bool
compare :: Priority -> Priority -> Ordering
$ccompare :: Priority -> Priority -> Ordering
Ord, Int -> Priority
Priority -> Int
Priority -> [Priority]
Priority -> Priority
Priority -> Priority -> [Priority]
Priority -> Priority -> Priority -> [Priority]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Priority -> Priority -> Priority -> [Priority]
$cenumFromThenTo :: Priority -> Priority -> Priority -> [Priority]
enumFromTo :: Priority -> Priority -> [Priority]
$cenumFromTo :: Priority -> Priority -> [Priority]
enumFromThen :: Priority -> Priority -> [Priority]
$cenumFromThen :: Priority -> Priority -> [Priority]
enumFrom :: Priority -> [Priority]
$cenumFrom :: Priority -> [Priority]
fromEnum :: Priority -> Int
$cfromEnum :: Priority -> Int
toEnum :: Int -> Priority
$ctoEnum :: Int -> Priority
pred :: Priority -> Priority
$cpred :: Priority -> Priority
succ :: Priority -> Priority
$csucc :: Priority -> Priority
Enum, Priority
forall a. a -> a -> Bounded a
maxBound :: Priority
$cmaxBound :: Priority
minBound :: Priority
$cminBound :: Priority
Bounded)

-- | Note that this is logging actions _of the program_, not of the user.
--   You shouldn't call warning/error if the user has caused an error, only
--   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).
newtype Logger = Logger {Logger -> Priority -> Text -> IO ()
logPriority :: Priority -> T.Text -> IO ()}

instance Semigroup Logger where
    Logger
l1 <> :: Logger -> Logger -> Logger
<> Logger
l2 = (Priority -> Text -> IO ()) -> Logger
Logger forall a b. (a -> b) -> a -> b
$ \Priority
p Text
t -> Logger -> Priority -> Text -> IO ()
logPriority Logger
l1 Priority
p Text
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Logger -> Priority -> Text -> IO ()
logPriority Logger
l2 Priority
p Text
t

instance Monoid Logger where
    mempty :: Logger
mempty = (Priority -> Text -> IO ()) -> Logger
Logger forall a b. (a -> b) -> a -> b
$ \Priority
_ Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

logError :: Logger -> T.Text -> IO ()
logError :: Logger -> Text -> IO ()
logError Logger
x = Logger -> Priority -> Text -> IO ()
logPriority Logger
x Priority
Error

logWarning :: Logger -> T.Text -> IO ()
logWarning :: Logger -> Text -> IO ()
logWarning Logger
x = Logger -> Priority -> Text -> IO ()
logPriority Logger
x Priority
Warning

logInfo :: Logger -> T.Text -> IO ()
logInfo :: Logger -> Text -> IO ()
logInfo Logger
x = Logger -> Priority -> Text -> IO ()
logPriority Logger
x Priority
Info

logDebug :: Logger -> T.Text -> IO ()
logDebug :: Logger -> Text -> IO ()
logDebug Logger
x = Logger -> Priority -> Text -> IO ()
logPriority Logger
x Priority
Debug

noLogging :: Logger
noLogging :: Logger
noLogging = (Priority -> Text -> IO ()) -> Logger
Logger forall a b. (a -> b) -> a -> b
$ \Priority
_ Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

data WithPriority a = WithPriority { forall a. WithPriority a -> Priority
priority :: Priority, forall a. WithPriority a -> CallStack
callStack_ :: CallStack, forall a. WithPriority a -> a
payload :: a } deriving forall a b. a -> WithPriority b -> WithPriority a
forall a b. (a -> b) -> WithPriority a -> WithPriority b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> WithPriority b -> WithPriority a
$c<$ :: forall a b. a -> WithPriority b -> WithPriority a
fmap :: forall a b. (a -> b) -> WithPriority a -> WithPriority b
$cfmap :: forall a b. (a -> b) -> WithPriority a -> WithPriority b
Functor

-- | Note that this is logging actions _of the program_, not of the user.
--   You shouldn't call warning/error if the user has caused an error, only
--   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).
newtype Recorder msg = Recorder
  { forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ :: forall m. (MonadIO m) => msg -> m () }

logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith :: forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority msg)
recorder Priority
priority msg
msg = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ Recorder (WithPriority msg)
recorder (forall a. Priority -> CallStack -> a -> WithPriority a
WithPriority Priority
priority HasCallStack => CallStack
callStack msg
msg)

instance Semigroup (Recorder msg) where
  <> :: Recorder msg -> Recorder msg -> Recorder msg
(<>) Recorder{ logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ = forall (m :: * -> *). MonadIO m => msg -> m ()
logger_1 } Recorder{ logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ = forall (m :: * -> *). MonadIO m => msg -> m ()
logger_2 } =
    Recorder
      { logger_ :: forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ = \msg
msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_1 msg
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_2 msg
msg }

instance Monoid (Recorder msg) where
  mempty :: Recorder msg
mempty =
    Recorder
      { logger_ :: forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ = \msg
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure () }

instance Contravariant Recorder where
  contramap :: forall a' a. (a' -> a) -> Recorder a -> Recorder a'
contramap a' -> a
f Recorder{ forall (m :: * -> *). MonadIO m => a -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ } =
    Recorder
      { logger_ :: forall (m :: * -> *). MonadIO m => a' -> m ()
logger_ = forall (m :: * -> *). MonadIO m => a -> m ()
logger_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f }

cmap :: (a -> b) -> Recorder b -> Recorder a
cmap :: forall a' a. (a' -> a) -> Recorder a -> Recorder a'
cmap = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap

cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio :: forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio a -> b
f = forall a' a. (a' -> a) -> Recorder a -> Recorder a'
cmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)

cmapIO :: (a -> IO b) -> Recorder b -> Recorder a
cmapIO :: forall a b. (a -> IO b) -> Recorder b -> Recorder a
cmapIO a -> IO b
f Recorder{ forall (m :: * -> *). MonadIO m => b -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => b -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ } =
  Recorder
    { logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ = (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO b
f) forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *). MonadIO m => b -> m ()
logger_ }

cfilter :: (a -> Bool) -> Recorder a -> Recorder a
cfilter :: forall a. (a -> Bool) -> Recorder a -> Recorder a
cfilter a -> Bool
p Recorder{ forall (m :: * -> *). MonadIO m => a -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ } =
  Recorder
    { logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ = \a
msg -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a -> Bool
p a
msg) (forall (m :: * -> *). MonadIO m => a -> m ()
logger_ a
msg) }

textHandleRecorder :: Handle -> Recorder Text
textHandleRecorder :: Handle -> Recorder Text
textHandleRecorder Handle
handle =
  Recorder
    { logger_ :: forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ = \Text
text -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
Text.hPutStrLn Handle
handle Text
text forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Handle -> IO ()
hFlush Handle
handle }

-- | Priority is actually for hslogger compatibility
makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> Priority -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder :: forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn]
-> Priority -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder Maybe [LoggingColumn]
columns Priority
minPriority = do
  Lock
lock <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Lock
newLock
  forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn]
-> Priority
-> Lock
-> Handle
-> m (Recorder (WithPriority (Doc a)))
makeDefaultHandleRecorder Maybe [LoggingColumn]
columns Priority
minPriority Lock
lock Handle
stderr

-- | If no path given then use stderr, otherwise use file.
-- Kinda complicated because we also need to setup `hslogger` for
-- `hie-bios` log compatibility reasons. If `hie-bios` can be set to use our
-- logger instead or if `hie-bios` doesn't use `hslogger` then `hslogger` can
-- be removed completely. See `setupHsLogger` comment.
withDefaultRecorder
  :: MonadUnliftIO m
  => Maybe FilePath
  -- ^ Log file path. `Nothing` uses stderr
  -> Maybe [LoggingColumn]
  -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`
  -> Priority
  -- ^ min priority for hslogger compatibility
  -> (Recorder (WithPriority (Doc d)) -> m a)
  -- ^ action given a recorder
  -> m a
withDefaultRecorder :: forall (m :: * -> *) d a.
MonadUnliftIO m =>
Maybe String
-> Maybe [LoggingColumn]
-> Priority
-> (Recorder (WithPriority (Doc d)) -> m a)
-> m a
withDefaultRecorder Maybe String
path Maybe [LoggingColumn]
columns Priority
minPriority Recorder (WithPriority (Doc d)) -> m a
action = do
  Lock
lock <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Lock
newLock
  let makeHandleRecorder :: Handle -> m (Recorder (WithPriority (Doc a)))
makeHandleRecorder = forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn]
-> Priority
-> Lock
-> Handle
-> m (Recorder (WithPriority (Doc a)))
makeDefaultHandleRecorder Maybe [LoggingColumn]
columns Priority
minPriority Lock
lock
  case Maybe String
path of
    Maybe String
Nothing -> do
      Recorder (WithPriority (Doc d))
recorder <- forall {a}. Handle -> m (Recorder (WithPriority (Doc a)))
makeHandleRecorder Handle
stderr
      let message :: Doc d
message = Doc d
"No log file specified; using stderr."
      forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority (Doc d))
recorder Priority
Info Doc d
message
      Recorder (WithPriority (Doc d)) -> m a
action Recorder (WithPriority (Doc d))
recorder
    Just String
path -> do
      Either IOException Handle
fileHandle :: Either IOException Handle <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (String -> IOMode -> IO Handle
openFile String
path IOMode
AppendMode)
      case Either IOException Handle
fileHandle of
        Left IOException
e -> do
          Recorder (WithPriority (Doc d))
recorder <- forall {a}. Handle -> m (Recorder (WithPriority (Doc a)))
makeHandleRecorder Handle
stderr
          let exceptionMessage :: Doc ann
exceptionMessage = forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException IOException
e
          let message :: Doc ann
message = forall ann. [Doc ann] -> Doc ann
vcat [forall {ann}. Doc ann
exceptionMessage, Doc ann
"Couldn't open log file" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty String
path forall a. Semigroup a => a -> a -> a
<> Doc ann
"; falling back to stderr."]
          forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority (Doc d))
recorder Priority
Warning forall {ann}. Doc ann
message
          Recorder (WithPriority (Doc d)) -> m a
action Recorder (WithPriority (Doc d))
recorder
        Right Handle
fileHandle -> forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (forall {a}. Handle -> m (Recorder (WithPriority (Doc a)))
makeHandleRecorder Handle
fileHandle forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Recorder (WithPriority (Doc d)) -> m a
action) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
fileHandle)

makeDefaultHandleRecorder
  :: MonadIO m
  => Maybe [LoggingColumn]
  -- ^ built-in logging columns to display. Nothing uses the default
  -> Priority
  -- ^ min priority for hslogger compatibility
  -> Lock
  -- ^ lock to take when outputting to handle
  -> Handle
  -- ^ handle to output to
  -> m (Recorder (WithPriority (Doc a)))
makeDefaultHandleRecorder :: forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn]
-> Priority
-> Lock
-> Handle
-> m (Recorder (WithPriority (Doc a)))
makeDefaultHandleRecorder Maybe [LoggingColumn]
columns Priority
minPriority Lock
lock Handle
handle = do
  let Recorder{ forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ } = Handle -> Recorder Text
textHandleRecorder Handle
handle
  let threadSafeRecorder :: Recorder Text
threadSafeRecorder = Recorder { logger_ :: forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ = \Text
msg -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Lock -> IO a -> IO a
withLock Lock
lock (forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ Text
msg) }
  let loggingColumns :: [LoggingColumn]
loggingColumns = forall a. a -> Maybe a -> a
fromMaybe [LoggingColumn]
defaultLoggingColumns Maybe [LoggingColumn]
columns
  let textWithPriorityRecorder :: Recorder (WithPriority Text)
textWithPriorityRecorder = forall a b. (a -> IO b) -> Recorder b -> Recorder a
cmapIO ([LoggingColumn] -> WithPriority Text -> IO Text
textWithPriorityToText [LoggingColumn]
loggingColumns) Recorder Text
threadSafeRecorder
  -- see `setupHsLogger` comment
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Lock -> Handle -> [String] -> Priority -> IO ()
setupHsLogger Lock
lock Handle
handle [String
"hls", String
"hie-bios"] (Priority -> Priority
priorityToHsLoggerPriority Priority
minPriority)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a' a. (a' -> a) -> Recorder a -> Recorder a'
cmap forall {ann}. WithPriority (Doc ann) -> WithPriority Text
docToText Recorder (WithPriority Text)
textWithPriorityRecorder)
  where
    docToText :: WithPriority (Doc ann) -> WithPriority Text
docToText = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall ann. SimpleDocStream ann -> Text
renderStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions)

priorityToHsLoggerPriority :: Priority -> HsLogger.Priority
priorityToHsLoggerPriority :: Priority -> Priority
priorityToHsLoggerPriority = \case
  Priority
Debug   -> Priority
HsLogger.DEBUG
  Priority
Info    -> Priority
HsLogger.INFO
  Priority
Warning -> Priority
HsLogger.WARNING
  Priority
Error   -> Priority
HsLogger.ERROR

-- | The purpose of setting up `hslogger` at all is that `hie-bios` uses
-- `hslogger` to output compilation logs. The easiest way to merge these logs
-- with our log output is to setup an `hslogger` that uses the same handle
-- and same lock as our loggers. That way the output from our loggers and
-- `hie-bios` don't interleave strangely.
-- It may be possible to have `hie-bios` use our logger by decorating the
-- `Cradle.cradleOptsProg.runCradle` we get in the Cradle from
-- `HieBios.findCradle`, but I remember trying that and something not good
-- happened. I'd have to try it again to remember if that was a real issue.
-- Once that is figured out or `hie-bios` doesn't use `hslogger`, then all
-- references to `hslogger` can be removed entirely.
setupHsLogger :: Lock -> Handle -> [String] -> HsLogger.Priority -> IO ()
setupHsLogger :: Lock -> Handle -> [String] -> Priority -> IO ()
setupHsLogger Lock
lock Handle
handle [String]
extraLogNames Priority
level = do
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle TextEncoding
utf8

  GenericHandler Handle
logH <- Handle -> Priority -> IO (GenericHandler Handle)
HSL.streamHandler Handle
handle Priority
level

  let logHandle :: GenericHandler Handle
logHandle  = GenericHandler Handle
logH
        { writeFunc :: Handle -> String -> IO ()
HSL.writeFunc = \Handle
a String
s -> forall a. Lock -> IO a -> IO a
withLock Lock
lock forall a b. (a -> b) -> a -> b
$ forall a. GenericHandler a -> a -> String -> IO ()
HSL.writeFunc GenericHandler Handle
logH Handle
a String
s }
      logFormatter :: LogFormatter a
logFormatter  = forall a. String -> String -> LogFormatter a
HSL.tfLogFormatter String
logDateFormat String
logFormat
      logHandler :: GenericHandler Handle
logHandler = forall a. LogHandler a => a -> LogFormatter a -> a
HSL.setFormatter GenericHandler Handle
logHandle forall {a}. LogFormatter a
logFormatter

  String -> (Logger -> Logger) -> IO ()
HsLogger.updateGlobalLogger String
HsLogger.rootLoggerName forall a b. (a -> b) -> a -> b
$ forall a. LogHandler a => [a] -> Logger -> Logger
HsLogger.setHandlers ([] :: [HSL.GenericHandler Handle])
  String -> (Logger -> Logger) -> IO ()
HsLogger.updateGlobalLogger String
"haskell-lsp" forall a b. (a -> b) -> a -> b
$ forall a. LogHandler a => [a] -> Logger -> Logger
HsLogger.setHandlers [GenericHandler Handle
logHandler]
  String -> (Logger -> Logger) -> IO ()
HsLogger.updateGlobalLogger String
"haskell-lsp" forall a b. (a -> b) -> a -> b
$ Priority -> Logger -> Logger
HsLogger.setLevel Priority
level

  -- Also route the additional log names to the same log
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
extraLogNames forall a b. (a -> b) -> a -> b
$ \String
logName -> do
    String -> (Logger -> Logger) -> IO ()
HsLogger.updateGlobalLogger String
logName forall a b. (a -> b) -> a -> b
$ forall a. LogHandler a => [a] -> Logger -> Logger
HsLogger.setHandlers [GenericHandler Handle
logHandler]
    String -> (Logger -> Logger) -> IO ()
HsLogger.updateGlobalLogger String
logName forall a b. (a -> b) -> a -> b
$ Priority -> Logger -> Logger
HsLogger.setLevel Priority
level
  where
    logFormat :: String
logFormat = String
"$time [$tid] $prio $loggername:\t$msg"
    logDateFormat :: String
logDateFormat = String
"%Y-%m-%d %H:%M:%S%Q"

data LoggingColumn
  = TimeColumn
  | ThreadIdColumn
  | PriorityColumn
  | DataColumn
  | SourceLocColumn

defaultLoggingColumns :: [LoggingColumn]
defaultLoggingColumns :: [LoggingColumn]
defaultLoggingColumns = [LoggingColumn
TimeColumn, LoggingColumn
PriorityColumn, LoggingColumn
DataColumn]

textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text
textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text
textWithPriorityToText [LoggingColumn]
columns WithPriority{ Priority
priority :: Priority
priority :: forall a. WithPriority a -> Priority
priority, CallStack
callStack_ :: CallStack
callStack_ :: forall a. WithPriority a -> CallStack
callStack_, Text
payload :: Text
payload :: forall a. WithPriority a -> a
payload } = do
    [Text]
textColumns <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LoggingColumn -> IO Text
loggingColumnToText [LoggingColumn]
columns
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
" | " [Text]
textColumns
    where
      showAsText :: Show a => a -> Text
      showAsText :: forall a. Show a => a -> Text
showAsText = String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

      utcTimeToText :: t -> Text
utcTimeToText t
utcTime = String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%6QZ" t
utcTime

      priorityToText :: Priority -> Text
      priorityToText :: Priority -> Text
priorityToText = forall a. Show a => a -> Text
showAsText

      threadIdToText :: ThreadId -> Text
threadIdToText = forall a. Show a => a -> Text
showAsText

      callStackToSrcLoc :: CallStack -> Maybe SrcLoc
      callStackToSrcLoc :: CallStack -> Maybe SrcLoc
callStackToSrcLoc CallStack
callStack =
        case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
callStack of
          (String
_, SrcLoc
srcLoc) : [(String, SrcLoc)]
_ -> forall a. a -> Maybe a
Just SrcLoc
srcLoc
          [(String, SrcLoc)]
_               -> forall a. Maybe a
Nothing

      srcLocToText :: Maybe SrcLoc -> Text
srcLocToText = \case
          Maybe SrcLoc
Nothing -> Text
"<unknown>"
          Just SrcLoc{ String
srcLocModule :: String
srcLocModule :: SrcLoc -> String
srcLocModule, Int
srcLocStartLine :: Int
srcLocStartLine :: SrcLoc -> Int
srcLocStartLine, Int
srcLocStartCol :: Int
srcLocStartCol :: SrcLoc -> Int
srcLocStartCol } ->
            String -> Text
Text.pack String
srcLocModule forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showAsText Int
srcLocStartLine forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showAsText Int
srcLocStartCol

      loggingColumnToText :: LoggingColumn -> IO Text
      loggingColumnToText :: LoggingColumn -> IO Text
loggingColumnToText = \case
        LoggingColumn
TimeColumn -> do
          UTCTime
utcTime <- IO UTCTime
getCurrentTime
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {t}. FormatTime t => t -> Text
utcTimeToText UTCTime
utcTime)
        LoggingColumn
SourceLocColumn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Maybe SrcLoc -> Text
srcLocToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> Maybe SrcLoc
callStackToSrcLoc) CallStack
callStack_
        LoggingColumn
ThreadIdColumn -> do
          ThreadId
threadId <- IO ThreadId
myThreadId
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreadId -> Text
threadIdToText ThreadId
threadId)
        LoggingColumn
PriorityColumn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Priority -> Text
priorityToText Priority
priority)
        LoggingColumn
DataColumn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
payload

-- | Given a 'Recorder' that requires an argument, produces a 'Recorder'
-- that queues up messages until the argument is provided using the callback, at which
-- point it sends the backlog and begins functioning normally.
withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ())
withBacklog :: forall v a. (v -> Recorder a) -> IO (Recorder a, v -> IO ())
withBacklog v -> Recorder a
recFun = do
  -- Arbitrary backlog capacity
  TBQueue a
backlog <- forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
100
  let backlogRecorder :: Recorder a
backlogRecorder = forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder forall a b. (a -> b) -> a -> b
$ \a
it -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
          -- If the queue is full just drop the message on the floor. This is most likely
          -- to happen if the callback is just never going to be called; in which case
          -- we want neither to build up an unbounded backlog in memory, nor block waiting
          -- for space!
          Bool
full <- forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue a
backlog
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
full forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue a
backlog a
it

  -- The variable holding the recorder starts out holding the recorder that writes
  -- to the backlog.
  TVar (Recorder a)
recVar <- forall a. a -> IO (TVar a)
newTVarIO Recorder a
backlogRecorder
  -- The callback atomically swaps out the recorder for the final one, and flushes
  -- the backlog to it.
  let cb :: v -> IO ()
cb v
arg = do
        let recorder :: Recorder a
recorder = v -> Recorder a
recFun v
arg
        [a]
toRecord <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar (Recorder a)
recVar Recorder a
recorder forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TBQueue a -> STM [a]
flushTBQueue TBQueue a
backlog
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [a]
toRecord (forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ Recorder a
recorder)

  -- The recorder we actually return looks in the variable and uses whatever is there.
  let varRecorder :: Recorder a
varRecorder = forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder forall a b. (a -> b) -> a -> b
$ \a
it -> do
          Recorder a
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar (Recorder a)
recVar
          forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ Recorder a
r a
it

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Recorder a
varRecorder, v -> IO ()
cb)

-- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.
lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)
lspClientMessageRecorder :: forall config.
LanguageContextEnv config -> Recorder (WithPriority Text)
lspClientMessageRecorder LanguageContextEnv config
env = forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder forall a b. (a -> b) -> a -> b
$ \WithPriority {CallStack
Text
Priority
payload :: Text
callStack_ :: CallStack
priority :: Priority
payload :: forall a. WithPriority a -> a
callStack_ :: forall a. WithPriority a -> CallStack
priority :: forall a. WithPriority a -> Priority
..} ->
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv config
env forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SMethod 'WindowShowMessage
SWindowShowMessage
      ShowMessageParams
        { $sel:_xtype:ShowMessageParams :: MessageType
_xtype = Priority -> MessageType
priorityToLsp Priority
priority,
          $sel:_message:ShowMessageParams :: Text
_message = Text
payload
        }

-- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications.
lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)
lspClientLogRecorder :: forall config.
LanguageContextEnv config -> Recorder (WithPriority Text)
lspClientLogRecorder LanguageContextEnv config
env = forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder forall a b. (a -> b) -> a -> b
$ \WithPriority {CallStack
Text
Priority
payload :: Text
callStack_ :: CallStack
priority :: Priority
payload :: forall a. WithPriority a -> a
callStack_ :: forall a. WithPriority a -> CallStack
priority :: forall a. WithPriority a -> Priority
..} ->
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv config
env forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SMethod 'WindowLogMessage
SWindowLogMessage
      LogMessageParams
        { $sel:_xtype:LogMessageParams :: MessageType
_xtype = Priority -> MessageType
priorityToLsp Priority
priority,
          $sel:_message:LogMessageParams :: Text
_message = Text
payload
        }

priorityToLsp :: Priority -> MessageType
priorityToLsp :: Priority -> MessageType
priorityToLsp =
  \case
    Priority
Debug   -> MessageType
MtLog
    Priority
Info    -> MessageType
MtInfo
    Priority
Warning -> MessageType
MtWarning
    Priority
Error   -> MessageType
MtError

toCologActionWithPrio :: (MonadIO m, HasCallStack) => Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)
toCologActionWithPrio :: forall (m :: * -> *) msg.
(MonadIO m, HasCallStack) =>
Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)
toCologActionWithPrio (Recorder forall (m :: * -> *). MonadIO m => WithPriority msg -> m ()
_logger) = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ \WithSeverity{msg
Severity
getMsg :: forall msg. WithSeverity msg -> msg
getSeverity :: forall msg. WithSeverity msg -> Severity
getSeverity :: Severity
getMsg :: msg
..} -> do
    let priority :: Priority
priority = Severity -> Priority
severityToPriority Severity
getSeverity
    forall (m :: * -> *). MonadIO m => WithPriority msg -> m ()
_logger forall a b. (a -> b) -> a -> b
$ forall a. Priority -> CallStack -> a -> WithPriority a
WithPriority Priority
priority HasCallStack => CallStack
callStack msg
getMsg
  where
    severityToPriority :: Severity -> Priority
    severityToPriority :: Severity -> Priority
severityToPriority Severity
Colog.Debug   = Priority
Debug
    severityToPriority Severity
Colog.Info    = Priority
Info
    severityToPriority Severity
Colog.Warning = Priority
Warning
    severityToPriority Severity
Colog.Error   = Priority
Error