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

{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

-- | 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(..)
  , Recorder(..)
  , WithPriority(..)
  , logWith
  , cmap
  , cmapIO
  , cfilter
  , withFileRecorder
  , makeDefaultStderrRecorder
  , makeDefaultHandleRecorder
  , LoggingColumn(..)
  , cmapWithPrio
  , withBacklog
  , lspClientMessageRecorder
  , lspClientLogRecorder
  , module PrettyPrinterModule
  , renderStrict
  , toCologActionWithPrio
  , defaultLoggingColumns
  ) 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 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
(Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool) -> Eq Priority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Priority -> Priority -> Bool
== :: Priority -> Priority -> Bool
$c/= :: Priority -> Priority -> Bool
/= :: 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
$cshowsPrec :: Int -> Priority -> ShowS
showsPrec :: Int -> Priority -> ShowS
$cshow :: Priority -> String
show :: Priority -> String
$cshowList :: [Priority] -> ShowS
showList :: [Priority] -> ShowS
Show, ReadPrec [Priority]
ReadPrec Priority
Int -> ReadS Priority
ReadS [Priority]
(Int -> ReadS Priority)
-> ReadS [Priority]
-> ReadPrec Priority
-> ReadPrec [Priority]
-> Read Priority
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Priority
readsPrec :: Int -> ReadS Priority
$creadList :: ReadS [Priority]
readList :: ReadS [Priority]
$creadPrec :: ReadPrec Priority
readPrec :: ReadPrec Priority
$creadListPrec :: ReadPrec [Priority]
readListPrec :: ReadPrec [Priority]
Read, 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
$ccompare :: Priority -> Priority -> Ordering
compare :: Priority -> Priority -> Ordering
$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
>= :: Priority -> Priority -> Bool
$cmax :: Priority -> Priority -> Priority
max :: Priority -> Priority -> Priority
$cmin :: Priority -> Priority -> Priority
min :: Priority -> Priority -> 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
$csucc :: Priority -> Priority
succ :: Priority -> Priority
$cpred :: Priority -> Priority
pred :: Priority -> Priority
$ctoEnum :: Int -> Priority
toEnum :: Int -> Priority
$cfromEnum :: Priority -> Int
fromEnum :: Priority -> Int
$cenumFrom :: Priority -> [Priority]
enumFrom :: Priority -> [Priority]
$cenumFromThen :: Priority -> Priority -> [Priority]
enumFromThen :: Priority -> Priority -> [Priority]
$cenumFromTo :: Priority -> Priority -> [Priority]
enumFromTo :: Priority -> Priority -> [Priority]
$cenumFromThenTo :: Priority -> Priority -> Priority -> [Priority]
enumFromThenTo :: Priority -> Priority -> Priority -> [Priority]
Enum, Priority
Priority -> Priority -> Bounded Priority
forall a. a -> a -> Bounded a
$cminBound :: Priority
minBound :: Priority
$cmaxBound :: Priority
maxBound :: Priority
Bounded)

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 -> 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
$cfmap :: forall a b. (a -> b) -> WithPriority a -> WithPriority b
fmap :: forall a b. (a -> b) -> WithPriority a -> WithPriority b
$c<$ :: forall a b. a -> WithPriority b -> WithPriority a
<$ :: forall a b. a -> WithPriority b -> WithPriority a
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 = (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)
-> forall (m :: * -> *). MonadIO m => 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
      { 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 a b. m a -> m b -> m b
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
      { logger_ :: forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ = \msg
_ -> () -> m ()
forall a. a -> m a
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 msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ } =
    Recorder
      { logger_ :: forall (m :: * -> *). MonadIO m => a' -> m ()
logger_ = a -> m ()
forall (m :: * -> *). MonadIO m => a -> m ()
logger_ (a -> m ()) -> (a' -> a) -> a' -> m ()
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 = (a -> b) -> Recorder b -> Recorder a
forall a' a. (a' -> a) -> Recorder a -> Recorder a'
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 = (WithPriority a -> WithPriority b)
-> Recorder (WithPriority b) -> Recorder (WithPriority a)
forall a' a. (a' -> a) -> Recorder a -> Recorder a'
cmap ((a -> b) -> WithPriority a -> WithPriority b
forall a b. (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 :: forall a b. (a -> IO b) -> Recorder b -> Recorder a
cmapIO a -> IO b
f Recorder{ forall (m :: * -> *). MonadIO m => b -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => b -> m ()
logger_ } =
  Recorder
    { logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ = (IO b -> m b
forall a. IO a -> m a
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 :: forall a. (a -> Bool) -> Recorder a -> Recorder a
cfilter a -> Bool
p Recorder{ forall (m :: * -> *). MonadIO m => a -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ } =
  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
    { logger_ :: forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ = \Text
text -> IO () -> m ()
forall a. IO a -> m a
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 a b. IO a -> IO b -> IO b
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 <- IO Lock -> m Lock
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Lock
newLock
  Maybe [LoggingColumn]
-> Lock -> Handle -> m (Recorder (WithPriority (Doc a)))
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 <- IO Lock -> m Lock
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Lock
newLock
  let makeHandleRecorder :: Handle -> m (Recorder (WithPriority (Doc a)))
makeHandleRecorder = Maybe [LoggingColumn]
-> Lock -> Handle -> m (Recorder (WithPriority (Doc a)))
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 <- IO (Either IOException Handle) -> m (Either IOException Handle)
forall a. IO a -> m a
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 -> Either IOException (Recorder (WithPriority (Doc d))) -> m a
action (Either IOException (Recorder (WithPriority (Doc d))) -> m a)
-> Either IOException (Recorder (WithPriority (Doc d))) -> m a
forall a b. (a -> b) -> a -> b
$ IOException -> Either IOException (Recorder (WithPriority (Doc d)))
forall a b. a -> Either a b
Left IOException
e
    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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either IOException (Recorder (WithPriority (Doc d))) -> m a
action (Either IOException (Recorder (WithPriority (Doc d))) -> m a)
-> (Recorder (WithPriority (Doc d))
    -> Either IOException (Recorder (WithPriority (Doc d))))
-> Recorder (WithPriority (Doc d))
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Recorder (WithPriority (Doc d))
-> Either IOException (Recorder (WithPriority (Doc d)))
forall a b. b -> Either a b
Right) (IO () -> m ()
forall a. IO a -> m a
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
  -> 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 msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ } = Handle -> Recorder Text
textHandleRecorder Handle
handle
  let threadSafeRecorder :: Recorder Text
threadSafeRecorder = Recorder { logger_ :: forall (m :: * -> *). MonadIO m => Text -> m ()
logger_ = \Text
msg -> IO () -> m ()
forall a. IO a -> m a
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
  Recorder (WithPriority (Doc a))
-> m (Recorder (WithPriority (Doc a)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((WithPriority (Doc a) -> WithPriority Text)
-> Recorder (WithPriority Text) -> Recorder (WithPriority (Doc a))
forall a' a. (a' -> a) -> Recorder a -> 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 a b. (a -> b) -> WithPriority a -> WithPriority b
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)

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 :: forall a. WithPriority a -> Priority
priority :: Priority
priority, CallStack
callStack_ :: forall a. WithPriority a -> CallStack
callStack_ :: CallStack
callStack_, Text
payload :: forall a. WithPriority a -> a
payload :: Text
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LoggingColumn -> IO Text
loggingColumnToText [LoggingColumn]
columns
    Text -> IO Text
forall a. a -> IO a
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 :: forall a. Show a => 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 :: SrcLoc -> String
srcLocModule :: String
srcLocModule, Int
srcLocStartLine :: SrcLoc -> Int
srcLocStartLine :: Int
srcLocStartLine, Int
srcLocStartCol :: SrcLoc -> Int
srcLocStartCol :: 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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreadId -> Text
threadIdToText ThreadId
threadId)
        LoggingColumn
PriorityColumn -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Priority -> Text
priorityToText Priority
priority)
        LoggingColumn
DataColumn -> Text -> IO Text
forall a. a -> IO a
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 <- 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 a. IO a -> m a
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 a b. STM a -> STM b -> STM b
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 a. IO a -> m 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 -> forall (m :: * -> *). MonadIO m => 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 a. a -> IO a
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 (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 {CallStack
Text
Priority
priority :: forall a. WithPriority a -> Priority
callStack_ :: forall a. WithPriority a -> CallStack
payload :: forall a. WithPriority a -> a
priority :: Priority
callStack_ :: CallStack
payload :: Text
..} ->
  IO () -> m ()
forall a. IO a -> m a
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 'Method_WindowShowMessage
-> MessageParams 'Method_WindowShowMessage -> LspT config IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod '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 (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 {CallStack
Text
Priority
priority :: forall a. WithPriority a -> Priority
callStack_ :: forall a. WithPriority a -> CallStack
payload :: forall a. WithPriority a -> a
priority :: Priority
callStack_ :: CallStack
payload :: Text
..} ->
  IO () -> m ()
forall a. IO a -> m a
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 'Method_WindowLogMessage
-> MessageParams 'Method_WindowLogMessage -> LspT config IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod '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) = (WithSeverity msg -> m ()) -> LogAction m (WithSeverity msg)
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((WithSeverity msg -> m ()) -> LogAction m (WithSeverity msg))
-> (WithSeverity msg -> m ()) -> LogAction m (WithSeverity msg)
forall a b. (a -> b) -> a -> b
$ \WithSeverity{msg
Severity
getMsg :: msg
getSeverity :: Severity
getMsg :: forall msg. WithSeverity msg -> msg
getSeverity :: forall msg. WithSeverity msg -> Severity
..} -> do
    let priority :: Priority
priority = Severity -> Priority
severityToPriority Severity
getSeverity
    WithPriority msg -> m ()
forall (m :: * -> *). MonadIO m => WithPriority msg -> m ()
_logger (WithPriority msg -> m ()) -> WithPriority msg -> m ()
forall a b. (a -> b) -> a -> b
$ Priority -> CallStack -> msg -> WithPriority msg
forall a. Priority -> CallStack -> a -> WithPriority a
WithPriority Priority
priority CallStack
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