Skip to content

Commit 1862a03

Browse files
michaelpjmichaelpj
committed
Use a callback instead
1 parent 7657312 commit 1862a03

File tree

7 files changed

+54
-46
lines changed

7 files changed

+54
-46
lines changed

‎exe/Main.hs‎

Lines changed: 3 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,6 @@
44
{-# LANGUAGE OverloadedStrings #-}
55
module Main(main) where
66

7-
import Control.Concurrent (newEmptyMVar)
87
import Data.Function ((&))
98
import Data.Text (Text)
109
import qualified Development.IDE.Types.Logger as Logger
@@ -18,7 +17,6 @@ import Ide.Arguments (Arguments (..),
1817
getArguments)
1918
import Ide.Main (defaultMain)
2019
import qualified Ide.Main as IdeMain
21-
import Ide.PluginUtils (pluginDescToIdePlugins)
2220
import qualified Plugins
2321
import Prettyprinter (Pretty (pretty), vsep)
2422

@@ -38,9 +36,8 @@ main = do
3836
pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing Info
3937
args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) False)
4038

41-
lspEnvVar <- newEmptyMVar
42-
lspLogRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientLogRecorder
43-
lspMessageRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientMessageRecorder
39+
(lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
40+
(lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
4441

4542
let (minPriority, logFilePath, includeExamplePlugins) =
4643
case args of
@@ -64,9 +61,9 @@ main = do
6461

6562
defaultMain
6663
(cmapWithPrio LogIdeMain recorder)
67-
(Just lspEnvVar)
6864
args
6965
(Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins)
66+
(cb1 <> cb2)
7067

7168
renderDoc :: Doc a -> Text
7269
renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep

‎ghcide/exe/Main.hs‎

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,6 @@ module Main(main) where
77

88
import Arguments (Arguments (..),
99
getArguments)
10-
import Control.Concurrent (newEmptyMVar)
1110
import Control.Monad.Extra (unless)
1211
import Data.Default (def)
1312
import Data.Function ((&))
@@ -87,9 +86,8 @@ main = withTelemetryLogger $ \telemetryLogger -> do
8786

8887
docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority
8988

90-
lspEnvVar <- newEmptyMVar
91-
lspLogRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientLogRecorder
92-
lspMessageRecorder <- Logger.withBacklog lspEnvVar Logger.lspClientMessageRecorder
89+
(lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
90+
(lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
9391

9492
let docWithFilteredPriorityRecorder@Recorder{ logger_ } =
9593
(docWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>
@@ -109,7 +107,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do
109107
then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger
110108
else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger
111109

112-
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (Just lspEnvVar) arguments
110+
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
113111
{ IDEMain.argsProjectRoot = Just argsCwd
114112
, IDEMain.argCommand = argsCommand
115113
, IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger
@@ -134,4 +132,5 @@ main = withTelemetryLogger $ \telemetryLogger -> do
134132
, optCheckProject = pure $ checkProject config
135133
, optRunSubset = not argsConservativeChangeTracking
136134
}
135+
, IDEMain.argsLspEnvCb = cb1 <> cb2
137136
}

‎ghcide/src/Development/IDE/Main.hs‎

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@ module Development.IDE.Main
1111
,testing
1212
,Log(..)
1313
) where
14-
import Control.Concurrent (MVar, putMVar)
1514
import Control.Concurrent.Extra (withNumCapabilities)
1615
import Control.Concurrent.STM.Stats (atomically,
1716
dumpSTMStats)
@@ -21,7 +20,7 @@ import Control.Monad.Extra (concatMapM, unless,
2120
when)
2221
import qualified Data.Aeson.Encode.Pretty as A
2322
import Data.Default (Default (def))
24-
import Data.Foldable (traverse_, for_)
23+
import Data.Foldable (traverse_)
2524
import qualified Data.HashMap.Strict as HashMap
2625
import Data.Hashable (hashed)
2726
import Data.List.Extra (intercalate, isPrefixOf,
@@ -232,6 +231,7 @@ data Arguments = Arguments
232231
, argsHandleIn :: IO Handle
233232
, argsHandleOut :: IO Handle
234233
, argsThreads :: Maybe Natural
234+
, argsLspEnvCb :: LSP.LanguageContextEnv Config -> IO () -- ^ Callback to run once the LSP environment is setup
235235
}
236236

237237
defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments
@@ -268,6 +268,7 @@ defaultArguments recorder logger = Arguments
268268
-- the language server tests without the redirection.
269269
putStr " " >> hFlush stdout
270270
return newStdout
271+
, argsLspEnvCb = mempty
271272
}
272273

273274

@@ -291,12 +292,9 @@ testing recorder logger =
291292

292293
defaultMain
293294
:: Recorder (WithPriority Log)
294-
-> Maybe (MVar (LSP.LanguageContextEnv Config))
295-
-- ^ Variable to be filled with the LSP environment, useful for tools that need this outside
296-
-- the scope of runLanguageServer
297295
-> Arguments
298296
-> IO ()
299-
defaultMain recorder lspEnvVar Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun
297+
defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun
300298
where
301299
log :: Priority -> Log -> IO ()
302300
log = logWith recorder
@@ -334,7 +332,7 @@ defaultMain recorder lspEnvVar Arguments{..} = withHeapStats (cmapWithPrio LogHe
334332
t <- t
335333
log Info $ LogLspStartDuration t
336334

337-
for_ lspEnvVar $ \var -> putMVar var env
335+
argsLspEnvCb env
338336

339337
dir <- maybe IO.getCurrentDirectory return rootPath
340338

‎ghcide/src/Development/IDE/Types/Logger.hs‎

Lines changed: 34 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -28,13 +28,13 @@ module Development.IDE.Types.Logger
2828
, renderStrict
2929
) where
3030

31-
import Control.Concurrent (MVar, myThreadId, tryReadMVar)
31+
import Control.Concurrent (myThreadId)
3232
import Control.Concurrent.Extra (Lock, newLock, withLock)
3333
import Control.Concurrent.STM (atomically, newTQueueIO,
34-
writeTQueue)
34+
writeTQueue, newTVarIO, writeTVar, readTVarIO, newTBQueueIO, flushTBQueue, writeTBQueue, isFullTBQueue)
3535
import Control.Concurrent.STM.TQueue (flushTQueue)
3636
import Control.Exception (IOException)
37-
import Control.Monad (forM_, when, (>=>))
37+
import Control.Monad (forM_, when, (>=>), unless)
3838
import Control.Monad.IO.Class (MonadIO (liftIO))
3939
import Data.Foldable (for_)
4040
import Data.Functor.Contravariant (Contravariant (contramap))
@@ -304,22 +304,37 @@ textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = d
304304
PriorityColumn -> pure (priorityToText priority)
305305
DataColumn -> pure payload
306306

307-
-- | Given a 'Recorder' that requires an argument, and an 'MVar' that
308-
-- will eventually be filled with that argument, produces a 'Recorder'
309-
-- that queues up messages until the argument is available, at which
310-
-- point it sends the backlog.
311-
withBacklog :: MVar v -> (v -> Recorder a) -> IO (Recorder a)
312-
withBacklog argVar recFun = do
313-
backlog <- newTQueueIO
314-
pure $ Recorder $ \it -> do
315-
marg <- liftIO $ tryReadMVar argVar
316-
case marg of
317-
Nothing -> liftIO $ atomically $ writeTQueue backlog it
318-
Just arg -> do
319-
let recorder = recFun arg
320-
toRecord <- liftIO $ atomically $ flushTQueue backlog
321-
for_ toRecord (logger_ recorder)
322-
logger_ recorder it
307+
-- | Given a 'Recorder' that requires an argument, produces a 'Recorder'
308+
-- that queues up messages until the argument is provided using the callback, at which
309+
-- point it sends the backlog and begins functioning normally.
310+
withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ())
311+
withBacklog recFun = do
312+
-- Arbitrary backlog capacity
313+
backlog <- newTBQueueIO 100
314+
let backlogRecorder = Recorder $ \it -> liftIO $ atomically $ do
315+
-- If the queue is full just drop the message on the floor. This is most likely
316+
-- to happen if the callback is just never going to be called; in which case
317+
-- we want neither to build up an unbounded backlog in memory, nor block waiting
318+
-- for space!
319+
full <- isFullTBQueue backlog
320+
unless full $ writeTBQueue backlog it
321+
322+
-- The variable holding the recorder starts out holding the recorder that writes
323+
-- to the backlog.
324+
recVar <- newTVarIO backlogRecorder
325+
-- The callback atomically swaps out the recorder for the final one, and flushes
326+
-- the backlog to it.
327+
let cb arg = do
328+
let recorder = recFun arg
329+
toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog
330+
for_ toRecord (logger_ recorder)
331+
332+
-- The recorder we actually return looks in the variable and uses whatever is there.
333+
let varRecorder = Recorder $ \it -> do
334+
r <- liftIO $ readTVarIO recVar
335+
logger_ r it
336+
337+
pure (varRecorder, cb)
323338

