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

{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | 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 Ide.Logger
  ( Priority(..)
  , Logger(..)
  , Recorder(..)
  , logError, logWarning, logInfo, logDebug
  , noLogging
  , WithPriority(..)
  , logWith
  , cmap
  , cmapIO
  , cfilter
  , withFileRecorder
  , makeDefaultStderrRecorder
  , makeDefaultHandleRecorder
  , LoggingColumn(..)
  , cmapWithPrio
  , withBacklog
  , lspClientMessageRecorder
  , lspClientLogRecorder
  , module PrettyPrinterModule
  , renderStrict
  , toCologActionWithPrio
  ) where

import           Colog.Core                    (LogAction (..), Severity,
                                                WithSeverity (..))
import qualified Colog.Core                    as Colog
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.Protocol.Message (SMethod (SMethod_WindowLogMessage, SMethod_WindowShowMessage))
import           Language.LSP.Protocol.Types   (LogMessageParams (..),
                                                MessageType (..),
                                                ShowMessageParams (..))
import           Language.LSP.Server
import qualified Language.LSP.Server           as LSP
import           Prettyprinter                 as PrettyPrinterModule
import           Prettyprinter.Render.Text     (renderStrict)
import           System.IO                     (Handle, IOMode (AppendMode),
                                                hClose, hFlush, openFile,
                                                stderr)
import           UnliftIO                      (MonadUnliftIO, 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, ReadPrec [Priority]
ReadPrec Priority
Int -> ReadS Priority
ReadS [Priority]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Priority]
$creadListPrec :: ReadPrec [Priority]
readPrec :: ReadPrec Priority
$creadPrec :: ReadPrec Priority
readList :: ReadS [Priority]
$creadList :: ReadS [Priority]
readsPrec :: Int -> ReadS Priority
$creadsPrec :: Int -> ReadS Priority
Read, 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

withFileRecorder
  :: MonadUnliftIO m
  => FilePath
  -- ^ Log file path.
  -> Maybe [LoggingColumn]
  -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`
  -> (Either IOException (Recorder (WithPriority (Doc d))) -> m a)
  -- ^ action given a recorder, or the exception if we failed to open the file
  -> m a
withFileRecorder :: forall (m :: * -> *) d a.
MonadUnliftIO m =>
String
-> Maybe [LoggingColumn]
-> (Either IOException (Recorder (WithPriority (Doc d))) -> m a)
-> m a
withFileRecorder String
path Maybe [LoggingColumn]
columns Either IOException (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
  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 -> Either IOException (Recorder (WithPriority (Doc d))) -> m a
action forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left IOException
e
    Right Handle
fileHandle -> forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally ((forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Handle -> m (Recorder (WithPriority (Doc a)))
makeHandleRecorder Handle
fileHandle) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either IOException (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 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SMethod 'Method_WindowShowMessage
SMethod_WindowShowMessage
      ShowMessageParams
        { $sel:_type_:ShowMessageParams :: MessageType
_type_ = 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 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SMethod 'Method_WindowLogMessage
SMethod_WindowLogMessage
      LogMessageParams
        { $sel:_type_:LogMessageParams :: MessageType
_type_ = Priority -> MessageType
priorityToLsp Priority
priority,
          $sel:_message:LogMessageParams :: Text
_message = Text
payload
        }

priorityToLsp :: Priority -> MessageType
priorityToLsp :: Priority -> MessageType
priorityToLsp =
  \case
    Priority
Debug   -> MessageType
MessageType_Log
    Priority
Info    -> MessageType
MessageType_Info
    Priority
Warning -> MessageType
MessageType_Warning
    Priority
Error   -> MessageType
MessageType_Error

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