-- 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
  , makeDefaultHandleRecorder
  , 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                         (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,
                                                        openFile, stderr)
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 }

makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder :: forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder Maybe [LoggingColumn]
columns = do
  Lock
lock <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Lock
newLock
  forall (m :: * -> *) a.
MonadIO m =>
Maybe [LoggingColumn]
-> Lock -> Handle -> m (Recorder (WithPriority (Doc a)))
makeDefaultHandleRecorder Maybe [LoggingColumn]
columns Lock
lock Handle
stderr

-- | If no path given then use stderr, otherwise use file.
withDefaultRecorder
  :: MonadUnliftIO m
  => Maybe FilePath
  -- ^ Log file path. `Nothing` uses stderr
  -> Maybe [LoggingColumn]
  -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`
  -> (Recorder (WithPriority (Doc d)) -> m a)
  -- ^ action given a recorder
  -> m a
withDefaultRecorder :: forall (m :: * -> *) d a.
MonadUnliftIO m =>
Maybe String
-> Maybe [LoggingColumn]
-> (Recorder (WithPriority (Doc d)) -> m a)
-> m a
withDefaultRecorder Maybe String
path Maybe [LoggingColumn]
columns 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]
-> Lock -> Handle -> m (Recorder (WithPriority (Doc a)))
makeDefaultHandleRecorder Maybe [LoggingColumn]
columns 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
  -> 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]
-> Lock -> Handle -> m (Recorder (WithPriority (Doc a)))
makeDefaultHandleRecorder Maybe [LoggingColumn]
columns 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
  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)

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