324339
-- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.
325340
lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)

‎ghcide/test/exe/Main.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6407,7 +6407,7 @@ testIde recorder arguments session = do
64076407
(hInRead, hInWrite) <- createPipe
64086408
(hOutRead, hOutWrite) <- createPipe
64096409
let projDir = "."
6410-
let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) Nothing arguments
6410+
let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
64116411
{ IDE.argsHandleIn = pure hInRead
64126412
, IDE.argsHandleOut = pure hOutWrite
64136413
}

‎hls-test-utils/src/Test/Hls.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -219,7 +219,6 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre
219219
async $
220220
Ghcide.defaultMain
221221
(cmapWithPrio LogIDEMain recorder)
222-
Nothing
223222
arguments
224223
{ argsHandleIn = pure inR
225224
, argsHandleOut = pure outW

‎src/Ide/Main.hs‎

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@
1111
module Ide.Main(defaultMain, runLspMode, Log(..)) where
1212

1313
import Control.Monad.Extra
14-
import Control.Concurrent (MVar)
1514
import qualified Data.Aeson.Encode.Pretty as A
1615
import qualified Data.ByteString.Lazy.Char8 as LBS
1716
import Data.Coerce (coerce)
@@ -63,11 +62,11 @@ instance Pretty Log where
6362

6463
defaultMain
6564
:: Recorder (WithPriority Log)
66-
-> Maybe (MVar (LSP.LanguageContextEnv Config))
6765
-> Arguments
6866
-> IdePlugins IdeState
67+
-> (LSP.LanguageContextEnv Config -> IO ())
6968
-> IO ()
70-
defaultMain recorder lspEnvVar args idePlugins = do
69+
defaultMain recorder args idePlugins lspEnvCb = do
7170
-- WARNING: If you write to stdout before runLanguageServer
7271
-- then the language server will not work
7372

@@ -100,7 +99,7 @@ defaultMain recorder lspEnvVar args idePlugins = do
10099
Ghcide ghcideArgs -> do
101100
{- see WARNING above -}
102101
logWith recorder Info $ LogVersion hlsVer
103-
runLspMode recorder lspEnvVar ghcideArgs idePlugins
102+
runLspMode recorder ghcideArgs idePlugins lspEnvCb
104103

105104
VSCodeExtensionSchemaMode -> do
106105
LBS.putStrLn $ A.encodePretty $ pluginsToVSCodeExtensionSchema idePlugins
@@ -129,11 +128,11 @@ hlsLogger = G.Logger $ \pri txt ->
129128

130129
runLspMode
131130
:: Recorder (WithPriority Log)
132-
-> Maybe (MVar (LSP.LanguageContextEnv Config))
133131
-> GhcideArguments
134132
-> IdePlugins IdeState
133+
-> (LSP.LanguageContextEnv Config -> IO ())
135134
-> IO ()
136-
runLspMode recorder lspEnvVar ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do
135+
runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins lspEnvCb = withTelemetryLogger $ \telemetryLogger -> do
137136
let log = logWith recorder
138137
whenJust argsCwd IO.setCurrentDirectory
139138
dir <- IO.getCurrentDirectory
@@ -142,7 +141,7 @@ runLspMode recorder lspEnvVar ghcideArgs@GhcideArguments{..} idePlugins = withTe
142141
when (isLSP argsCommand) $ do
143142
log Info $ LogLspStart ghcideArgs (map fst $ ipMap idePlugins)
144143

145-
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) lspEnvVar (IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsLogger)
144+
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsLogger)
146145
{ IDEMain.argCommand = argsCommand
147146
, IDEMain.argsHlsPlugins = idePlugins
148147
, IDEMain.argsLogger = pure hlsLogger <> pure telemetryLogger
@@ -155,4 +154,5 @@ runLspMode recorder lspEnvVar ghcideArgs@GhcideArguments{..} idePlugins = withTe
155154
, Ghcide.optShakeOptions = (Ghcide.optShakeOptions defOptions)
156155
{shakeThreads = argsThreads}
157156
}
157+
, IDEMain.argsLspEnvCb = lspEnvCb
158158
}

0 commit comments

Comments
 (0)