diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 1829f648ff..2e3099223b 100644 --- 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 index bcd93bca25..09bae9405e 100644 --- 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 index bc5780e1b1..d8f9c1a1a8 100644 --- 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 index 4164ce201f..01e4a14743 100644 --- 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,8 +75,6 @@ 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 @@ -86,16 +82,15 @@ data Arguments = Arguments , 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 @@ -103,11 +98,11 @@ defArguments hiedb hiechan = , 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 index a3c5e0f523..831acf2e93 100644 --- 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 index ee36576843..09157fed9e 100644 --- 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} + } + }