Merge branch 'master' into lsp-1.1.1

mergify[bot] · web-flow · commit dfb91a09a000 · 2021-02-15T22:48:28.000Z
diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml
@@ -105,7 +105,7 @@
 #
 - functions:
   # Things that are unsafe in Haskell base library
-  - {name: unsafeInterleaveIO, within: []}
+  - {name: unsafeInterleaveIO, within: [Development.IDE.LSP.LanguageServer]}
   - {name: unsafeDupablePerformIO, within: []}
   - {name: unsafeCoerce, within: []}
   # Things that are a bit dangerous in the GHC API
diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs
@@ -20,7 +20,7 @@ import Development.IDE.Core.OfInterest (kick)
 import Development.IDE.Core.Rules (mainRule)
 import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
 import qualified Development.IDE.Plugin.Test as Test
-import Development.IDE.Session (setInitialDynFlags, getHieDbLoc, runWithDb)
+import Development.IDE.Session (setInitialDynFlags, getHieDbLoc)
 import Development.IDE.Types.Options
 import qualified Development.IDE.Main as Main
 import Development.Shake (ShakeOptions(shakeThreads))
@@ -56,9 +56,6 @@ main = do
 
     whenJust argsCwd IO.setCurrentDirectory
 
-    dir <- IO.getCurrentDirectory
-    dbLoc <- getHieDbLoc dir
-
     -- lock to avoid overlapping output on stdout
     lock <- newLock
     let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $
@@ -67,6 +64,8 @@ main = do
 
     case argFilesOrCmd of
       DbCmd opts cmd -> do
+        dir <- IO.getCurrentDirectory
+        dbLoc <- getHieDbLoc dir
         mlibdir <- setInitialDynFlags
         case mlibdir of
           Nothing -> exitWith $ ExitFailure 1
@@ -80,40 +79,39 @@ main = do
                 hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
               _ -> return ()
 
-          runWithDb dbLoc $ \hiedb hiechan ->
-              Main.defaultMain (Main.defArguments hiedb hiechan)
-                {Main.argFiles = case argFilesOrCmd of
-                    Typecheck x | not argLSP -> Just x
-                    _ -> Nothing
-
-                ,Main.argsLogger = logger
-
-                ,Main.argsRules = do
-                    -- install the main and ghcide-plugin rules
-                    mainRule
-                    -- install the kick action, which triggers a typecheck on every
-                    -- Shake database restart, i.e. on every user edit.
-                    unless argsDisableKick $
-                        action kick
-
-                ,Main.argsHlsPlugins =
-                    pluginDescToIdePlugins $
-                    GhcIde.descriptors
-                    ++ [Test.blockCommandDescriptor "block-command" | argsTesting]
-
-                ,Main.argsGhcidePlugin = if argsTesting
-                    then Test.plugin
-                    else mempty
-
-                ,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader ->
-                    let defOptions = defaultIdeOptions sessionLoader
-                    in defOptions
-                      { optShakeProfiling = argsShakeProfiling
-                      , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
-                      , optTesting = IdeTesting argsTesting
-                      , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
-                      , optCheckParents = pure $ checkParents config
-                      , optCheckProject = pure $ checkProject config
-                      }
-                }
+          Main.defaultMain Main.defArguments
+            {Main.argFiles = case argFilesOrCmd of
+                Typecheck x | not argLSP -> Just x
+                _ -> Nothing
+
+            ,Main.argsLogger = logger
+
+            ,Main.argsRules = do
+                -- install the main and ghcide-plugin rules
+                mainRule
+                -- install the kick action, which triggers a typecheck on every
+                -- Shake database restart, i.e. on every user edit.
+                unless argsDisableKick $
+                    action kick
+
+            ,Main.argsHlsPlugins =
+                pluginDescToIdePlugins $
+                GhcIde.descriptors
+                ++ [Test.blockCommandDescriptor "block-command" | argsTesting]
+
+            ,Main.argsGhcidePlugin = if argsTesting
+                then Test.plugin
+                else mempty
+
+            ,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader ->
+                let defOptions = defaultIdeOptions sessionLoader
+                in defOptions
+                  { optShakeProfiling = argsShakeProfiling
+                  , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
+                  , optTesting = IdeTesting argsTesting
+                  , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
+                  , optCheckParents = pure $ checkParents config
+                  , optCheckProject = pure $ checkProject config
+                  }
+            }
 
diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs
@@ -28,9 +28,11 @@ import Control.Monad.Extra
 import UnliftIO.Exception
 import UnliftIO.Async
 import UnliftIO.Concurrent
+import UnliftIO.Directory
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 import Ide.Types (traceWithSpan)
+import Development.IDE.Session (runWithDb)
 
 import Development.IDE.Core.IdeConfiguration
 import Development.IDE.Core.Shake
@@ -40,14 +42,17 @@ import Development.IDE.Types.Logger
 import Development.IDE.Core.FileStore
 import Development.IDE.Core.Tracing
 
+import System.IO.Unsafe (unsafeInterleaveIO)
+
 runLanguageServer
     :: forall config. (Show config)
     => LSP.Options
+    -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
     -> (IdeState -> Value -> IO (Either T.Text config))
     -> LSP.Handlers (ServerM config)
-    -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> IO IdeState)
+    -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState)
     -> IO ()
-runLanguageServer options onConfigurationChange userHandlers getIdeState = do
+runLanguageServer options getHieDbLoc onConfigurationChange userHandlers getIdeState = do
     -- Move stdout to another file descriptor and duplicate stderr
     -- to stdout. This guards against stray prints from corrupting the JSON-RPC
     -- message stream.
@@ -132,15 +137,26 @@ runLanguageServer options onConfigurationChange userHandlers getIdeState = do
           :: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage
           -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
         handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
-            liftIO $ traceWithSpan sp params
+            traceWithSpan sp params
             let root = LSP.resRootPath env
