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

{-# 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
  ) where

import           Control.Concurrent            (myThreadId)
import           Control.Concurrent.Extra      (Lock, newLock, withLock)
import           Control.Concurrent.STM        (atomically,
                                                newTVarIO, writeTVar, readTVarIO, newTBQueueIO, flushTBQueue, writeTBQueue, isFullTBQueue)
import           Control.Exception             (IOException)
import           Control.Monad                 (forM_, when, (>=>), unless)
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 (..))
import           Prettyprinter                 as PrettyPrinterModule
import           Prettyprinter.Render.Text     (renderStrict)
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
(Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool) -> Eq Priority
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
(Int -> Priority -> ShowS)
-> (Priority -> String) -> ([Priority] -> ShowS) -> Show Priority
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
Eq Priority
-> (Priority -> Priority -> Ordering)
-> (Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool)
-> (Priority -> Priority -> Priority)
-> (Priority -> Priority -> Priority)
-> Ord 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
$cp1Ord :: Eq Priority
Ord, Int -> Priority
Priority -> Int
Priority -> [Priority]
Priority -> Priority
Priority -> Priority -> [Priority]
Priority -> Priority -> Priority -> [Priority]
(Priority -> Priority)
-> (Priority -> Priority)
-> (Int -> Priority)
-> (Priority -> Int)
-> (Priority -> [Priority])
-> (Priority -> Priority -> [Priority])
-> (Priority -> Priority -> [Priority])
-> (Priority -> Priority -> Priority -> [Priority])
-> Enum 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
Priority -> Priority -> Bounded 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 ((Priority -> Text -> IO ()) -> Logger)
-> (Priority -> Text -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Priority
p Text
t -> Logger -> Priority -> Text -> IO ()
logPriority Logger
l1 Priority
p Text
t IO () -> IO () -> IO ()
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 ((Priority -> Text -> IO ()) -> Logger)
-> (Priority -> Text -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Priority
_ Text
_ -> () -> IO ()
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 ((Priority -> Text -> IO ()) -> Logger)
-> (Priority -> Text -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Priority
_ Text
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

data WithPriority a = WithPriority { WithPriority a -> Priority
priority :: Priority, WithPriority a -> CallStack
callStack_ :: CallStack, WithPriority a -> a
payload :: a } deriving a -> WithPriority b -> WithPriority a
(a -> b) -> WithPriority a -> WithPriority b
(forall a b. (a -> b) -> WithPriority a -> WithPriority b)
-> (forall a b. a -> WithPriority b -> WithPriority a)
-> Functor WithPriority
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
<$ :: a -> WithPriority b -> WithPriority a
$c<$ :: forall a b. a -> WithPriority b -> WithPriority a
fmap :: (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
  { 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 :: Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority msg)
recorder Priority
priority msg
msg = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority msg) -> WithPriority msg -> m ()
forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ Recorder (WithPriority msg)
recorder (Priority -> CallStack -> msg -> WithPriority msg
forall a. Priority -> CallStack -> a -> WithPriority a
WithPriority Priority
priority CallStack
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 :: forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder
      { logger_ :: forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ = \msg
msg -> msg -> m ()
forall (m :: * -> *). MonadIO m => msg -> m ()
logger_1 msg
msg m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> msg -> m ()
forall (m :: * -> *). MonadIO m => msg -> m ()
logger_2 msg
msg }

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

instance Contravariant Recorder where
  contramap :: (a -> b) -> Recorder b -> Recorder a
contramap a -> 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 :: forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder
      { logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ = b -> m ()
forall (m :: * -> *). MonadIO m => b -> m ()
logger_ (b -> m ()) -> (a -> b) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f }

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

cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio a -> b
f = (WithPriority a -> WithPriority b)
-> Recorder (WithPriority b) -> Recorder (WithPriority a)
forall a b. (a -> b) -> Recorder b -> Recorder a
cmap ((a -> b) -> WithPriority a -> WithPriority b
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 :: (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 :: forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder
    { logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ = (IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> (a -> IO b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO b
f) (a -> m b) -> (b -> m ()) -> a -> m ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> b -> m ()
forall (m :: * -> *). MonadIO m => b -> m ()
logger_ }

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

textHandleRecorder :: Handle -> Recorder Text
textHandleRecorder :: Handle -> Recorder Text
textHandleRecorder Handle
handle =
  Recorder :: forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder
    { logger_ :: forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ = \Text
text -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
Text.hPutStrLn Handle
handle Text
text IO () -> IO () -> IO ()
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 :: Maybe [LoggingColumn]
-> Priority -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder Maybe [LoggingColumn]
columns Priority
minPriority = do
  Lock
lock <- IO Lock -> m Lock
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Lock
newLock
  Maybe [LoggingColumn]
-> Priority
-> Lock
-> Handle
-> m (Recorder (WithPriority (Doc a)))
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 :: 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 <- IO Lock -> m Lock
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Lock
newLock
  let makeHandleRecorder :: Handle -> m (Recorder (WithPriority (Doc a)))
makeHandleRecorder = Maybe [LoggingColumn]
-> Priority
-> Lock
-> Handle
-> m (Recorder (WithPriority (Doc a)))
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 <- Handle -> m (Recorder (WithPriority (Doc d)))
forall a. Handle -> m (Recorder (WithPriority (Doc a)))
makeHandleRecorder Handle
stderr
      let message :: Doc d
message = Doc d
"No log file specified; using stderr."
      Recorder (WithPriority (Doc d)) -> Priority -> Doc d -> m ()
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 <- IO (Either IOException Handle) -> m (Either IOException Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException Handle) -> m (Either IOException Handle))
-> IO (Either IOException Handle) -> m (Either IOException Handle)
forall a b. (a -> b) -> a -> b
$ IO Handle -> IO (Either IOException Handle)
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 <- Handle -> m (Recorder (WithPriority (Doc d)))
forall a. Handle -> m (Recorder (WithPriority (Doc a)))
makeHandleRecorder Handle
stderr
          let exceptionMessage :: Doc ann
exceptionMessage = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall e. Exception e => e -> String
displayException IOException
e
          let message :: Doc ann
message = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann
forall ann. Doc ann
exceptionMessage, Doc ann
"Couldn't open log file" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
path Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"; falling back to stderr."]
          Recorder (WithPriority (Doc d)) -> Priority -> Doc d -> m ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority (Doc d))
recorder Priority
Warning Doc d
forall ann. Doc ann
message
          Recorder (WithPriority (Doc d)) -> m a
action Recorder (WithPriority (Doc d))
recorder
        Right Handle
fileHandle -> m a -> m () -> m a
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (Handle -> m (Recorder (WithPriority (Doc d)))
forall a. Handle -> m (Recorder (WithPriority (Doc a)))
makeHandleRecorder Handle
fileHandle m (Recorder (WithPriority (Doc d)))
-> (Recorder (WithPriority (Doc d)) -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Recorder (WithPriority (Doc d)) -> m a
action) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 :: 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 :: forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder { logger_ :: forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ = \Text
msg -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
lock (Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ Text
msg) }
  let loggingColumns :: [LoggingColumn]
loggingColumns = [LoggingColumn] -> Maybe [LoggingColumn] -> [LoggingColumn]
forall a. a -> Maybe a -> a
fromMaybe [LoggingColumn]
defaultLoggingColumns Maybe [LoggingColumn]
columns
  let textWithPriorityRecorder :: Recorder (WithPriority Text)
textWithPriorityRecorder = (WithPriority Text -> IO Text)
-> Recorder Text -> Recorder (WithPriority Text)
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
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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)
  Recorder (WithPriority (Doc a))
-> m (Recorder (WithPriority (Doc a)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((WithPriority (Doc a) -> WithPriority Text)
-> Recorder (WithPriority Text) -> Recorder (WithPriority (Doc a))
forall a b. (a -> b) -> Recorder b -> Recorder a
cmap WithPriority (Doc a) -> WithPriority Text
forall ann. WithPriority (Doc ann) -> WithPriority Text
docToText Recorder (WithPriority Text)
textWithPriorityRecorder)
  where
    docToText :: WithPriority (Doc ann) -> WithPriority Text
docToText = (Doc ann -> Text) -> WithPriority (Doc ann) -> WithPriority Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SimpleDocStream ann -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream ann -> Text)
-> (Doc ann -> SimpleDocStream ann) -> Doc ann -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc ann -> SimpleDocStream ann
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 -> Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GenericHandler Handle -> Handle -> String -> IO ()
forall a. GenericHandler a -> a -> String -> IO ()
HSL.writeFunc GenericHandler Handle
logH Handle
a String
s }
      logFormatter :: LogFormatter a
logFormatter  = String -> String -> LogFormatter a
forall a. String -> String -> LogFormatter a
HSL.tfLogFormatter String
logDateFormat String
logFormat
      logHandler :: GenericHandler Handle
logHandler = GenericHandler Handle
-> LogFormatter (GenericHandler Handle) -> GenericHandler Handle
forall a. LogHandler a => a -> LogFormatter a -> a
HSL.setFormatter GenericHandler Handle
logHandle LogFormatter (GenericHandler Handle)
forall a. LogFormatter a
logFormatter

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

  -- Also route the additional log names to the same log
  [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
extraLogNames ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
logName -> do
    String -> (Logger -> Logger) -> IO ()
HsLogger.updateGlobalLogger String
logName ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ [GenericHandler Handle] -> Logger -> Logger
forall a. LogHandler a => [a] -> Logger -> Logger
HsLogger.setHandlers [GenericHandler Handle
logHandler]
    String -> (Logger -> Logger) -> IO ()
HsLogger.updateGlobalLogger String
logName ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
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 <- (LoggingColumn -> IO Text) -> [LoggingColumn] -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LoggingColumn -> IO Text
loggingColumnToText [LoggingColumn]
columns
    Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
" | " [Text]
textColumns
    where
      showAsText :: Show a => a -> Text
      showAsText :: a -> Text
showAsText = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

      utcTimeToText :: t -> Text
utcTimeToText t
utcTime = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> t -> String
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 = Priority -> Text
forall a. Show a => a -> Text
showAsText

      threadIdToText :: ThreadId -> Text
threadIdToText = ThreadId -> Text
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)]
_ -> SrcLoc -> Maybe SrcLoc
forall a. a -> Maybe a
Just SrcLoc
srcLoc
          [(String, SrcLoc)]
_               -> Maybe 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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showAsText Int
srcLocStartLine Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
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
          Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> Text
forall t. FormatTime t => t -> Text
utcTimeToText UTCTime
utcTime)
        LoggingColumn
SourceLocColumn -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ (Maybe SrcLoc -> Text
srcLocToText (Maybe SrcLoc -> Text)
-> (CallStack -> Maybe SrcLoc) -> CallStack -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> Maybe SrcLoc
callStackToSrcLoc) CallStack
callStack_
        LoggingColumn
ThreadIdColumn -> do
          ThreadId
threadId <- IO ThreadId
myThreadId
          Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreadId -> Text
threadIdToText ThreadId
threadId)
        LoggingColumn
PriorityColumn -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Priority -> Text
priorityToText Priority
priority)
        LoggingColumn
DataColumn -> Text -> IO Text
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 :: (v -> Recorder a) -> IO (Recorder a, v -> IO ())
withBacklog v -> Recorder a
recFun = do
  -- Arbitrary backlog capacity
  TBQueue a
backlog <- Natural -> IO (TBQueue a)
forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
100
  let backlogRecorder :: Recorder a
backlogRecorder = (forall (m :: * -> *). MonadIO m => a -> m ()) -> Recorder a
forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder ((forall (m :: * -> *). MonadIO m => a -> m ()) -> Recorder a)
-> (forall (m :: * -> *). MonadIO m => a -> m ()) -> Recorder a
forall a b. (a -> b) -> a -> b
$ \a
it -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
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 <- TBQueue a -> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue a
backlog
          Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
full (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TBQueue a -> a -> STM ()
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 <- Recorder a -> IO (TVar (Recorder a))
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 <- STM [a] -> IO [a]
forall a. STM a -> IO a
atomically (STM [a] -> IO [a]) -> STM [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ TVar (Recorder a) -> Recorder a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Recorder a)
recVar Recorder a
recorder STM () -> STM [a] -> STM [a]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TBQueue a -> STM [a]
forall a. TBQueue a -> STM [a]
flushTBQueue TBQueue a
backlog
        [a] -> (a -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [a]
toRecord (Recorder a -> forall (m :: * -> *). MonadIO m => a -> m ()
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 (m :: * -> *). MonadIO m => a -> m ()) -> Recorder a
forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder ((forall (m :: * -> *). MonadIO m => a -> m ()) -> Recorder a)
-> (forall (m :: * -> *). MonadIO m => a -> m ()) -> Recorder a
forall a b. (a -> b) -> a -> b
$ \a
it -> do
          Recorder a
r <- IO (Recorder a) -> m (Recorder a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Recorder a) -> m (Recorder a))
-> IO (Recorder a) -> m (Recorder a)
forall a b. (a -> b) -> a -> b
$ TVar (Recorder a) -> IO (Recorder a)
forall a. TVar a -> IO a
readTVarIO TVar (Recorder a)
recVar
          Recorder a -> a -> m ()
forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ Recorder a
r a
it

  (Recorder a, v -> IO ()) -> IO (Recorder a, v -> IO ())
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 :: LanguageContextEnv config -> Recorder (WithPriority Text)
lspClientMessageRecorder LanguageContextEnv config
env = (forall (m :: * -> *). MonadIO m => WithPriority Text -> m ())
-> Recorder (WithPriority Text)
forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder ((forall (m :: * -> *). MonadIO m => WithPriority Text -> m ())
 -> Recorder (WithPriority Text))
-> (forall (m :: * -> *). MonadIO m => WithPriority Text -> m ())
-> Recorder (WithPriority Text)
forall a b. (a -> b) -> a -> b
$ \WithPriority {..} ->
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv config -> LspT config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv config
env (LspT config IO () -> IO ()) -> LspT config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'WindowShowMessage
-> MessageParams 'WindowShowMessage -> LspT config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'WindowShowMessage
SWindowShowMessage
      ShowMessageParams :: MessageType -> Text -> ShowMessageParams
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 :: LanguageContextEnv config -> Recorder (WithPriority Text)
lspClientLogRecorder LanguageContextEnv config
env = (forall (m :: * -> *). MonadIO m => WithPriority Text -> m ())
-> Recorder (WithPriority Text)
forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder ((forall (m :: * -> *). MonadIO m => WithPriority Text -> m ())
 -> Recorder (WithPriority Text))
-> (forall (m :: * -> *). MonadIO m => WithPriority Text -> m ())
-> Recorder (WithPriority Text)
forall a b. (a -> b) -> a -> b
$ \WithPriority {..} ->
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv config -> LspT config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv config
env (LspT config IO () -> IO ()) -> LspT config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'WindowLogMessage
-> MessageParams 'WindowLogMessage -> LspT config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'WindowLogMessage
SWindowLogMessage
      LogMessageParams :: MessageType -> Text -> LogMessageParams
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