Skip to content

Commit 132193e

Browse files
wz1000wz1000
authored
Add test for multi-component goto def and make runLanguageServer responsible for hiedb (#1373)
* Add test for multi-component goto def and make runLanguageServer responsible for hiedb * cleanup * fix hlint * debug windows * fix windows test * make hiedb location configurable
1 parent d674178 commit 132193e

File tree

6 files changed

+117
-83
lines changed

6 files changed

+117
-83
lines changed

‎ghcide/.hlint.yaml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -105,7 +105,7 @@
105105
#
106106
- functions:
107107
# Things that are unsafe in Haskell base library
108-
- {name: unsafeInterleaveIO, within: []}
108+
- {name: unsafeInterleaveIO, within: [Development.IDE.LSP.LanguageServer]}
109109
- {name: unsafeDupablePerformIO, within: []}
110110
- {name: unsafeCoerce, within: []}
111111
# Things that are a bit dangerous in the GHC API

‎ghcide/exe/Main.hs

Lines changed: 38 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,7 @@ import Development.IDE.Core.OfInterest (kick)
2020
import Development.IDE.Core.Rules (mainRule)
2121
import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
2222
import qualified Development.IDE.Plugin.Test as Test
23-
import Development.IDE.Session (setInitialDynFlags, getHieDbLoc, runWithDb)
23+
import Development.IDE.Session (setInitialDynFlags, getHieDbLoc)
2424
import Development.IDE.Types.Options
2525
import qualified Development.IDE.Main as Main
2626
import Development.Shake (ShakeOptions(shakeThreads))
@@ -56,9 +56,6 @@ main = do
5656

5757
whenJust argsCwd IO.setCurrentDirectory
5858

59-
dir <- IO.getCurrentDirectory
60-
dbLoc <- getHieDbLoc dir
61-
6259
-- lock to avoid overlapping output on stdout
6360
lock <- newLock
6461
let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $
@@ -67,6 +64,8 @@ main = do
6764

6865
case argFilesOrCmd of
6966
DbCmd opts cmd -> do
67+
dir <- IO.getCurrentDirectory
68+
dbLoc <- getHieDbLoc dir
7069
mlibdir <- setInitialDynFlags
7170
case mlibdir of
7271
Nothing -> exitWith $ ExitFailure 1
@@ -80,40 +79,39 @@ main = do
8079
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
8180
_ -> return ()
8281

83-
runWithDb dbLoc $ \hiedb hiechan ->
84-
Main.defaultMain (Main.defArguments hiedb hiechan)
85-
{Main.argFiles = case argFilesOrCmd of
86-
Typecheck x | not argLSP -> Just x
87-
_ -> Nothing
88-
89-
,Main.argsLogger = logger
90-
91-
,Main.argsRules = do
92-
-- install the main and ghcide-plugin rules
93-
mainRule
94-
-- install the kick action, which triggers a typecheck on every
95-
-- Shake database restart, i.e. on every user edit.
96-
unless argsDisableKick $
97-
action kick
98-
99-
,Main.argsHlsPlugins =
100-
pluginDescToIdePlugins $
101-
GhcIde.descriptors
102-
++ [Test.blockCommandDescriptor "block-command" | argsTesting]
103-
104-
,Main.argsGhcidePlugin = if argsTesting
105-
then Test.plugin
106-
else mempty
107-
108-
,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader ->
109-
let defOptions = defaultIdeOptions sessionLoader
110-
in defOptions
111-
{ optShakeProfiling = argsShakeProfiling
112-
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
113-
, optTesting = IdeTesting argsTesting
114-
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
115-
, optCheckParents = pure $ checkParents config
116-
, optCheckProject = pure $ checkProject config
117-
}
118-
}
82+
Main.defaultMain Main.defArguments
83+
{Main.argFiles = case argFilesOrCmd of
84+
Typecheck x | not argLSP -> Just x
85+
_ -> Nothing
86+
87+
,Main.argsLogger = logger
88+
89+
,Main.argsRules = do
90+
-- install the main and ghcide-plugin rules
91+
mainRule
92+
-- install the kick action, which triggers a typecheck on every
93+
-- Shake database restart, i.e. on every user edit.
94+
unless argsDisableKick $
95+
action kick
96+
97+
,Main.argsHlsPlugins =
98+
pluginDescToIdePlugins $
99+
GhcIde.descriptors
100+
++ [Test.blockCommandDescriptor "block-command" | argsTesting]
101+
102+
,Main.argsGhcidePlugin = if argsTesting
103+
then Test.plugin
104+
else mempty
105+
106+
,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader ->
107+
let defOptions = defaultIdeOptions sessionLoader
108+
in defOptions
109+
{ optShakeProfiling = argsShakeProfiling
110+
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
111+
, optTesting = IdeTesting argsTesting
112+
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
113+
, optCheckParents = pure $ checkParents config
114+
, optCheckProject = pure $ checkProject config
115+
}
116+
}
119117

‎ghcide/src/Development/IDE/LSP/LanguageServer.hs

Lines changed: 27 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -28,9 +28,11 @@ import Control.Monad.Extra
2828
import UnliftIO.Exception
2929
import UnliftIO.Async
3030
import UnliftIO.Concurrent
31+
import UnliftIO.Directory
3132
import Control.Monad.IO.Class
3233
import Control.Monad.Reader
3334
import Ide.Types (traceWithSpan)
35+
import Development.IDE.Session (runWithDb)
3436

3537
import Development.IDE.Core.IdeConfiguration
3638
import Development.IDE.Core.Shake
@@ -40,14 +42,17 @@ import Development.IDE.Types.Logger
4042
import Development.IDE.Core.FileStore
4143
import Development.IDE.Core.Tracing
4244

45+
import System.IO.Unsafe (unsafeInterleaveIO)
46+
4347
runLanguageServer
4448
:: forall config. (Show config)
4549
=> LSP.Options
50+
-> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
4651
-> (IdeState -> Value -> IO (Either T.Text config))
4752
-> LSP.Handlers (ServerM config)
48-
-> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> IO IdeState)
53+
-> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState)
4954
-> IO ()
50-
runLanguageServer options onConfigurationChange userHandlers getIdeState = do
55+
runLanguageServer options getHieDbLoc onConfigurationChange userHandlers getIdeState = do
5156
-- Move stdout to another file descriptor and duplicate stderr
5257
-- to stdout. This guards against stray prints from corrupting the JSON-RPC
5358
-- message stream.
@@ -132,15 +137,26 @@ runLanguageServer options onConfigurationChange userHandlers getIdeState = do
132137
:: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage
133138
-> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
134139
handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
135-
liftIO $ traceWithSpan sp params
140+
traceWithSpan sp params
136141
let root = LSP.resRootPath env
137-
ide <- liftIO $ getIdeState env (makeLSPVFSHandle env) root
142+
143+
dir <- getCurrentDirectory
144+
dbLoc <- getHieDbLoc dir
145+
146+
-- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference
147+
-- to 'getIdeState', so we use this dirty trick
148+
dbMVar <- newEmptyMVar
149+
~(hiedb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar
150+
151+
ide <- getIdeState env (makeLSPVFSHandle env) root hiedb hieChan
138152

139153
let initConfig = parseConfiguration params
140-
liftIO $ logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig
141-
liftIO $ registerIdeConfiguration (shakeExtras ide) initConfig
154+
logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig
155+
registerIdeConfiguration (shakeExtras ide) initConfig
142156

143-
_ <- flip forkFinally (const exitClientMsg) $ forever $ do
157+
_ <- flip forkFinally (const exitClientMsg) $ runWithDb dbLoc $ \hiedb hieChan -> do
158+
putMVar dbMVar (hiedb,hieChan)
159+
forever $ do
144160
msg <- readChan clientMsgChan
145161
-- We dispatch notifications synchronously and requests asynchronously
146162
-- This is to ensure that all file edits and config changes are applied before a request is handled
@@ -158,20 +174,20 @@ runLanguageServer options onConfigurationChange userHandlers getIdeState = do
158174
:: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId
159175
-> IO () -> (ResponseError -> IO ()) -> IO ()
160176
checkCancelled ide clearReqId waitForCancel _id act k =
161-
flip finally (liftIO $ clearReqId _id) $
177+
flip finally (clearReqId _id) $
162178
catch (do
163179
-- We could optimize this by first checking if the id
164180
-- is in the cancelled set. However, this is unlikely to be a
165181
-- bottleneck and the additional check might hide
166182
-- issues with async exceptions that need to be fixed.
167-
cancelOrRes <- race (liftIO $ waitForCancel _id) act
183+
cancelOrRes <- race (waitForCancel _id) act
168184
case cancelOrRes of
169185
Left () -> do
170-
liftIO $ logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id
186+
logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id
171187
k $ ResponseError RequestCancelled "" Nothing
172188
Right res -> pure res
173189
) $ \(e :: SomeException) -> do
174-
liftIO $ logError (ideLogger ide) $ T.pack $
190+
logError (ideLogger ide) $ T.pack $
175191
"Unexpected exception on request, please report!\n" ++
176192
"Exception: " ++ show e
177193
k $ ResponseError InternalError (T.pack $ show e) Nothing

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

Lines changed: 14 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -37,9 +37,7 @@ import Development.IDE.Core.Rules (
3737
)
3838
import Development.IDE.Core.Service (initialise, runAction)
3939
import Development.IDE.Core.Shake (
40-
HieDb,
4140
IdeState (shakeExtras),
42-
IndexQueue,
4341
ShakeExtras (state),
4442
uses,
4543
)
@@ -49,7 +47,7 @@ import Development.IDE.Plugin (
4947
Plugin (pluginHandlers, pluginRules),
5048
)
5149
import Development.IDE.Plugin.HLS (asGhcIdePlugin)
52-
import Development.IDE.Session (SessionLoadingOptions, defaultLoadingOptions, loadSessionWithOptions, setInitialDynFlags)
50+
import Development.IDE.Session (SessionLoadingOptions, defaultLoadingOptions, loadSessionWithOptions, setInitialDynFlags, getHieDbLoc, runWithDb)
5351
import Development.IDE.Types.Location (toNormalizedFilePath')
5452
import Development.IDE.Types.Logger (Logger)
5553
import Development.IDE.Types.Options (
@@ -77,37 +75,34 @@ data Arguments = Arguments
7775
{ argsOTMemoryProfiling :: Bool
7876
, argFiles :: Maybe [FilePath] -- ^ Nothing: lsp server ; Just: typecheck and exit
7977
, argsLogger :: Logger
80-
, argsHiedb :: HieDb
81-
, argsHieChan :: IndexQueue
8278
, argsRules :: Rules ()
8379
, argsHlsPlugins :: IdePlugins IdeState
8480
, argsGhcidePlugin :: Plugin Config -- ^ Deprecated
8581
, argsSessionLoadingOptions :: SessionLoadingOptions
8682
, argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions
8783
, argsLspOptions :: LSP.Options
8884
, argsDefaultHlsConfig :: Config
85+
, argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project
8986
}
9087

91-
defArguments :: HieDb -> IndexQueue -> Arguments
92-
defArguments hiedb hiechan =
88+
defArguments :: Arguments
89+
defArguments =
9390
Arguments
9491
{ argsOTMemoryProfiling = False
9592
, argFiles = Nothing
9693
, argsLogger = noLogging
97-
, argsHiedb = hiedb
98-
, argsHieChan = hiechan
9994
, argsRules = mainRule >> action kick
10095
, argsGhcidePlugin = mempty
10196
, argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors
10297
, argsSessionLoadingOptions = defaultLoadingOptions
10398
, argsIdeOptions = const defaultIdeOptions
10499
, argsLspOptions = def {LSP.completionTriggerCharacters = Just "."}
105100
, argsDefaultHlsConfig = def
101+
, argsGetHieDbLoc = getHieDbLoc
106102
}
107103

108104
defaultMain :: Arguments -> IO ()
109105
defaultMain Arguments{..} = do
110-
dir <- IO.getCurrentDirectory
111106
pid <- T.pack . show <$> getProcessID
112107

113108
let hlsPlugin = asGhcIdePlugin argsHlsPlugins
@@ -121,10 +116,12 @@ defaultMain Arguments{..} = do
121116
t <- offsetTime
122117
hPutStrLn stderr "Starting LSP server..."
123118
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
124-
runLanguageServer options argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath -> do
119+
runLanguageServer options argsGetHieDbLoc argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do
125120
t <- t
126121
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
127122

123+
dir <- IO.getCurrentDirectory
124+
128125
-- We want to set the global DynFlags right now, so that we can use
129126
-- `unsafeGlobalDynFlags` even before the project is configured
130127
-- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')
@@ -148,9 +145,12 @@ defaultMain Arguments{..} = do
148145
debouncer
149146
options
150147
vfs
151-
argsHiedb
152-
argsHieChan
148+
hiedb
149+
hieChan
153150
Just argFiles -> do
151+
dir <- IO.getCurrentDirectory
152+
dbLoc <- getHieDbLoc dir
153+
runWithDb dbLoc $ \hiedb hieChan -> do
154154
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
155155
hSetEncoding stdout utf8
156156
hSetEncoding stderr utf8
@@ -178,7 +178,7 @@ defaultMain Arguments{..} = do
178178
{ optCheckParents = pure NeverCheck
179179
, optCheckProject = pure False
180180
}
181-
ide <- initialise mainRule Nothing argsLogger debouncer options vfs argsHiedb argsHieChan
181+
ide <- initialise mainRule Nothing argsLogger debouncer options vfs hiedb hieChan
182182

183183
putStrLn "\nStep 4/4: Type checking the files"
184184
setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files

‎ghcide/test/exe/Main.hs

Lines changed: 23 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4343,7 +4343,7 @@ cradleTests = testGroup "cradle"
43434343
[testGroup "dependencies" [sessionDepsArePickedUp]
43444344
,testGroup "ignore-fatal" [ignoreFatalWarning]
43454345
,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]
4346-
,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
4346+
,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiDefTest]
43474347
,testGroup "sub-directory" [simpleSubDirectoryTest]
43484348
]
43494349

@@ -4503,6 +4503,28 @@ simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \
45034503
checkDefs locs (pure [fooL])
45044504
expectNoMoreDiagnostics 0.5
45054505

4506+
-- Like simpleMultiTest but open the files in component 'a' in a seperate session
4507+
simpleMultiDefTest :: TestTree
4508+
simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do
4509+
let aPath = dir </> "a/A.hs"
4510+
bPath = dir </> "b/B.hs"
4511+
adoc <- liftIO $ runInDir dir $ do
4512+
aSource <- liftIO $ readFileUtf8 aPath
4513+
adoc <- createDoc aPath "haskell" aSource
4514+
~() <- skipManyTill anyMessage $ satisfyMaybe $ \case
4515+
FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do
4516+
A.Success fp' <- pure $ fromJSON fp
4517+
if equalFilePath fp' aPath then pure () else Nothing
4518+
_ -> Nothing
4519+
closeDoc adoc
4520+
pure adoc
4521+
bSource <- liftIO $ readFileUtf8 bPath
4522+
bdoc <- createDoc bPath "haskell" bSource
4523+
locs <- getDefinitions bdoc (Position 2 7)
4524+
let fooL = mkL (adoc ^. L.uri) 2 0 2 3
4525+
checkDefs locs (pure [fooL])
4526+
expectNoMoreDiagnostics 0.5
4527+
45064528
ifaceTests :: TestTree
45074529
ifaceTests = testGroup "Interface loading tests"
45084530
[ -- https://github.com/haskell/ghcide/pull/645/

‎src/Ide/Main.hs

Lines changed: 14 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ import Control.Monad.Extra
1616
import qualified Data.Map.Strict as Map
1717
import qualified Data.Text as T
1818
import Development.IDE.Core.Rules
19-
import Development.IDE.Session (setInitialDynFlags, getHieDbLoc, runWithDb)
19+
import Development.IDE.Session (setInitialDynFlags, getHieDbLoc)
2020
import Development.IDE.Types.Logger as G
2121
import qualified Language.LSP.Server as LSP
2222
import Ide.Arguments
@@ -83,7 +83,6 @@ runLspMode :: LspArguments -> IdePlugins IdeState -> IO ()
8383
runLspMode lspArgs@LspArguments{..} idePlugins = do
8484
whenJust argsCwd IO.setCurrentDirectory
8585
dir <- IO.getCurrentDirectory
86-
dbLoc <- getHieDbLoc dir
8786
LSP.setupLogger argsLogFile ["hls", "hie-bios"]
8887
$ if argsDebugOn then L.DEBUG else L.INFO
8988

@@ -94,17 +93,16 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do
9493
hPutStrLn stderr $ " in directory: " <> dir
9594
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
9695

97-
runWithDb dbLoc $ \hiedb hiechan ->
98-
Main.defaultMain (Main.defArguments hiedb hiechan)
99-
{ Main.argFiles = if argLSP then Nothing else Just []
100-
, Main.argsHlsPlugins = idePlugins
101-
, Main.argsLogger = hlsLogger
102-
, Main.argsIdeOptions = \_config sessionLoader ->
103-
let defOptions = Ghcide.defaultIdeOptions sessionLoader
104-
in defOptions
105-
{ Ghcide.optShakeProfiling = argsShakeProfiling
106-
, Ghcide.optTesting = Ghcide.IdeTesting argsTesting
107-
, Ghcide.optShakeOptions = (Ghcide.optShakeOptions defOptions)
108-
{shakeThreads = argsThreads}
109-
}
110-
}
96+
Main.defaultMain Main.defArguments
97+
{ Main.argFiles = if argLSP then Nothing else Just []
98+
, Main.argsHlsPlugins = idePlugins
99+
, Main.argsLogger = hlsLogger
100+
, Main.argsIdeOptions = \_config sessionLoader ->
101+
let defOptions = Ghcide.defaultIdeOptions sessionLoader
102+
in defOptions
103+
{ Ghcide.optShakeProfiling = argsShakeProfiling
104+
, Ghcide.optTesting = Ghcide.IdeTesting argsTesting
105+
, Ghcide.optShakeOptions = (Ghcide.optShakeOptions defOptions)
106+
{shakeThreads = argsThreads}
107+
}
108+
}

0 commit comments

Comments
 (0)