-            ide <- liftIO $ getIdeState env (makeLSPVFSHandle env) root
+
+            dir <- getCurrentDirectory
+            dbLoc <- getHieDbLoc dir
+
+            -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference
+            -- to 'getIdeState', so we use this dirty trick
+            dbMVar <- newEmptyMVar
+            ~(hiedb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar
+
+            ide <- getIdeState env (makeLSPVFSHandle env) root hiedb hieChan
 
             let initConfig = parseConfiguration params
-            liftIO $ logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig
-            liftIO $ registerIdeConfiguration (shakeExtras ide) initConfig
+            logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig
+            registerIdeConfiguration (shakeExtras ide) initConfig
 
-            _ <- flip forkFinally (const exitClientMsg) $ forever $ do
+            _ <- flip forkFinally (const exitClientMsg) $ runWithDb dbLoc $ \hiedb hieChan -> do
+              putMVar dbMVar (hiedb,hieChan)
+              forever $ do
                 msg <- readChan clientMsgChan
                 -- We dispatch notifications synchronously and requests asynchronously
                 -- 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
           :: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId
           -> IO () -> (ResponseError -> IO ()) -> IO ()
         checkCancelled ide clearReqId waitForCancel _id act k =
-            flip finally (liftIO $ clearReqId _id) $
+            flip finally (clearReqId _id) $
                 catch (do
                     -- We could optimize this by first checking if the id
                     -- is in the cancelled set. However, this is unlikely to be a
                     -- bottleneck and the additional check might hide
                     -- issues with async exceptions that need to be fixed.
-                    cancelOrRes <- race (liftIO $ waitForCancel _id) act
+                    cancelOrRes <- race (waitForCancel _id) act
                     case cancelOrRes of
                         Left () -> do
-                            liftIO $ logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id
+                            logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id
                             k $ ResponseError RequestCancelled "" Nothing
                         Right res -> pure res
                 ) $ \(e :: SomeException) -> do
-                    liftIO $ logError (ideLogger ide) $ T.pack $
+                    logError (ideLogger ide) $ T.pack $
                         "Unexpected exception on request, please report!\n" ++
                         "Exception: " ++ show e
                     k $ ResponseError InternalError (T.pack $ show e) Nothing
diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs
@@ -37,9 +37,7 @@ import Development.IDE.Core.Rules (
  )
 import Development.IDE.Core.Service (initialise, runAction)
 import Development.IDE.Core.Shake (
-    HieDb,
     IdeState (shakeExtras),
-    IndexQueue,
     ShakeExtras (state),
     uses,
  )
@@ -49,7 +47,7 @@ import Development.IDE.Plugin (
     Plugin (pluginHandlers, pluginRules),
  )
 import Development.IDE.Plugin.HLS (asGhcIdePlugin)
-import Development.IDE.Session (SessionLoadingOptions, defaultLoadingOptions, loadSessionWithOptions, setInitialDynFlags)
+import Development.IDE.Session (SessionLoadingOptions, defaultLoadingOptions, loadSessionWithOptions, setInitialDynFlags, getHieDbLoc, runWithDb)
 import Development.IDE.Types.Location (toNormalizedFilePath')
 import Development.IDE.Types.Logger (Logger)
 import Development.IDE.Types.Options (
@@ -77,37 +75,34 @@ data Arguments = Arguments
     { argsOTMemoryProfiling :: Bool
     , argFiles :: Maybe [FilePath]   -- ^ Nothing: lsp server ;  Just: typecheck and exit
     , argsLogger :: Logger
-    , argsHiedb :: HieDb
-    , argsHieChan :: IndexQueue
     , argsRules :: Rules ()
     , argsHlsPlugins :: IdePlugins IdeState
     , argsGhcidePlugin :: Plugin Config  -- ^ Deprecated
     , argsSessionLoadingOptions :: SessionLoadingOptions
     , argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions
     , argsLspOptions :: LSP.Options
     , argsDefaultHlsConfig :: Config
+    , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project
     }
 
-defArguments :: HieDb -> IndexQueue -> Arguments
-defArguments hiedb hiechan =
+defArguments :: Arguments
+defArguments =
     Arguments
         { argsOTMemoryProfiling = False
         , argFiles = Nothing
         , argsLogger = noLogging
-        , argsHiedb = hiedb
-        , argsHieChan = hiechan
         , argsRules = mainRule >> action kick
         , argsGhcidePlugin = mempty
         , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors
         , argsSessionLoadingOptions = defaultLoadingOptions
         , argsIdeOptions = const defaultIdeOptions
         , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."}
         , argsDefaultHlsConfig = def
+        , argsGetHieDbLoc = getHieDbLoc
         }
 
 defaultMain :: Arguments -> IO ()
 defaultMain Arguments{..} = do
-    dir <- IO.getCurrentDirectory
     pid <- T.pack . show <$> getProcessID
 
     let hlsPlugin = asGhcIdePlugin argsHlsPlugins
@@ -121,10 +116,12 @@ defaultMain Arguments{..} = do
             t <- offsetTime
             hPutStrLn stderr "Starting LSP server..."
             hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
-            runLanguageServer options argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath -> do
+            runLanguageServer options argsGetHieDbLoc argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do
                 t <- t
                 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
 
+                dir <- IO.getCurrentDirectory
+
                 -- We want to set the global DynFlags right now, so that we can use
                 -- `unsafeGlobalDynFlags` even before the project is configured
                 -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')
@@ -148,9 +145,12 @@ defaultMain Arguments{..} = do
                     debouncer
                     options
                     vfs
-                    argsHiedb
-                    argsHieChan
+                    hiedb
+                    hieChan
         Just argFiles -> do
+          dir <- IO.getCurrentDirectory
+          dbLoc <- getHieDbLoc dir
+          runWithDb dbLoc $ \hiedb hieChan -> do
             -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
             hSetEncoding stdout utf8
             hSetEncoding stderr utf8
@@ -178,7 +178,7 @@ defaultMain Arguments{..} = do
                         { optCheckParents = pure NeverCheck
                         , optCheckProject = pure False
                         }
-            ide <- initialise mainRule Nothing argsLogger debouncer options vfs argsHiedb argsHieChan
+            ide <- initialise mainRule Nothing argsLogger debouncer options vfs hiedb hieChan
 
             putStrLn "\nStep 4/4: Type checking the files"
             setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files
diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
@@ -4343,7 +4343,7 @@ cradleTests = testGroup "cradle"
     [testGroup "dependencies" [sessionDepsArePickedUp]
     ,testGroup "ignore-fatal" [ignoreFatalWarning]
     ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]
-    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2]
+    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2, simpleMultiDefTest]
     ,testGroup "sub-directory"   [simpleSubDirectoryTest]
     ]
 
@@ -4503,6 +4503,28 @@ simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \
     checkDefs locs (pure [fooL])
     expectNoMoreDiagnostics 0.5
 
