@@ -21,38 +21,50 @@ module Development.IDE.Types.Logger
2121 , priorityToHsLoggerPriority
2222 , LoggingColumn (.. )
2323 , cmapWithPrio
24+ , withBacklog
25+ , lspClientMessageRecorder
26+ , lspClientLogRecorder
2427 , module PrettyPrinterModule
2528 , renderStrict
2629 ) where
2730
28- import Control.Concurrent (myThreadId )
29- import Control.Concurrent.Extra (Lock , newLock , withLock )
30- import Control.Exception (IOException )
31- import Control.Monad (forM_ , when , (>=>) )
32- import Control.Monad.IO.Class (MonadIO (liftIO ))
33- import Data.Functor.Contravariant (Contravariant (contramap ))
34- import Data.Maybe (fromMaybe )
35- import Data.Text (Text )
36- import qualified Data.Text as T
37- import qualified Data.Text as Text
38- import qualified Data.Text.IO as Text
39- import Data.Time (defaultTimeLocale , formatTime ,
40- getCurrentTime )
41- import GHC.Stack (CallStack , HasCallStack ,
42- SrcLoc (SrcLoc , srcLocModule , srcLocStartCol , srcLocStartLine ),
43- callStack , getCallStack ,
44- withFrozenCallStack )
45- import Prettyprinter as PrettyPrinterModule
46- import Prettyprinter.Render.Text (renderStrict )
47- import System.IO (Handle , IOMode (AppendMode ),
48- hClose , hFlush , hSetEncoding ,
49- openFile , stderr , utf8 )
50- import qualified System.Log.Formatter as HSL
51- import qualified System.Log.Handler as HSL
52- import qualified System.Log.Handler.Simple as HSL
53- import qualified System.Log.Logger as HsLogger
54- import UnliftIO (MonadUnliftIO , displayException ,
55- finally , try )
31+ import Control.Concurrent (myThreadId )
32+ import Control.Concurrent.Extra (Lock , newLock , withLock )
33+ import Control.Concurrent.STM (atomically ,
34+ newTVarIO , writeTVar , readTVarIO , newTBQueueIO , flushTBQueue , writeTBQueue , isFullTBQueue )
35+ import Control.Exception (IOException )
36+ import Control.Monad (forM_ , when , (>=>) , unless )
37+ import Control.Monad.IO.Class (MonadIO (liftIO ))
38+ import Data.Foldable (for_ )
39+ import Data.Functor.Contravariant (Contravariant (contramap ))
40+ import Data.Maybe (fromMaybe )
41+ import Data.Text (Text )
42+ import qualified Data.Text as T
43+ import qualified Data.Text as Text
44+ import qualified Data.Text.IO as Text
45+ import Data.Time (defaultTimeLocale , formatTime ,
46+ getCurrentTime )
47+ import GHC.Stack (CallStack , HasCallStack ,
48+ SrcLoc (SrcLoc , srcLocModule , srcLocStartCol , srcLocStartLine ),
49+ callStack , getCallStack ,
50+ withFrozenCallStack )
51+ import Language.LSP.Server
52+ import qualified Language.LSP.Server as LSP
53+ import Language.LSP.Types (LogMessageParams (.. ),
54+ MessageType (.. ),
55+ SMethod (SWindowLogMessage , SWindowShowMessage ),
56+ ShowMessageParams (.. ))
57+ import Prettyprinter as PrettyPrinterModule
58+ import Prettyprinter.Render.Text (renderStrict )
59+ import System.IO (Handle , IOMode (AppendMode ),
60+ hClose , hFlush , hSetEncoding ,
61+ openFile , stderr , utf8 )
62+ import qualified System.Log.Formatter as HSL
63+ import qualified System.Log.Handler as HSL
64+ import qualified System.Log.Handler.Simple as HSL
65+ import qualified System.Log.Logger as HsLogger
66+ import UnliftIO (MonadUnliftIO , displayException ,
67+ finally , try )
5668
5769data Priority
5870-- Don't change the ordering of this type or you will mess up the Ord
@@ -204,10 +216,10 @@ makeDefaultHandleRecorder columns minPriority lock handle = do
204216
205217priorityToHsLoggerPriority :: Priority -> HsLogger. Priority
206218priorityToHsLoggerPriority = \ case
207- Debug -> HsLogger. DEBUG
208- Info -> HsLogger. INFO
209- Warning -> HsLogger. WARNING
210- Error -> HsLogger. ERROR
219+ Debug -> HsLogger. DEBUG
220+ Info -> HsLogger. INFO
221+ Warning -> HsLogger. WARNING
222+ Error -> HsLogger. ERROR
211223
212224-- | The purpose of setting up `hslogger` at all is that `hie-bios` uses
213225-- `hslogger` to output compilation logs. The easiest way to merge these logs
@@ -290,3 +302,61 @@ textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = d
290302 pure (threadIdToText threadId)
291303 PriorityColumn -> pure (priorityToText priority)
292304 DataColumn -> pure payload
305+
306+ -- | Given a 'Recorder' that requires an argument, produces a 'Recorder'
307+ -- that queues up messages until the argument is provided using the callback, at which
308+ -- point it sends the backlog and begins functioning normally.
309+ withBacklog :: (v -> Recorder a ) -> IO Recorder a , v -> IO () )
310+ withBacklog recFun = do
311+ -- Arbitrary backlog capacity
312+ backlog <- newTBQueueIO 100
313+ let backlogRecorder = Recorder $ \ it -> liftIO $ atomically $ do
314+ -- If the queue is full just drop the message on the floor. This is most likely
315+ -- to happen if the callback is just never going to be called; in which case
316+ -- we want neither to build up an unbounded backlog in memory, nor block waiting
317+ -- for space!
318+ full <- isFullTBQueue backlog
319+ unless full $ writeTBQueue backlog it
320+
321+ -- The variable holding the recorder starts out holding the recorder that writes
322+ -- to the backlog.
323+ recVar <- newTVarIO backlogRecorder
324+ -- The callback atomically swaps out the recorder for the final one, and flushes
325+ -- the backlog to it.
326+ let cb arg = do
327+ let recorder = recFun arg
328+ toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog
329+ for_ toRecord (logger_ recorder)
330+
331+ -- The recorder we actually return looks in the variable and uses whatever is there.
332+ let varRecorder = Recorder $ \ it -> do
333+ r <- liftIO $ readTVarIO recVar
334+ logger_ r it
335+
336+ pure (varRecorder, cb)
337+
338+ -- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.
339+ lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text )
340+ lspClientMessageRecorder env = Recorder $ \ WithPriority {.. } ->
341+ liftIO $ LSP. runLspT env $ LSP. sendNotification SWindowShowMessage
342+ ShowMessageParams
343+ { _xtype = priorityToLsp priority,
344+ _message = payload
345+ }
346+
347+ -- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications.
348+ lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text )
349+ lspClientLogRecorder env = Recorder $ \ WithPriority {.. } ->
350+ liftIO $ LSP. runLspT env $ LSP. sendNotification SWindowLogMessage
351+ LogMessageParams
352+ { _xtype = priorityToLsp priority,
353+ _message = payload
354+ }
355+
356+ priorityToLsp :: Priority -> MessageType
357+ priorityToLsp =
358+ \ case
359+ Debug -> MtLog
360+ Info -> MtInfo
361+ Warning -> MtWarning
362+ Error -> MtError
0 commit comments