+-- Like simpleMultiTest but open the files in component 'a' in a seperate session
+simpleMultiDefTest :: TestTree
+simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do
+    let aPath = dir </> "a/A.hs"
+        bPath = dir </> "b/B.hs"
+    adoc <- liftIO $ runInDir dir $ do
+      aSource <- liftIO $ readFileUtf8 aPath
+      adoc <- createDoc aPath "haskell" aSource
+      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case
+        FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do
+          A.Success fp' <- pure $ fromJSON fp
+          if equalFilePath fp' aPath then pure () else Nothing
+        _ -> Nothing
+      closeDoc adoc
+      pure adoc
+    bSource <- liftIO $ readFileUtf8 bPath
+    bdoc <- createDoc bPath "haskell" bSource
+    locs <- getDefinitions bdoc (Position 2 7)
+    let fooL = mkL (adoc ^. L.uri) 2 0 2 3
+    checkDefs locs (pure [fooL])
+    expectNoMoreDiagnostics 0.5
+
 ifaceTests :: TestTree
 ifaceTests = testGroup "Interface loading tests"
     [ -- https://github.com/haskell/ghcide/pull/645/
diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs
@@ -16,7 +16,7 @@ import Control.Monad.Extra
 import qualified Data.Map.Strict as Map
 import qualified Data.Text as T
 import Development.IDE.Core.Rules
-import Development.IDE.Session (setInitialDynFlags, getHieDbLoc, runWithDb)
+import Development.IDE.Session (setInitialDynFlags, getHieDbLoc)
 import Development.IDE.Types.Logger as G
 import qualified Language.LSP.Server as LSP
 import Ide.Arguments
@@ -83,7 +83,6 @@ runLspMode :: LspArguments -> IdePlugins IdeState -> IO ()
 runLspMode lspArgs@LspArguments{..} idePlugins = do
     whenJust argsCwd IO.setCurrentDirectory
     dir <- IO.getCurrentDirectory
-    dbLoc <- getHieDbLoc dir
     LSP.setupLogger argsLogFile ["hls", "hie-bios"]
       $ if argsDebugOn then L.DEBUG else L.INFO
 
@@ -94,17 +93,16 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do
         hPutStrLn stderr $ "  in directory: " <> dir
         hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
 
-    runWithDb dbLoc $ \hiedb hiechan ->
-        Main.defaultMain (Main.defArguments hiedb hiechan)
-          { Main.argFiles = if argLSP then Nothing else Just []
-          , Main.argsHlsPlugins = idePlugins
-          , Main.argsLogger = hlsLogger
-          , Main.argsIdeOptions = \_config sessionLoader ->
-            let defOptions = Ghcide.defaultIdeOptions sessionLoader
-            in defOptions
-                { Ghcide.optShakeProfiling = argsShakeProfiling
-                , Ghcide.optTesting = Ghcide.IdeTesting argsTesting
-                , Ghcide.optShakeOptions = (Ghcide.optShakeOptions defOptions)
-                    {shakeThreads = argsThreads}
-                }
-          }
+    Main.defaultMain Main.defArguments
+      { Main.argFiles = if argLSP then Nothing else Just []
+      , Main.argsHlsPlugins = idePlugins
+      , Main.argsLogger = hlsLogger
+      , Main.argsIdeOptions = \_config sessionLoader ->
+        let defOptions = Ghcide.defaultIdeOptions sessionLoader
+        in defOptions
+            { Ghcide.optShakeProfiling = argsShakeProfiling
+            , Ghcide.optTesting = Ghcide.IdeTesting argsTesting
+            , Ghcide.optShakeOptions = (Ghcide.optShakeOptions defOptions)
+                {shakeThreads = argsThreads}
+            }
+      }

Original file line number	Diff line number	Diff line change
`@@ -105,7 +105,7 @@`
`105`	`105`	`#`
`106`	`106`	`- functions:`
`107`	`107`	`# Things that are unsafe in Haskell base library`
`108`		`- - {name: unsafeInterleaveIO, within: []}`
	`108`	`+ - {name: unsafeInterleaveIO, within: [Development.IDE.LSP.LanguageServer]}`
`109`	`109`	`- {name: unsafeDupablePerformIO, within: []}`
`110`	`110`	`- {name: unsafeCoerce, within: []}`
`111`	`111`	`# Things that are a bit dangerous in the GHC API`