diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +### 0.7.5 (2021-02-??) +* Tone down some logInfos to logDebug (#1385) - Pepe Iborra +* Show window message when auto extending import lists (#1371) - Potato Hatsue +* Catch GHC errors in listing module names (#1367) - Potato Hatsue +* Upgrade to lsp-1.0 (#1284) - wz1000 +* Added Development.IDE.Main (#1338) - Pepe Iborra +* Fix completion snippets on DuplicateRecordFields (#1360) - Potato Hatsue +* Add code action for hiding shadowed identifiers from imports (#1322) - Potato Hatsue +* Make find-definition work better with multi-components (#1357) - wz1000 +* Index files on first open (#1358) - wz1000 +* Fix code actions regression (#1349) - Pepe Iborra + ### 0.7.4 (2021-02-08) * Support for references via hiedb (#704) - wz1000 * Fix space leak on cradle reloads (#1316) - Pepe Iborra diff --git a/bench/hist/Main.hs b/bench/hist/Main.hs --- a/bench/hist/Main.hs +++ b/bench/hist/Main.hs @@ -55,6 +55,7 @@ import System.Console.GetOpt import Data.Maybe import Control.Monad.Extra +import System.FilePath configPath :: FilePath @@ -84,7 +85,12 @@ _ -> want wants ghcideBuildRules :: MkBuildRules BuildSystem -ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" buildGhcide +ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" projectDepends buildGhcide + where + projectDepends = do + need . map ("src" ) =<< getDirectoryFiles "src" ["//*.hs"] + need . map ("session-loader" ) =<< getDirectoryFiles "session-loader" ["//*.hs"] + need =<< getDirectoryFiles "." ["*.cabal"] -------------------------------------------------------------------------------- @@ -116,7 +122,7 @@ let build = outputFolder configStatic buildRules build ghcideBuildRules - benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchGhcide "ghcide") + benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchGhcide warmupGhcide "ghcide") csvRules build svgRules build heapProfileRules build @@ -141,6 +147,7 @@ ,"--install-method=copy" ,"--overwrite-policy=always" ,"--ghc-options=-rtsopts" + ,"--ghc-options=-eventlog" ] buildGhcide Stack args out = @@ -150,6 +157,7 @@ ,"ghcide:ghcide" ,"--copy-bins" ,"--ghc-options=-rtsopts" + ,"--ghc-options=-eventlog" ] benchGhcide @@ -170,3 +178,15 @@ [ "--stack" | Stack == buildSystem ] +warmupGhcide :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action () +warmupGhcide buildSystem exePath args example = do + command args "ghcide-bench" $ + [ "--no-clean", + "-v", + "--samples=1", + "--ghcide=" <> exePath, + "--select=hover" + ] ++ + exampleToOptions example ++ + [ "--stack" | Stack == buildSystem + ] diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -1,7 +1,9 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} module Experiments ( Bench(..) @@ -20,19 +22,19 @@ , exampleToOptions ) where import Control.Applicative.Combinators (skipManyTill) -import Control.Exception.Safe +import Control.Exception.Safe (IOException, handleAny, try) import Control.Monad.Extra import Control.Monad.IO.Class -import Data.Aeson (Value(Null)) +import Data.Aeson (Value(Null), toJSON) import Data.List import Data.Maybe import qualified Data.Text as T import Data.Version import Development.IDE.Plugin.Test import Experiments.Types -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Capabilities import Numeric.Natural import Options.Applicative import System.Directory @@ -41,6 +43,7 @@ import System.Process import System.Time.Extra import Text.ParserCombinators.ReadP (readP_to_S) +import Development.Shake (cmd_, CmdOption (Cwd, FileStdout)) charEdit :: Position -> TextDocumentContentChangeEvent charEdit p = @@ -78,13 +81,13 @@ isJust <$> getHover doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} -> - not . null <$> getDefinitions doc (fromJust identifierP), + either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "getDefinition after edit" $ \docs -> do forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - not . null <$> getDefinitions doc (fromJust identifierP), + either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc, @@ -147,7 +150,7 @@ ( \docs -> do Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml" liftIO $ appendFile hieYaml "##\n" - sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] @@ -162,7 +165,7 @@ (\docs -> do Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml" liftIO $ appendFile hieYaml "##\n" - sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP) ) @@ -358,7 +361,9 @@ waitForProgressDone = loop where loop = do - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -392,8 +397,9 @@ else do output (showDuration t) -- Wait for the delayed actions to finish - waitId <- sendRequest (CustomClientMethod "test") WaitForShakeQueue - (td, resp) <- duration $ skipManyTill anyMessage $ responseForId waitId + let m = SCustomMethod "test" + waitId <- sendRequest m (toJSON WaitForShakeQueue) + (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId case resp of ResponseMessage{_result=Right Null} -> do loop (userWaits+t) (delayedWork+td) (n -1) @@ -423,19 +429,24 @@ setup = do -- when alreadyExists $ removeDirectoryRecursive examplesPath benchDir <- case example ?config of - UsePackage{..} -> return examplePath + UsePackage{..} -> do + let hieYamlPath = examplePath "hie.yaml" + alreadyExists <- doesFileExist hieYamlPath + unless alreadyExists $ + cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String) + return examplePath GetPackage{..} -> do let path = examplesPath package package = exampleName <> "-" <> showVersion exampleVersion + hieYamlPath = path "hie.yaml" alreadySetup <- doesDirectoryExist path unless alreadySetup $ case buildTool ?config of Cabal -> do let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config)) callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath - writeFile - (path "hie.yaml") - ("cradle: {cabal: {component: " <> exampleName <> "}}") + let hieYamlPath = path "hie.yaml" + cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) -- Need this in case there is a parent cabal.project somewhere writeFile (path "cabal.project") @@ -464,9 +475,7 @@ ] ) - writeFile - (path "hie.yaml") - ("cradle: {stack: {component: " <> show (exampleName <> ":lib") <> "}}") + cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) ["--stack"::String] return path whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True @@ -498,22 +507,21 @@ -- Find an identifier defined in another file in this project symbols <- getDocumentSymbols doc - case symbols of - Left [DocumentSymbol{_children = Just (List symbols)}] -> do - let endOfImports = case symbols of - DocumentSymbol{_kind = SkModule, _name = "imports", _range } : _ -> - Position (succ $ _line $ _end _range) 4 - DocumentSymbol{_range} : _ -> _start _range - [] -> error "Module has no symbols" - contents <- documentContents doc - - identifierP <- searchSymbol doc contents endOfImports - - return $ DocumentPositions{..} - other -> - error $ "symbols: " <> show other - + let endOfImports = case symbols of + Left symbols | Just x <- findEndOfImports symbols -> x + _ -> error $ "symbols: " <> show symbols + contents <- documentContents doc + identifierP <- searchSymbol doc contents endOfImports + return $ DocumentPositions{..} +findEndOfImports :: [DocumentSymbol] -> Maybe Position +findEndOfImports (DocumentSymbol{_kind = SkModule, _name = "imports", _range} : _) = + Just $ Position (succ $ _line $ _end _range) 4 +findEndOfImports [DocumentSymbol{_kind = SkFile, _children = Just (List cc)}] = + findEndOfImports cc +findEndOfImports (DocumentSymbol{_range} : _) = + Just $ _start _range +findEndOfImports _ = Nothing -------------------------------------------------------------------------------------------- @@ -559,7 +567,7 @@ checkDefinitions pos = do defs <- getDefinitions doc pos case defs of - [Location uri _] -> return $ uri /= _uri + (InL [Location uri _]) -> return $ uri /= _uri _ -> return False checkCompletions pos = not . null <$> getCompletions doc pos diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -5,61 +5,34 @@ module Main(main) where -import Arguments -import Control.Concurrent.Extra -import Control.Monad.Extra -import Control.Exception.Safe -import Control.Lens ( (^.) ) -import Data.Default -import Data.List.Extra -import Data.Maybe +import Arguments ( Arguments'(..), IdeCmd(..), getArguments ) +import Control.Concurrent.Extra ( newLock, withLock ) +import Control.Monad.Extra ( unless, when, whenJust ) +import Data.Default ( Default(def) ) +import Data.List.Extra ( upper ) +import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Version -import Development.IDE.Core.Debouncer -import Development.IDE.Core.FileStore -import Development.IDE.Core.OfInterest -import Development.IDE.Core.Service -import Development.IDE.Core.Rules -import Development.IDE.Core.Shake -import Development.IDE.Core.RuleTypes -import Development.IDE.LSP.Protocol -import Development.IDE.Types.Location -import Development.IDE.Types.Diagnostics +import Data.Version ( showVersion ) +import Development.GitRev ( gitHash ) +import Development.IDE ( Logger(Logger), Priority(Info), action ) +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) import Development.IDE.Types.Options -import Development.IDE.Types.Logger -import Development.IDE.Plugin -import Development.IDE.Plugin.Test as Test -import Development.IDE.Session (loadSession, setInitialDynFlags, getHieDbLoc, runWithDb) -import Development.Shake (ShakeOptions (shakeThreads)) -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens (params, initializationOptions) -import Development.IDE.LSP.LanguageServer -import qualified System.Directory.Extra as IO -import System.Environment -import System.IO -import System.Info -import System.Exit -import System.FilePath -import System.Time.Extra -import Paths_ghcide -import Development.GitRev -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Aeson as J - -import HIE.Bios.Cradle -import Development.IDE (action) -import Text.Printf -import Development.IDE.Core.Tracing -import Development.IDE.Types.Shake (Key(Key)) -import Development.IDE.Plugin.HLS (asGhcIdePlugin) -import Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Ide.Plugin.Config -import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins) - +import qualified Development.IDE.Main as Main +import Development.Shake (ShakeOptions(shakeThreads)) +import Ide.Plugin.Config (Config(checkParents, checkProject)) +import Ide.PluginUtils (pluginDescToIdePlugins) import HieDb.Run (Options(..), runCommand) +import Paths_ghcide ( version ) +import qualified System.Directory.Extra as IO +import System.Environment ( getExecutablePath ) +import System.Exit ( ExitCode(ExitFailure), exitSuccess, exitWith ) +import System.Info ( compilerVersion ) +import System.IO ( stderr, hPutStrLn ) ghcideVersion :: IO String ghcideVersion = do @@ -83,171 +56,62 @@ 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 $ + T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg + logLevel = if argsVerbose then minBound else Info case argFilesOrCmd of DbCmd opts cmd -> do - mlibdir <- setInitialDynFlags + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir + mlibdir <- setInitialDynFlags def case mlibdir of Nothing -> exitWith $ ExitFailure 1 - Just libdir -> - runCommand libdir opts{database = dbLoc} cmd - Typecheck (Just -> argFilesOrCmd) | not argLSP -> runWithDb dbLoc $ runIde Arguments{..} - _ -> let argFilesOrCmd = Nothing in runWithDb dbLoc $ runIde Arguments{..} - - -runIde :: Arguments' (Maybe [FilePath]) -> HieDb -> IndexQueue -> IO () -runIde Arguments{..} hiedb hiechan = do - -- lock to avoid overlapping output on stdout - lock <- newLock - let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $ - T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg - - dir <- IO.getCurrentDirectory + Just libdir -> runCommand libdir opts{database = dbLoc} cmd - let hlsPlugins = pluginDescToIdePlugins $ - GhcIde.descriptors ++ - [ Test.blockCommandDescriptor "block-command" | argsTesting] + _ -> do - pid <- T.pack . show <$> getProcessID - let hlsPlugin = asGhcIdePlugin hlsPlugins - hlsCommands = allLspCmdIds' pid hlsPlugins + case argFilesOrCmd of + LSP -> do + 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!" + _ -> return () - let plugins = hlsPlugin - <> if argsTesting then Test.plugin else mempty - onInitialConfiguration :: InitializeRequest -> Either T.Text Config - onInitialConfiguration x = case x ^. params . initializationOptions of - Nothing -> Right def - Just v -> case J.fromJSON v of - J.Error err -> Left $ T.pack err - J.Success a -> Right a - onConfigurationChange = const $ Left "Updating Not supported" - options = def { LSP.executeCommandCommands = Just hlsCommands - , LSP.completionTriggerCharacters = Just "." - } - case argFilesOrCmd of - Nothing -> 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 (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg getConfig rootPath -> do - t <- t - hPutStrLn stderr $ "Started LSP server in " ++ showDuration t + Main.defaultMain def + {Main.argFiles = case argFilesOrCmd of + Typecheck x | not argLSP -> Just x + _ -> Nothing - -- 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') - -- before calling this function - _mlibdir <- setInitialDynFlags - `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) + ,Main.argsLogger = logger - sessionLoader <- loadSession $ fromMaybe dir rootPath - config <- fromMaybe def <$> getConfig - let options = defOptions - { optReportProgress = clientSupportsProgress caps - , optShakeProfiling = argsShakeProfiling - , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling - , optTesting = IdeTesting argsTesting - , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} - , optCheckParents = checkParents config - , optCheckProject = checkProject config - } - defOptions = defaultIdeOptions sessionLoader - logLevel = if argsVerbose then minBound else Info - debouncer <- newAsyncDebouncer - let rules = do - -- install the main and ghcide-plugin rules - mainRule - pluginRules plugins - -- install the kick action, which triggers a typecheck on every - -- Shake database restart, i.e. on every user edit. - unless argsDisableKick $ + ,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 - initialise caps rules - getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs hiedb hiechan - Just argFiles -> do - -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - putStrLn $ "Ghcide setup tester in " ++ dir ++ "." - putStrLn "Report bugs at https://github.com/haskell/ghcide/issues" - - putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir - files <- expandFiles (argFiles ++ ["." | null argFiles]) - -- LSP works with absolute file paths, so try and behave similarly - files <- nubOrd <$> mapM IO.canonicalizePath files - putStrLn $ "Found " ++ show (length files) ++ " files" - - putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup" - cradles <- mapM findCradle files - let ucradles = nubOrd cradles - let n = length ucradles - putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] - when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" - putStrLn "\nStep 3/4: Initializing the IDE" - vfs <- makeVFSHandle - debouncer <- newAsyncDebouncer - let dummyWithProg _ _ f = f (const (pure ())) - sessionLoader <- loadSession dir - let options = defOptions - { optShakeProfiling = argsShakeProfiling - -- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling - , optTesting = IdeTesting argsTesting - , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} - , optCheckParents = NeverCheck - , optCheckProject = False - } - defOptions = defaultIdeOptions sessionLoader - logLevel = if argsVerbose then minBound else Info - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs hiedb hiechan - - putStrLn "\nStep 4/4: Type checking the files" - setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files - results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files) - _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files) - _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files) - let (worked, failed) = partition fst $ zip (map isJust results) files - when (failed /= []) $ - putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed - - let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" - putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" - - when argsOTMemoryProfiling $ do - let valuesRef = state $ shakeExtras ide - values <- readVar valuesRef - let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6) - consoleObserver (Just k) = return $ \size -> printf " - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3) - - printf "# Shake value store contents(%d):\n" (length values) - let keys = nub - $ Key GhcSession : Key GhcSessionDeps - : [ k | (_,k) <- HashMap.keys values, k /= Key GhcSessionIO] - ++ [Key GhcSessionIO] - measureMemory (logger logLevel) [keys] consoleObserver valuesRef - - unless (null failed) (exitWith $ ExitFailure (length failed)) + ,Main.argsHlsPlugins = + pluginDescToIdePlugins $ + GhcIde.descriptors + ++ [Test.blockCommandDescriptor "block-command" | argsTesting] -{-# ANN runIde ("HLint: ignore Use nubOrd" :: String) #-} + ,Main.argsGhcidePlugin = if argsTesting + then Test.plugin + else mempty -expandFiles :: [FilePath] -> IO [FilePath] -expandFiles = concatMapM $ \x -> do - b <- IO.doesFileExist x - if b then return [x] else do - let recurse "." = True - recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc - recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories - files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x - when (null files) $ - fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x - return files + ,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 + } + } --- | Print an LSP event. -showEvent :: Lock -> FromServerMessage -> IO () -showEvent _ (EventFileDiagnostics _ []) = return () -showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) = - withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags -showEvent lock e = withLock lock $ print e diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 0.7.4.0 +version: 0.7.5.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -13,7 +13,7 @@ A library for building Haskell IDE's on top of the GHC API. homepage: https://github.com/haskell/ghcide#readme bug-reports: https://github.com/haskell/ghcide/issues -tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.1 || == 8.10.2 || == 8.10.3 +tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md test/data/hover/*.hs test/data/multi/cabal.project @@ -27,11 +27,6 @@ type: git location: https://github.com/haskell/ghcide.git -flag ghc-lib - description: build against ghc-lib instead of the ghc package - default: False - manual: True - library default-language: Haskell2010 build-depends: @@ -46,6 +41,8 @@ data-default, deepseq, directory, + dependent-map, + dependent-sum, dlist, extra >= 1.7.4, fuzzy, @@ -55,12 +52,12 @@ Glob, haddock-library >= 1.8, hashable, - haskell-lsp-types == 0.23.*, - haskell-lsp == 0.23.*, hie-compat, - hls-plugin-api >= 0.7, + hls-plugin-api >= 0.7.1, lens, hiedb == 0.3.0.1, + lsp-types == 1.1.*, + lsp == 1.1.1.0, mtl, network-uri, parallel, @@ -88,19 +85,12 @@ vector, bytestring-encoding, opentelemetry >=0.6.1, - heapsize ==0.3.* - if flag(ghc-lib) - build-depends: - ghc-lib >= 8.8, - ghc-lib-parser >= 8.8 - cpp-options: -DGHC_LIB - else - build-depends: + heapsize ==0.3.*, + unliftio, + unliftio-core, ghc-boot-th, ghc-boot, ghc >= 8.6, - -- These dependencies are used by Development.IDE.Session and are - -- Haskell specific. So don't use them when building with -fghc-lib! ghc-check >=0.5.0.1, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12, @@ -131,13 +121,18 @@ TupleSections TypeApplications ViewPatterns + DataKinds + TypeOperators + KindSignatures hs-source-dirs: src + session-loader include-dirs: include exposed-modules: Development.IDE + Development.IDE.Main Development.IDE.Core.Debouncer Development.IDE.Core.FileStore Development.IDE.Core.IdeConfiguration @@ -150,16 +145,18 @@ Development.IDE.Core.Shake Development.IDE.Core.Tracing Development.IDE.GHC.Compat + Development.IDE.Core.Compile Development.IDE.GHC.Error Development.IDE.GHC.ExactPrint Development.IDE.GHC.Orphans Development.IDE.GHC.Util Development.IDE.Import.DependencyInformation + Development.IDE.Import.FindImports Development.IDE.LSP.HoverDefinition Development.IDE.LSP.LanguageServer Development.IDE.LSP.Outline - Development.IDE.LSP.Protocol Development.IDE.LSP.Server + Development.IDE.Session Development.IDE.Spans.Common Development.IDE.Spans.Documentation Development.IDE.Spans.AtPoint @@ -182,31 +179,16 @@ Development.IDE.Plugin.Test Development.IDE.Plugin.TypeLenses - -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses - -- the real GHC library and the types are incompatible. Furthermore, when - -- building with ghc-lib we need to make this Haskell agnostic, so no - -- hie-bios! - -- We also put these modules into a separate hs-source-dirs so we can avoid - -- compiling them at all if ghc-lib is not set - if !flag(ghc-lib) - hs-source-dirs: - session-loader - exposed-modules: - Development.IDE.Session - other-modules: - Development.IDE.Session.VersionCheck other-modules: - Development.IDE.Core.Compile Development.IDE.Core.FileExists Development.IDE.GHC.CPP Development.IDE.GHC.Warnings - Development.IDE.Import.FindImports Development.IDE.LSP.Notifications Development.IDE.Plugin.CodeAction.PositionIndexed Development.IDE.Plugin.Completions.Logic - Development.IDE.Plugin.HLS.Formatter + Development.IDE.Session.VersionCheck Development.IDE.Types.Action - ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns + ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors executable ghcide-test-preprocessor default-language: Haskell2010 @@ -225,7 +207,8 @@ other-modules: Experiments.Types build-tool-depends: ghcide:ghcide-bench, - hp2pretty:hp2pretty + hp2pretty:hp2pretty, + implicit-hie:gen-hie default-extensions: BangPatterns DeriveFunctor @@ -254,8 +237,6 @@ yaml executable ghcide - if flag(ghc-lib) - buildable: False default-language: Haskell2010 include-dirs: include @@ -283,8 +264,8 @@ safe-exceptions, ghc, hashable, - haskell-lsp, - haskell-lsp-types, + lsp, + lsp-types, heapsize, hie-bios, hls-plugin-api, @@ -315,13 +296,12 @@ ViewPatterns test-suite ghcide-tests - if flag(ghc-lib) - buildable: False type: exitcode-stdio-1.0 default-language: Haskell2010 build-tool-depends: ghcide:ghcide, - ghcide:ghcide-test-preprocessor + ghcide:ghcide-test-preprocessor, + implicit-hie:gen-hie build-depends: aeson, base, @@ -343,12 +323,12 @@ ghcide, ghc-typelits-knownnat, haddock-library, - haskell-lsp, - haskell-lsp-types, + lsp, + lsp-types, hls-plugin-api, network-uri, lens, - lsp-test >= 0.12.0.0 && < 0.13, + lsp-test == 0.13.0.0, optparse-applicative, process, QuickCheck, @@ -369,7 +349,7 @@ record-hasfield hs-source-dirs: test/cabal test/exe test/src bench/lib include-dirs: include - ghc-options: -threaded -Wall -Wno-name-shadowing -O0 + ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors main-is: Main.hs other-modules: Development.IDE.Test @@ -405,7 +385,7 @@ extra, filepath, ghcide, - lsp-test >= 0.12.0.0 && < 0.13, + lsp-test == 0.13.0.0, optparse-applicative, process, safe-exceptions, diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -8,7 +8,6 @@ module Development.IDE.Session (SessionLoadingOptions(..) ,CacheDirs(..) - ,defaultLoadingOptions ,loadSession ,loadSessionWithOptions ,setInitialDynFlags @@ -34,6 +33,7 @@ import Data.Aeson import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 +import Data.Default import Data.Either.Extra import Data.Function import Data.Hashable @@ -60,9 +60,8 @@ import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types import Hie.Implicit.Cradle (loadImplicitHieCradle) -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types +import Language.LSP.Server +import Language.LSP.Types import System.Directory import qualified System.Directory.Extra as IO import System.FilePath @@ -99,23 +98,26 @@ -- return the path for storing generated GHC artifacts, -- or 'Nothing' to respect the cradle setting , getCacheDirs :: String -> [String] -> IO CacheDirs + -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' + , getInitialGhcLibDir :: IO (Maybe LibDir) } -defaultLoadingOptions :: SessionLoadingOptions -defaultLoadingOptions = SessionLoadingOptions - {findCradle = HieBios.findCradle - ,loadCradle = HieBios.loadCradle - ,getCacheDirs = getCacheDirsDefault - } +instance Default SessionLoadingOptions where + def = SessionLoadingOptions + {findCradle = HieBios.findCradle + ,loadCradle = HieBios.loadCradle + ,getCacheDirs = getCacheDirsDefault + ,getInitialGhcLibDir = getInitialGhcLibDirDefault + } --- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir -setInitialDynFlags :: IO (Maybe LibDir) -setInitialDynFlags = do +getInitialGhcLibDirDefault :: IO (Maybe LibDir) +getInitialGhcLibDirDefault = do dir <- IO.getCurrentDirectory hieYaml <- runMaybeT $ yamlConfig dir - cradle <- maybe (HieBios.loadImplicitCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml + cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml + hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle libDirRes <- getRuntimeGhcLibDir cradle - libdir <- case libDirRes of + case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir CradleFail err -> do hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,dir,hieYaml,cradle) @@ -123,6 +125,11 @@ CradleNone -> do hPutStrLn stderr $ "Couldn't load cradle (CradleNone)" pure Nothing + +-- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir +setInitialDynFlags :: SessionLoadingOptions -> IO (Maybe LibDir) +setInitialDynFlags SessionLoadingOptions{..} = do + libdir <- getInitialGhcLibDir dynFlags <- mapM dynFlagsForPrinting libdir mapM_ setUnsafeGlobalDynFlags dynFlags pure libdir @@ -177,7 +184,7 @@ -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. loadSession :: FilePath -> IO (Action IdeGhcSession) -loadSession = loadSessionWithOptions defaultLoadingOptions +loadSession = loadSessionWithOptions def loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) loadSessionWithOptions SessionLoadingOptions{..} dir = do @@ -208,12 +215,11 @@ runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) return $ do - extras@ShakeExtras{logger, eventer, restartShakeSession, - withIndefiniteProgress, ideNc, knownTargetsVar + extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras IdeOptions{ optTesting = IdeTesting optTesting - , optCheckProject = checkProject + , optCheckProject = getCheckProject , optCustomDynFlags , optExtensions } <- getIdeOptions @@ -358,6 +364,7 @@ restartShakeSession [] -- Typecheck all files in the project on startup + checkProject <- getCheckProject unless (null cs || not checkProject) $ do cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs) void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do @@ -376,17 +383,19 @@ lfp <- flip makeRelative cfp <$> getCurrentDirectory logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) - when (isNothing hieYaml) $ eventer $ notifyUserImplicitCradle lfp + when (isNothing hieYaml) $ mRunLspT lspEnv $ + sendNotification SWindowShowMessage $ notifyUserImplicitCradle lfp cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml - when optTesting $ eventer $ notifyCradleLoaded lfp + when optTesting $ mRunLspT lspEnv $ + sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp) -- Display a user friendly progress message here: They probably don't know what a cradle is let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfp <> ")" - eopts <- withIndefiniteProgress progMsg NotCancellable $ - cradleToOptsAndLibDir cradle cfp + eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $ + cradleToOptsAndLibDir cradle cfp logDebug logger $ T.pack ("Session loading result: " <> show eopts) case eopts of @@ -612,7 +621,7 @@ -- For the exact reason, see Note [Avoiding bad interface files]. setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags setCacheDirs logger CacheDirs{..} dflags = do - liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir + liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir) pure $ dflags & maybe id setHiDir hiCacheDir & maybe id setHieDir hieCacheDir @@ -796,24 +805,12 @@ cacheDir :: String cacheDir = "ghcide" -notifyUserImplicitCradle:: FilePath -> FromServerMessage -notifyUserImplicitCradle fp = - NotShowMessage $ - NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $ - "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " - <> T.pack fp <> - ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n" <> - "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." - -notifyCradleLoaded :: FilePath -> FromServerMessage -notifyCradleLoaded fp = - NotCustomServer $ - NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $ - toJSON fp - -cradleLoadedMethod :: T.Text -cradleLoadedMethod = "ghcide/cradle/loaded" - +notifyUserImplicitCradle:: FilePath -> ShowMessageParams +notifyUserImplicitCradle fp =ShowMessageParams MtWarning $ + "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " + <> T.pack fp <> + ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<> + "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ---------------------------------------------------------------------------------------------------- data PackageSetupException diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -48,7 +48,7 @@ import HieDb -import Language.Haskell.LSP.Types (DiagnosticTag(..)) +import Language.LSP.Types (DiagnosticTag(..)) import LoadIface (loadModuleInterface) import DriverPhases @@ -106,8 +106,8 @@ import Maybes (orElse) import qualified Data.HashMap.Strict as HashMap -import qualified Language.Haskell.LSP.Messages as LSP -import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Server as LSP import Control.Concurrent.STM hiding (orElse) import Control.Concurrent.Extra import Data.Functor @@ -521,9 +521,9 @@ -- If the hash in the pending list doesn't match the current hash, then skip Just pendingHash -> pendingHash /= hash unless newerScheduled $ do - tok <- pre + pre addRefsFromLoaded db targetPath (RealFile $ fromNormalizedFilePath srcPath) hash hf - post tok + post where mod_location = ms_location mod_summary targetPath = Compat.ml_hie_file mod_location @@ -531,46 +531,42 @@ -- Get a progress token to report progress and update it for the current file pre = do - tok <- modifyVar indexProgressToken $ \case - x@(Just tok) -> pure (x, tok) + tok <- modifyVar indexProgressToken $ fmap dupe . \case + x@(Just _) -> pure x -- Create a token if we don't already have one Nothing -> do - u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> newUnique - lspId <- getLspId se - eventer se $ LSP.ReqWorkDoneProgressCreate $ - LSP.fmServerWorkDoneProgressCreateRequest lspId $ - LSP.WorkDoneProgressCreateParams { _token = u } - eventer se $ LSP.NotWorkDoneProgressBegin $ - LSP.fmServerWorkDoneProgressBeginNotification - LSP.ProgressParams - { _token = u - , _value = LSP.WorkDoneProgressBeginParams - { _title = "Indexing references from:" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } + case lspEnv se of + Nothing -> pure Nothing + Just env -> LSP.runLspT env $ do + u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + -- TODO: Wait for the progress create response to use the token + _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) + LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $ + LSP.Begin $ LSP.WorkDoneProgressBeginParams + { _title = "Indexing references from:" + , _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing } - pure (Just u, u) + pure (Just u) + (!done, !remaining) <- atomically $ do done <- readTVar indexCompleted remaining <- HashMap.size <$> readTVar indexPending pure (done, remaining) + let progress = " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." - eventer se $ LSP.NotWorkDoneProgressReport $ - LSP.fmServerWorkDoneProgressReportNotification - LSP.ProgressParams - { _token = tok - , _value = LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Just $ T.pack (show srcPath) <> progress - , _percentage = Nothing - } - } - pure tok + whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ + LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ + LSP.Report $ LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Just $ T.pack (show srcPath) <> progress + , _percentage = Nothing + } + -- Report the progress once we are done indexing this file - post tok = do + post = do mdone <- atomically $ do -- Remove current element from pending pending <- stateTVar indexPending $ @@ -579,23 +575,20 @@ -- If we are done, report and reset completed whenMaybe (HashMap.null pending) $ swapTVar indexCompleted 0 - when (coerce $ ideTesting se) $ - eventer se $ LSP.NotCustomServer $ - LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath srcPath) - case mdone of - Nothing -> pure () - Just done -> - modifyVar_ indexProgressToken $ \_ -> do - eventer se $ LSP.NotWorkDoneProgressEnd $ - LSP.fmServerWorkDoneProgressEndNotification - LSP.ProgressParams - { _token = tok - , _value = LSP.WorkDoneProgressEndParams - { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" - } - } - -- We are done with the current indexing cycle, so destroy the token - pure Nothing + whenJust (lspEnv se) $ \env -> LSP.runLspT env $ + when (coerce $ ideTesting se) $ + LSP.sendNotification (LSP.SCustomMethod "ghcide/reference/ready") $ + toJSON $ fromNormalizedFilePath srcPath + whenJust mdone $ \done -> + modifyVar_ indexProgressToken $ \tok -> do + whenJust (lspEnv se) $ \env -> LSP.runLspT env $ + whenJust tok $ \tok -> + LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ + LSP.End $ LSP.WorkDoneProgressEndParams + { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" + } + -- We are done with the current indexing cycle, so destroy the token + pure Nothing writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -26,7 +26,9 @@ import Development.Shake import Development.Shake.Classes import GHC.Generics -import Language.Haskell.LSP.Types.Capabilities +import Language.LSP.Server hiding (getVirtualFile) +import Language.LSP.Types +import Language.LSP.Types.Capabilities import qualified System.Directory as Dir import qualified System.FilePath.Glob as Glob @@ -148,8 +150,18 @@ -- | Installs the 'getFileExists' rules. -- Provides a fast implementation if client supports dynamic watched files. -- Creates a global state as a side effect in that case. -fileExistsRules :: ClientCapabilities -> VFSHandle -> Rules () -fileExistsRules ClientCapabilities{_workspace} vfs = do +fileExistsRules :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules () +fileExistsRules lspEnv vfs = do + supportsWatchedFiles <- case lspEnv of + Just lspEnv' -> liftIO $ runLspT lspEnv' $ do + ClientCapabilities {_workspace} <- getClientCapabilities + case () of + _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace + , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles + , Just True <- _dynamicRegistration + -> pure True + _ -> pure False + Nothing -> pure False -- Create the global always, although it should only be used if we have fast rules. -- But there's a chance someone will send unexpected notifications anyway, -- e.g. https://github.com/haskell/ghcide/issues/599 @@ -159,12 +171,9 @@ opts <- liftIO $ getIdeOptionsIO extras let globs = watchedGlobs opts - case () of - _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace - , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles - , Just True <- _dynamicRegistration - -> fileExistsRulesFast globs vfs - | otherwise -> fileExistsRulesSlow vfs + if supportsWatchedFiles + then fileExistsRulesFast globs vfs + else fileExistsRulesSlow vfs -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. fileExistsRulesFast :: [String] -> VFSHandle -> Rules () diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -59,8 +59,9 @@ import qualified Development.IDE.Types.Logger as L -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.VFS +import Language.LSP.Server hiding (getVirtualFile) +import qualified Language.LSP.Server as LSP +import Language.LSP.VFS makeVFSHandle :: IO VFSHandle makeVFSHandle = do @@ -77,9 +78,9 @@ Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs } -makeLSPVFSHandle :: LspFuncs c -> VFSHandle -makeLSPVFSHandle lspFuncs = VFSHandle - { getVirtualFile = getVirtualFileFunc lspFuncs +makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle +makeLSPVFSHandle lspEnv = VFSHandle + { getVirtualFile = runLspT lspEnv . LSP.getVirtualFile , setVirtualFileContents = Nothing } @@ -179,7 +180,7 @@ Nothing -> do foi <- use_ IsFileOfInterest f liftIO $ case foi of - IsFOI Modified -> getCurrentTime + IsFOI Modified{} -> getCurrentTime _ -> do (large,small) <- getModTime $ fromNormalizedFilePath f pure $ internalTimeToUTCTime large small @@ -200,7 +201,8 @@ -> IO () setFileModified state saved nfp = do ideOptions <- getIdeOptionsIO $ shakeExtras state - let checkParents = case optCheckParents ideOptions of + doCheckParents <- optCheckParents ideOptions + let checkParents = case doCheckParents of AlwaysCheck -> True CheckOnSaveAndClose -> saved _ -> False diff --git a/src/Development/IDE/Core/IdeConfiguration.hs b/src/Development/IDE/Core/IdeConfiguration.hs --- a/src/Development/IDE/Core/IdeConfiguration.hs +++ b/src/Development/IDE/Core/IdeConfiguration.hs @@ -21,7 +21,7 @@ import Development.IDE.Core.Shake import Development.IDE.Types.Location import Development.Shake -import Language.Haskell.LSP.Types +import Language.LSP.Types import System.FilePath (isRelative) -- | Lsp client relevant configuration details diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -104,7 +104,8 @@ -- Update the exports map for non FOIs -- We can skip this if checkProject is True, assuming they never change under our feet. - IdeOptions{ optCheckProject = checkProject } <- getIdeOptions + IdeOptions{ optCheckProject = doCheckProject } <- getIdeOptions + checkProject <- liftIO doCheckProject ifaces <- if checkProject then return Nothing else runMaybeT $ do deps <- MaybeT $ sequence <$> uses GetDependencies files hiResults <- lift $ uses GetModIface (nubOrd $ foldMap transitiveModuleDeps deps) diff --git a/src/Development/IDE/Core/PositionMapping.hs b/src/Development/IDE/Core/PositionMapping.hs --- a/src/Development/IDE/Core/PositionMapping.hs +++ b/src/Development/IDE/Core/PositionMapping.hs @@ -24,7 +24,7 @@ import Control.Monad import qualified Data.Text as T -import Language.Haskell.LSP.Types +import Language.LSP.Types import Data.List import Data.Algorithm.Diff import Data.Bifunctor diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -26,19 +26,17 @@ import Development.IDE.Types.KnownTargets import Data.Hashable import Data.Typeable -import qualified Data.Set as S import qualified Data.Map as M import Development.Shake import GHC.Generics (Generic) -import Module (InstalledUnitId) import HscTypes (ModGuts, hm_iface, HomeModInfo, hm_linkable) import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Import.FindImports (ArtifactsLocation) import Data.ByteString (ByteString) -import Language.Haskell.LSP.Types (NormalizedFilePath) +import Language.LSP.Types (NormalizedFilePath) import TcRnMonad (TcGblEnv) import qualified Data.ByteString.Char8 as BS import Development.IDE.Types.Options (IdeGhcSession) @@ -223,9 +221,8 @@ -- | A GHC session preloaded with all the dependencies type instance RuleResult GhcSessionDeps = HscEnvEq --- | Resolve the imports in a module to the file path of a module --- in the same package or the package id of another package. -type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId) +-- | Resolve the imports in a module to the file path of a module in the same package +type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)] -- | This rule is used to report import cycles. It depends on GetDependencyInformation. -- We cannot report the cycles directly from GetDependencyInformation since @@ -296,7 +293,10 @@ instance Binary GetFileContents -data FileOfInterestStatus = OnDisk | Modified +data FileOfInterestStatus + = OnDisk + | Modified { firstOpen :: !Bool -- ^ was this file just opened + } deriving (Eq, Show, Typeable, Generic) instance Hashable FileOfInterestStatus instance NFData FileOfInterestStatus diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -57,14 +57,17 @@ getBindingsRule, needsCompilationRule, generateCoreRule, - getImportMapRule + getImportMapRule, + regenerateHiFile, + ghcSessionDepsDefinition, + getParsedModuleDefinition, + typeCheckRuleDefinition, ) where import Fingerprint -import Data.Aeson (fromJSON,toJSON, Result(Success), FromJSON) +import Data.Aeson (toJSON, Result(Success)) import Data.Binary hiding (get, put) -import Data.Default import Data.Tuple.Extra import Control.Monad.Extra import Control.Monad.Trans.Class @@ -83,7 +86,6 @@ import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile, TargetModule, TargetFile) import Development.IDE.GHC.ExactPrint import Development.IDE.GHC.Util -import Data.Either.Extra import qualified Development.IDE.Types.Logger as L import Data.Maybe import Data.Foldable @@ -99,10 +101,9 @@ import Development.IDE.Core.RuleTypes import qualified Data.ByteString.Char8 as BS import Development.IDE.Core.PositionMapping -import Language.Haskell.LSP.Types (DocumentHighlight (..), SymbolInformation(..)) -import Language.Haskell.LSP.VFS -import qualified Language.Haskell.LSP.Messages as LSP -import qualified Language.Haskell.LSP.Types as LSP +import Language.LSP.Types (DocumentHighlight (..), SymbolInformation(..), SMethod(SCustomMethod)) +import qualified Language.LSP.Server as LSP +import Language.LSP.VFS import qualified GHC.LanguageExtensions as LangExt import HscTypes hiding (TargetModule, TargetFile) @@ -136,6 +137,8 @@ import Data.ByteString.Encoding as T import qualified HieDb +import Ide.Plugin.Config +import qualified Data.Aeson.Types as A -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing @@ -402,17 +405,11 @@ (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource case diagOrImp of - Left diags -> pure (diags, Left (modName, Nothing)) - Right (FileImport path) -> pure ([], Left (modName, Just path)) - Right (PackageImport pkgId) -> liftIO $ do - diagsOrPkgDeps <- computePackageDeps env pkgId - case diagsOrPkgDeps of - Left diags -> pure (diags, Right Nothing) - Right pkgIds -> pure ([], Right $ Just $ pkgId : pkgIds) - let (moduleImports, pkgImports) = partitionEithers imports' - case sequence pkgImports of - Nothing -> pure (concat diags, Nothing) - Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports)) + Left diags -> pure (diags, Just (modName, Nothing)) + Right (FileImport path) -> pure ([], Just (modName, Just path)) + Right PackageImport -> pure ([], Nothing) + let moduleImports = catMaybes imports' + pure (concat diags, Just moduleImports) type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a @@ -427,19 +424,23 @@ -- imports recursively. rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation rawDependencyInformation fs = do - (rdi, ss) <- execRawDepM (mapM_ go fs) + (rdi, ss) <- execRawDepM (goPlural fs) let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss return (rdi { rawBootMap = bm }) where + goPlural ff = do + mss <- lift $ (fmap.fmap) fst <$> uses GetModSummaryWithoutTimestamps ff + zipWithM go ff mss + go :: NormalizedFilePath -- ^ Current module being processed + -> Maybe ModSummary -- ^ ModSummary of the module -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId - go f = do + go f msum = do -- First check to see if we have already processed the FilePath -- If we have, just return its Id but don't update any of the state. -- Otherwise, we need to process its imports. checkAlreadyProcessed f $ do - msum <- lift $ fmap fst <$> use GetModSummaryWithoutTimestamps f - let al = modSummaryToArtifactsLocation f msum + let al = modSummaryToArtifactsLocation f msum -- Get a fresh FilePathId for the new file fId <- getFreshFid al -- Adding an edge to the bootmap so we can make sure to @@ -454,19 +455,19 @@ -- elements in the queue modifyRawDepInfo (insertImport fId (Left ModuleParseError)) return fId - Just (modImports, pkgImports) -> do + Just modImports -> do -- Get NFPs of the imports which have corresponding files -- Imports either come locally from a file or from a package. let (no_file, with_file) = splitImports modImports (mns, ls) = unzip with_file -- Recursively process all the imports we just learnt about -- and get back a list of their FilePathIds - fids <- mapM (go . artifactFilePath) ls + fids <- goPlural $ map artifactFilePath ls -- Associate together the ModuleName with the FilePathId let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids) -- Insert into the map the information about this modules -- imports. - modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports) + modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports') return fId @@ -593,10 +594,10 @@ isFoi <- use_ IsFileOfInterest f diagsWrite <- case isFoi of - IsFOI Modified -> do - when (coerce $ ideTesting se) $ - liftIO $ eventer se $ LSP.NotCustomServer $ - LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath f) + IsFOI Modified{firstOpen = False} -> do + when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ + LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + toJSON $ fromNormalizedFilePath f pure [] _ | Just asts <- masts -> do source <- getSourceFileSource f @@ -612,7 +613,7 @@ getImportMapRule :: Rules () getImportMapRule = define $ \GetImportMap f -> do im <- use GetLocatedImports f - let mkImports (fileImports, _) = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports + let mkImports fileImports = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports pure ([], ImportMap . mkImports <$> im) -- | Ensure that go to definition doesn't block on startup @@ -636,17 +637,7 @@ (hscEnv -> hsc, _) <- useWithStale_ GhcSessionDeps file (HAR{refMap=rf}, _) <- useWithStale_ GetHieAst file --- When possible, rely on the haddocks embedded in our interface files --- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc' -#if !defined(GHC_LIB) - let parsedDeps = [] -#else - deps <- fromMaybe (TransitiveDependencies [] [] []) <$> use GetDependencies file - let tdeps = transitiveModuleDeps deps - parsedDeps <- uses_ GetParsedModule tdeps -#endif - - dkMap <- liftIO $ mkDocMap hsc parsedDeps rf tc + dkMap <- liftIO $ mkDocMap hsc rf tc return ([],Just dkMap) -- | Persistent rule to ensure that hover doesn't block on startup @@ -665,7 +656,7 @@ readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction HieFile readHieFileFromDisk hie_loc = do nc <- asks ideNc - log <- asks $ L.logInfo . logger + log <- asks $ L.logDebug . logger res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc liftIO . log $ either (const $ "FAILED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) (const $ "SUCCEEDED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) @@ -826,9 +817,9 @@ | hash == HieDb.modInfoHash (HieDb.hieModInfo row) , hie_loc == HieDb.hieModuleHieFile row -> do -- All good, the db has indexed the file - when (coerce $ ideTesting se) $ - liftIO $ eventer se $ LSP.NotCustomServer $ - LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath f) + when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ + LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + toJSON $ fromNormalizedFilePath f -- Not in db, must re-index _ -> do ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $ @@ -838,7 +829,7 @@ Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err -- can just re-index the file we read from disk Right hf -> liftIO $ do - L.logInfo (logger se) $ "Re-indexing hie file for" <> T.pack (show f) + L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (show f) indexHieFile se ms f hash hf let fp = hiFileFingerPrint x @@ -857,7 +848,7 @@ if modificationTime x < modificationTime modVersion then pure SourceModified else do - (fileImports, _) <- use_ GetLocatedImports f + fileImports <- use_ GetLocatedImports f let imports = fmap artifactFilePath . snd <$> fileImports deps <- uses_ IsHiFileStable (catMaybes imports) pure $ if all (== SourceUnmodifiedAndStable) deps @@ -924,7 +915,6 @@ getModIfaceRule :: Rules () getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do -#if !defined(GHC_LIB) fileOfInterest <- use_ IsFileOfInterest f res@(_,(_,mhmi)) <- case fileOfInterest of IsFOI status -> do @@ -951,13 +941,6 @@ compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction liftIO $ modifyVar_ compiledLinkables $ \old -> pure $ extendModuleEnv old mod time pure res -#else - tm <- use_ TypeCheck f - hsc <- hscEnv <$> use_ GhcSessionDeps f - (diags, !hiFile) <- liftIO $ compileToObjCodeIfNeeded hsc Nothing (error "can't compile with ghc-lib") tm - let fp = hiFileFingerPrint <$> hiFile - return (fp, (diags, hiFile)) -#endif getModIfaceWithoutLinkableRule :: Rules () getModIfaceWithoutLinkableRule = defineEarlyCutoff $ \GetModIfaceWithoutLinkable f -> do @@ -1047,12 +1030,13 @@ -- | Returns the client configurarion stored in the IdeState. -- You can use this function to access it from shake Rules -getClientConfigAction :: (Default a, FromJSON a) => Action a -getClientConfigAction = do +getClientConfigAction :: Config -- ^ default value + -> Action Config +getClientConfigAction defValue = do mbVal <- unhashed <$> useNoFile_ GetClientSettings - case fromJSON <$> mbVal of + case A.parse (parseConfig defValue) <$> mbVal of Just (Success c) -> return c - _ -> return def + _ -> return defValue -- | For now we always use bytecode getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -25,9 +25,9 @@ import Development.IDE.Core.OfInterest import Development.IDE.Types.Logger as Logger import Development.Shake -import qualified Language.Haskell.LSP.Messages as LSP -import qualified Language.Haskell.LSP.Types as LSP -import qualified Language.Haskell.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP +import Ide.Plugin.Config import Development.IDE.Core.Shake import Control.Monad @@ -37,12 +37,8 @@ -- Exposed API -- | Initialise the Compiler Service. -initialise :: LSP.ClientCapabilities - -> Rules () - -> IO LSP.LspId - -> (LSP.FromServerMessage -> IO ()) - -> WithProgressFunc - -> WithIndefiniteProgressFunc +initialise :: Rules () + -> Maybe (LSP.LanguageContextEnv Config) -> Logger -> Debouncer LSP.NormalizedUri -> IdeOptions @@ -50,13 +46,9 @@ -> HieDb -> IndexQueue -> IO IdeState -initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer options vfs hiedb hiedbChan = +initialise mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = shakeOpen - getLspId - toDiags - wProg - wIndefProg - caps + lspEnv logger debouncer (optShakeProfiling options) @@ -70,7 +62,7 @@ addIdeGlobal $ GlobalIdeOptions options fileStoreRules vfs ofInterestRules - fileExistsRules caps vfs + fileExistsRules lspEnv vfs mainRule writeProfile :: IdeState -> FilePath -> IO () diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PolyKinds #-} -- | A Shake implementation of the compiler service. -- @@ -39,6 +40,7 @@ BadDependency(..), define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, getDiagnostics, + mRunLspT, mRunLspTCallback, getHiddenDiagnostics, IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction, getIdeGlobalExtras, @@ -48,7 +50,6 @@ garbageCollect, knownTargets, setPriority, - sendEvent, ideLogger, actionLogger, FileVersion(..), @@ -97,7 +98,7 @@ import Development.IDE.Types.KnownTargets import Development.IDE.Types.Shake import qualified Development.IDE.Types.Logger as Logger -import Language.Haskell.LSP.Diagnostics +import Language.LSP.Diagnostics import qualified Data.SortedList as SL import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports @@ -107,19 +108,16 @@ import Control.Concurrent.Extra import Control.Concurrent.STM import Control.DeepSeq -import Control.Exception.Extra import System.Time.Extra import Data.Typeable -import qualified Language.Haskell.LSP.Core as LSP -import qualified Language.Haskell.LSP.Messages as LSP -import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP import System.FilePath hiding (makeRelative) import qualified Development.Shake as Shake import Control.Monad.Extra import Data.Time import GHC.Generics -import System.IO.Unsafe -import Language.Haskell.LSP.Types +import Language.LSP.Types import qualified Control.Monad.STM as STM import Control.Monad.IO.Class import Control.Monad.Reader @@ -127,17 +125,21 @@ import Data.Traversable import Data.Hashable import Development.IDE.Core.Tracing -import Language.Haskell.LSP.VFS +import Language.LSP.VFS import Data.IORef import NameCache import UniqSupply import PrelInfo -import Language.Haskell.LSP.Types.Capabilities +import Language.LSP.Types.Capabilities import OpenTelemetry.Eventlog import GHC.Fingerprint import HieDb.Types +import Control.Exception.Extra hiding (bracket_) +import UnliftIO.Exception (bracket_) +import Ide.Plugin.Config +import Data.Default -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -156,7 +158,8 @@ -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras - {eventer :: LSP.FromServerMessage -> IO () + { --eventer :: LSP.FromServerMessage -> IO () + lspEnv :: Maybe (LSP.LanguageContextEnv Config) ,debouncer :: Debouncer NormalizedUri ,logger :: Logger ,globals :: Var (HMap.HashMap TypeRep Dynamic) @@ -174,15 +177,10 @@ ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int) -- ^ How many rules are running for each file ,progressUpdate :: ProgressEvent -> IO () - -- ^ The generator for unique Lsp identifiers ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,session :: MVar ShakeSession -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component - ,withProgress :: WithProgressFunc - -- ^ Report progress about some long running operation (on top of the progress shown by 'lspShakeProgress') - ,withIndefiniteProgress :: WithIndefiniteProgressFunc - -- ^ Same as 'withProgress', but for processes that do not report the percentage complete ,restartShakeSession :: [DelayedAction ()] -> IO () ,ideNc :: IORef NameCache -- | A mapping of module name to known target (or candidate targets, if missing) @@ -197,12 +195,11 @@ , persistentKeys :: Var (HMap.HashMap Key GetStalePersistent) -- ^ Registery for functions that compute/get "stale" results for the rule -- (possibly from disk) - , getLspId :: IO LspId , vfs :: VFSHandle } type WithProgressFunc = forall a. - T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a + T.Text -> LSP.ProgressCancellable -> ((LSP.ProgressAmount -> IO ()) -> IO a) -> IO a type WithIndefiniteProgressFunc = forall a. T.Text -> LSP.ProgressCancellable -> IO a -> IO a @@ -373,29 +370,24 @@ ,shakeSession :: MVar ShakeSession ,shakeClose :: IO () ,shakeExtras :: ShakeExtras - ,shakeProfileDir :: Maybe FilePath + ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) ,stopProgressReporting :: IO () } -- This is debugging code that generates a series of profiles, if the Boolean is true -shakeDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> IO (Maybe FilePath) -shakeDatabaseProfile mbProfileDir shakeDb = +shakeDatabaseProfileIO :: Maybe FilePath -> IO(ShakeDatabase -> IO (Maybe FilePath)) +shakeDatabaseProfileIO mbProfileDir = do + profileStartTime <- formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime + profileCounter <- newVar (0::Int) + return $ \shakeDb -> for mbProfileDir $ \dir -> do count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y) let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) <.> "html" shakeProfileDatabase shakeDb $ dir file return (dir file) -{-# NOINLINE profileStartTime #-} -profileStartTime :: String -profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime - -{-# NOINLINE profileCounter #-} -profileCounter :: Var Int -profileCounter = unsafePerformIO $ newVar 0 - setValues :: IdeRule k v => Var Values -> k @@ -452,11 +444,7 @@ Failed _ -> b -- | Open a 'IdeState', should be shut using 'shakeShut'. -shakeOpen :: IO LSP.LspId - -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler - -> WithProgressFunc - -> WithIndefiniteProgressFunc - -> ClientCapabilities +shakeOpen :: Maybe (LSP.LanguageContextEnv Config) -> Logger -> Debouncer NormalizedUri -> Maybe FilePath @@ -468,8 +456,9 @@ -> ShakeOptions -> Rules () -> IO IdeState -shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilities logger debouncer +shakeOpen lspEnv logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo + inProgress <- newVar HMap.empty us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) @@ -497,6 +486,8 @@ actionQueue <- newQueue + let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv + pure (ShakeExtras{..}, cancel progressAsync) (shakeDbM, shakeClose) <- shakeOpenDatabase @@ -505,6 +496,7 @@ shakeDb <- shakeDbM initSession <- newSession shakeExtras shakeDb [] shakeSession <- newMVar initSession + shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir let ideState = IdeState{..} IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras @@ -526,7 +518,7 @@ case v of KickCompleted -> STM.retry KickStarted -> return () - asyncReporter <- async lspShakeProgress + asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress progressLoopReporting asyncReporter progressLoopReporting asyncReporter = do atomically $ do @@ -537,54 +529,55 @@ cancel asyncReporter progressLoopIdle + lspShakeProgress :: LSP.LspM config () lspShakeProgress = do -- first sleep a bit, so we only show progress messages if it's going to take -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - unless testing $ sleep 0.1 - lspId <- getLspId - u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique - eventer $ LSP.ReqWorkDoneProgressCreate $ - LSP.fmServerWorkDoneProgressCreateRequest lspId $ - LSP.WorkDoneProgressCreateParams { _token = u } - bracket_ (start u) (stop u) (loop u Nothing) + liftIO $ unless testing $ sleep 0.1 + u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + + void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) + + bracket_ + (start u) + (stop u) + (loop u Nothing) where - start id = eventer $ LSP.NotWorkDoneProgressBegin $ - LSP.fmServerWorkDoneProgressBeginNotification + start id = LSP.sendNotification LSP.SProgress $ LSP.ProgressParams { _token = id - , _value = WorkDoneProgressBeginParams + , _value = LSP.Begin $ WorkDoneProgressBeginParams { _title = "Processing" , _cancellable = Nothing , _message = Nothing , _percentage = Nothing } } - stop id = eventer $ LSP.NotWorkDoneProgressEnd $ - LSP.fmServerWorkDoneProgressEndNotification + stop id = LSP.sendNotification LSP.SProgress LSP.ProgressParams { _token = id - , _value = WorkDoneProgressEndParams + , _value = LSP.End WorkDoneProgressEndParams { _message = Nothing } } sample = 0.1 loop id prev = do - sleep sample - current <- readVar inProgress + liftIO $ sleep sample + current <- liftIO $ readVar inProgress let done = length $ filter (== 0) $ HMap.elems current let todo = HMap.size current let next = Just $ T.pack $ show done <> "/" <> show todo when (next /= prev) $ - eventer $ LSP.NotWorkDoneProgressReport $ - LSP.fmServerWorkDoneProgressReportNotification - LSP.ProgressParams - { _token = id - , _value = LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = next - , _percentage = Nothing - } - } + LSP.sendNotification LSP.SProgress $ + LSP.ProgressParams + { _token = id + , _value = LSP.Report $ LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = next + , _percentage = Nothing + } + } loop id next shakeProfile :: IdeState -> FilePath -> IO () @@ -630,7 +623,7 @@ shakeSession (\runner -> do (stopTime,()) <- duration (cancelShakeSession runner) - res <- shakeDatabaseProfile shakeProfileDir shakeDb + res <- shakeDatabaseProfile shakeDb let profile = case res of Just fp -> ", profile saved at " <> fp _ -> "" @@ -648,9 +641,8 @@ notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () notifyTestingLogMessage extras msg = do (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras - let notif = LSP.NotLogMessage $ LSP.NotificationMessage "2.0" LSP.WindowLogMessage - $ LSP.LogMessageParams LSP.MtLog msg - when isTestMode $ eventer extras notif + let notif = LSP.LogMessageParams LSP.MtLog msg + when isTestMode $ mRunLspT (lspEnv extras) $ LSP.sendNotification LSP.SWindowLogMessage notif -- | Enqueue an action in the existing 'ShakeSession'. @@ -742,6 +734,18 @@ d' = DelayedAction (Just u) s p a' return (b, d') +mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () +mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f +mRunLspT Nothing _ = pure () + +mRunLspTCallback :: Monad m + => Maybe (LSP.LanguageContextEnv c) + -> (LSP.LspT c m a -> LSP.LspT c m a) + -> m a + -> m a +mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) +mRunLspTCallback Nothing _ g = g + getDiagnostics :: IdeState -> IO [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do val <- readVar diagnostics @@ -1027,7 +1031,7 @@ -> ShakeExtras -> [(ShowDiagnostic,Diagnostic)] -- ^ current results -> m () -updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do +updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do modTime <- (currentValue . fst =<<) <$> getValues state GetModificationTime fp let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current uri = filePathToUri' fp @@ -1048,25 +1052,18 @@ registerEvent debouncer delay uri $ do mask_ $ modifyVar_ publishedDiagnostics $ \published -> do let lastPublish = HMap.lookupDefault [] uri published - when (lastPublish /= newDiags) $ - eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags + when (lastPublish /= newDiags) $ case lspEnv of + Nothing -> -- Print an LSP event. + logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags + Just env -> LSP.runLspT env $ + LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ + LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags) pure $! HMap.insert uri newDiags published -publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage -publishDiagnosticsNotification uri diags = - LSP.NotPublishDiagnostics $ - LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams uri (List diags) - newtype Priority = Priority Double setPriority :: Priority -> Action () setPriority (Priority p) = reschedule p - -sendEvent :: LSP.FromServerMessage -> Action () -sendEvent e = do - ShakeExtras{eventer} <- getShakeExtras - liftIO $ eventer e ideLogger :: IdeState -> Logger ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} #include "ghc-api-version.h" module Development.IDE.Core.Tracing ( otTracedHandler @@ -28,11 +27,11 @@ GhcSessionIO (GhcSessionIO)) import Development.IDE.Types.Logger (logInfo, Logger, logDebug) import Development.IDE.Types.Shake (ValueWithDiagnostics(..), Key (..), Value, Values) -import Development.Shake (Action, actionBracket, liftIO) +import Development.Shake (Action, actionBracket) import Ide.PluginUtils (installSigUsr1Handler) import Foreign.Storable (Storable (sizeOf)) import HeapSize (recursiveSize, runHeapsize) -import Language.Haskell.LSP.Types (NormalizedFilePath, +import Language.LSP.Types (NormalizedFilePath, fromNormalizedFilePath) import Numeric.Natural (Natural) import OpenTelemetry.Eventlog (SpanInFlight, Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan, @@ -42,20 +41,24 @@ import Data.Text.Encoding (encodeUtf8) import Ide.Types (PluginId (..)) import Development.IDE.Types.Location (Uri (..)) +import Control.Monad.IO.Unlift -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler - :: String -- ^ Message type + :: MonadUnliftIO m + => String -- ^ Message type -> String -- ^ Message label - -> (SpanInFlight -> IO a) - -> IO a + -> (SpanInFlight -> m a) + -> m a otTracedHandler requestType label act = let !name = if null label then requestType else requestType <> ":" <> show label -- Add an event so all requests can be quickly seen in the viewer without searching - in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act sp) + in do + runInIO <- askRunInIO + liftIO $ withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> runInIO (act sp)) otSetUri :: SpanInFlight -> Uri -> IO () otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t) @@ -81,14 +84,15 @@ return res) #if MIN_GHC_API_VERSION(8,8,0) -otTracedProvider :: PluginId -> ByteString -> IO a -> IO a +otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a #else -otTracedProvider :: PluginId -> String -> IO a -> IO a +otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a #endif -otTracedProvider (PluginId pluginName) provider act = - withSpan (provider <> " provider") $ \sp -> do +otTracedProvider (PluginId pluginName) provider act = do + runInIO <- askRunInIO + liftIO $ withSpan (provider <> " provider") $ \sp -> do setTag sp "plugin" (encodeUtf8 pluginName) - act + runInIO act startTelemetry :: Bool -> Logger -> Var Values -> IO () startTelemetry allTheTime logger stateRef = do diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs --- a/src/Development/IDE/GHC/ExactPrint.hs +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -1,19 +1,24 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{- HLINT ignore "Use zipFrom" -} + module Development.IDE.GHC.ExactPrint ( Graft(..), graft, + graftWithoutParentheses, graftDecls, graftDeclsWithM, annotate, hoistGraft, graftWithM, graftWithSmallestM, + graftSmallestDecls, + graftSmallestDeclsWithM, transform, transformM, useAnnotatedSource, @@ -54,14 +59,22 @@ import Ide.PluginUtils import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) +import Language.LSP.Types +import Language.LSP.Types.Capabilities (ClientCapabilities) import Outputable (Outputable, ppr, showSDoc) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) import Parser (parseIdentifier) +import Data.Traversable (for) +import Data.Foldable (Foldable(fold)) +import Data.Bool (bool) #if __GLASGOW_HASKELL__ == 808 import Control.Arrow #endif +#if __GLASGOW_HASKELL__ > 808 +import Bag (listToBag) +import ErrUtils (mkErrMsg) +import Outputable (text, neverQualify) +#endif ------------------------------------------------------------------------------ @@ -179,8 +192,18 @@ SrcSpan -> Located ast -> Graft (Either String) a -graft dst val = Graft $ \dflags a -> do - (anns, val') <- annotate dflags $ maybeParensAST val +graft dst = graftWithoutParentheses dst . maybeParensAST + +-- | Like 'graft', but trusts that you have correctly inserted the parentheses +-- yourself. If you haven't, the resulting AST will not be valid! +graftWithoutParentheses :: + forall ast a. + (Data a, ASTElement ast) => + SrcSpan -> + Located ast -> + Graft (Either String) a +graftWithoutParentheses dst val = Graft $ \dflags a -> do + (anns, val') <- annotate dflags val modifyAnnsT $ mappend anns pure $ everywhere' @@ -191,6 +214,7 @@ ) a + ------------------------------------------------------------------------------ graftWithM :: @@ -260,6 +284,44 @@ | otherwise = DL.singleton (L src e) <> go rest modifyDeclsT (pure . DL.toList . go) a +graftSmallestDecls :: + forall a. + (HasDecls a) => + SrcSpan -> + [LHsDecl GhcPs] -> + Graft (Either String) a +graftSmallestDecls dst decs0 = Graft $ \dflags a -> do + decs <- forM decs0 $ \decl -> do + (anns, decl') <- annotateDecl dflags decl + modifyAnnsT $ mappend anns + pure decl' + let go [] = DL.empty + go (L src e : rest) + | dst `isSubspanOf` src = DL.fromList decs <> DL.fromList rest + | otherwise = DL.singleton (L src e) <> go rest + modifyDeclsT (pure . DL.toList . go) a + +graftSmallestDeclsWithM :: + forall a. + (HasDecls a) => + SrcSpan -> + (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) -> + Graft (Either String) a +graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do + let go [] = pure DL.empty + go (e@(L src _) : rest) + | dst `isSubspanOf` src = toDecls e >>= \case + Just decs0 -> do + decs <- forM decs0 $ \decl -> do + (anns, decl') <- + annotateDecl dflags decl + modifyAnnsT $ mappend anns + pure decl' + pure $ DL.fromList decs <> DL.fromList rest + Nothing -> (DL.singleton e <>) <$> go rest + | otherwise = (DL.singleton e <>) <$> go rest + modifyDeclsT (fmap DL.toList . go) a + graftDeclsWithM :: forall a m. (HasDecls a, Fail.MonadFail m) => @@ -344,12 +406,37 @@ -- | Given an 'LHsDecl', compute its exactprint annotations. annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (Anns, LHsDecl GhcPs) +-- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain +-- multiple matches. To work around this, we split the single +-- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match', +-- and then merge them all back together. +annotateDecl dflags + (L src ( + ValD ext fb@FunBind + { fun_matches = mg@MG { mg_alts = L alt_src alts@(_:_)} + })) = do + let set_matches matches = + ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }} + + (anns', alts') <- fmap unzip $ for (zip [0..] alts) $ \(ix :: Int, alt) -> do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags $ set_matches [alt] + lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case + (ann, L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}})) + -> pure (bool id (setPrecedingLines alt' 1 0) (ix /= 0) ann, alt') + _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match" + + let expr' = L src $ set_matches alts' + anns'' = setPrecedingLines expr' 1 0 $ fold anns' + + pure (anns'', expr') annotateDecl dflags ast = do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered let anns' = setPrecedingLines expr' 1 0 anns pure (anns', expr') + ------------------------------------------------------------------------------ -- | Print out something 'Outputable'. diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE ExplicitNamespaces #-} module Development.IDE.GHC.Warnings(withWarnings) where @@ -12,7 +13,7 @@ import Development.IDE.Types.Diagnostics import Development.IDE.GHC.Error -import Language.Haskell.LSP.Types (NumberOrString (StringValue)) +import Language.LSP.Types (type (|?)(..)) -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some @@ -36,7 +37,7 @@ return (reverse $ concat warns, res) attachReason :: WarnReason -> Diagnostic -> Diagnostic -attachReason wr d = d{_code = StringValue <$> showReason wr} +attachReason wr d = d{_code = InR <$> showReason wr} where showReason = \case NoReason -> Nothing diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -46,8 +46,6 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set import GHC.Generics (Generic) import Development.IDE.Types.Diagnostics @@ -55,15 +53,12 @@ import Development.IDE.Import.FindImports (ArtifactsLocation(..)) import GHC -import Module -- | The imports for a given module. -data ModuleImports = ModuleImports - { moduleImports :: ![(Located ModuleName, Maybe FilePathId)] +newtype ModuleImports = ModuleImports + { moduleImports :: [(Located ModuleName, Maybe FilePathId)] -- ^ Imports of a module in the current package and the file path of -- that module on disk (if we found it) - , packageImports :: !(Set InstalledUnitId) - -- ^ Transitive package dependencies unioned for all imports. } deriving Show -- | For processing dependency information, we need lots of maps and sets of @@ -132,10 +127,6 @@ , rawBootMap :: !BootIdMap } deriving Show -pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId) -pkgDependencies RawDependencyInformation{..} = - IntMap.map (either (const Set.empty) packageImports) rawImports - data DependencyInformation = DependencyInformation { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) @@ -146,8 +137,6 @@ -- in the same package. , depReverseModuleDeps :: !(IntMap IntSet) -- ^ Contains a reverse mapping from a module to all those that immediately depend on it. - , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId)) - -- ^ For a non-error node, this contains the set of immediate pkg deps. , depPathIdMap :: !PathIdMap -- ^ Map from FilePath to FilePathId , depBootMap :: !BootIdMap @@ -222,13 +211,12 @@ SuccessNode a <> SuccessNode _ = SuccessNode a processDependencyInformation :: RawDependencyInformation -> DependencyInformation -processDependencyInformation rawDepInfo@RawDependencyInformation{..} = +processDependencyInformation RawDependencyInformation{..} = DependencyInformation { depErrorNodes = IntMap.fromList errorNodes , depModuleDeps = moduleDeps , depReverseModuleDeps = reverseModuleDeps , depModuleNames = IntMap.fromList $ coerce moduleNames - , depPkgDeps = pkgDependencies rawDepInfo , depPathIdMap = rawPathIdMap , depBootMap = rawBootMap } @@ -248,8 +236,8 @@ successEdges reverseModuleDeps = foldr (\(p, cs) res -> - let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs)) - in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges + let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs)) + in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows: @@ -345,17 +333,8 @@ reachable g <$> toVertex (getFilePathId fileId) let transitiveModuleDepIds = filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs - let transitivePkgDeps = - Set.toList $ Set.unions $ - map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $ - getFilePathId fileId : transitiveModuleDepIds let transitiveModuleDeps = map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds - let transitiveNamedModuleDeps = - [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation - | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames - , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid - ] pure TransitiveDependencies {..} where (g, fromVertex, toVertex) = graphFromEdges edges @@ -369,15 +348,10 @@ vs = topSort g -data TransitiveDependencies = TransitiveDependencies +newtype TransitiveDependencies = TransitiveDependencies { transitiveModuleDeps :: [NormalizedFilePath] -- ^ Transitive module dependencies in topological order. -- The module itself is not included. - , transitiveNamedModuleDeps :: [NamedModuleDep] - -- ^ Transitive module dependencies in topological order. - -- The module itself is not included. - , transitivePkgDeps :: [InstalledUnitId] - -- ^ Transitive pkg dependencies in unspecified order. } deriving (Eq, Show, Generic) instance NFData TransitiveDependencies diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -37,7 +37,7 @@ data Import = FileImport !ArtifactsLocation - | PackageImport !M.InstalledUnitId + | PackageImport deriving (Show) data ArtifactsLocation = ArtifactsLocation @@ -55,7 +55,7 @@ instance NFData Import where rnf (FileImport x) = rnf x - rnf (PackageImport x) = rnf x + rnf PackageImport = () modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source @@ -137,7 +137,7 @@ lookupInPackageDB dfs = case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of - LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig + LookupFound _m _pkgConfig -> return $ Right PackageImport reason -> return $ Left $ notFoundErr dfs modName reason -- | Don't call this on a found module. diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs --- a/src/Development/IDE/LSP/HoverDefinition.hs +++ b/src/Development/IDE/LSP/HoverDefinition.hs @@ -1,42 +1,39 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 - +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} -- | Display information on hover. module Development.IDE.LSP.HoverDefinition - ( setHandlersDefinition - , setHandlersTypeDefinition - , setHandlersDocHighlight - , setHandlersReferences - , setHandlersWsSymbols + ( setIdeHandlers -- * For haskell-language-server , hover , gotoDefinition , gotoTypeDefinition ) where +import Control.Monad.IO.Class import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.LSP.Server import Development.IDE.Types.Location import Development.IDE.Types.Logger -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types import qualified Data.Text as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams) -hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) -gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams) -documentHighlight :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (List DocumentHighlight)) -gotoDefinition = request "Definition" getDefinition (MultiLoc []) MultiLoc -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc +gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition)) +hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover)) +gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition)) +documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight)) +gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List) hover = request "Hover" getAtPoint Nothing foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List -references :: IdeState -> ReferenceParams -> IO (Either ResponseError (List Location)) -references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _) = +references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location)) +references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $ case uriToFilePath' uri of Just path -> do let filePath = toNormalizedFilePath' path @@ -46,8 +43,8 @@ Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos) Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing -wsSymbols :: IdeState -> WorkspaceSymbolParams -> IO (Either ResponseError (List SymbolInformation)) -wsSymbols ide (WorkspaceSymbolParams query _) = do +wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError (List SymbolInformation)) +wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do logDebug (ideLogger ide) $ "Workspace symbols request: " <> query runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query @@ -55,18 +52,17 @@ foundHover (mbRange, contents) = Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange -setHandlersDefinition, setHandlersTypeDefinition, setHandlersDocHighlight, - setHandlersReferences, setHandlersWsSymbols :: PartialHandlers c -setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition} -setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x -> - return x {LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition} -setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight} -setHandlersReferences = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.referencesHandler = withResponse RspFindReferences $ const references} -setHandlersWsSymbols = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.workspaceSymbolHandler = withResponse RspWorkspaceSymbols $ const wsSymbols} +setIdeHandlers :: LSP.Handlers (ServerM c) +setIdeHandlers = mconcat + [ requestHandler STextDocumentDefinition $ \ide DefinitionParams{..} -> + gotoDefinition ide TextDocumentPositionParams{..} + , requestHandler STextDocumentTypeDefinition $ \ide TypeDefinitionParams{..} -> + gotoTypeDefinition ide TextDocumentPositionParams{..} + , requestHandler STextDocumentDocumentHighlight $ \ide DocumentHighlightParams{..} -> + documentHighlight ide TextDocumentPositionParams{..} + , requestHandler STextDocumentReferences references + , requestHandler SWorkspaceSymbol wsSymbols + ] -- | Respond to and log a hover or go-to-definition request request @@ -76,8 +72,8 @@ -> (a -> b) -> IdeState -> TextDocumentPositionParams - -> IO (Either ResponseError b) -request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do + -> LSP.LspM c (Either ResponseError b) +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do mbResult <- case uriToFilePath' uri of Just path -> logAndRunRequest label getResults ide pos path Nothing -> pure Nothing @@ -86,7 +82,7 @@ logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do let filePath = toNormalizedFilePath' path - logInfo (ideLogger ide) $ + logDebug (ideLogger ide) $ label <> " request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack path runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos) diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -1,8 +1,10 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. + -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling @@ -10,46 +12,47 @@ ( runLanguageServer ) where -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities +import Language.LSP.Types import Development.IDE.LSP.Server import qualified Development.IDE.GHC.Util as Ghcide -import qualified Language.Haskell.LSP.Control as LSP -import qualified Language.Haskell.LSP.Core as LSP -import Control.Concurrent.Chan -import Control.Concurrent.Extra -import Control.Concurrent.Async +import qualified Language.LSP.Server as LSP +import Control.Concurrent.Extra (newBarrier, signalBarrier, waitBarrier) import Control.Concurrent.STM -import Control.Exception.Safe -import Data.Default import Data.Maybe +import Data.Aeson (Value) import qualified Data.Set as Set import qualified Data.Text as T import GHC.IO.Handle (hDuplicate) import System.IO 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 import Development.IDE.LSP.HoverDefinition import Development.IDE.LSP.Notifications -import Development.IDE.LSP.Outline import Development.IDE.Types.Logger import Development.IDE.Core.FileStore import Development.IDE.Core.Tracing -import Language.Haskell.LSP.Core (LspFuncs(..)) -import Language.Haskell.LSP.Messages +import System.IO.Unsafe (unsafeInterleaveIO) + runLanguageServer :: forall config. (Show config) => LSP.Options - -> PartialHandlers config - -> (InitializeRequest -> Either T.Text config) - -> (DidChangeConfigurationNotification -> Either T.Text config) - -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities - -> WithProgressFunc -> WithIndefiniteProgressFunc -> IO (Maybe config) -> Maybe FilePath -> IO IdeState) + -> (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 -> HieDb -> IndexQueue -> IO IdeState) -> IO () -runLanguageServer options userHandlers onInitialConfig onConfigChange 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. @@ -64,10 +67,6 @@ -- the language server tests without the redirection. putStr " " >> hFlush stdout - -- Send everything over a channel, since you need to wait until after initialise before - -- LspFuncs is available - clientMsgChan :: Chan (Message config) <- newChan - -- These barriers are signaled when the threads reading from these chans exit. -- This should not happen but if it does, we will make sure that the whole server -- dies and can be restarted instead of losing threads silently. @@ -80,16 +79,6 @@ -- The set of requests that have been cancelled and are also in pendingRequests cancelledRequests <- newTVarIO Set.empty - let withResponse wrap f = Just $ \r@RequestMessage{_id, _method} -> do - atomically $ modifyTVar pendingRequests (Set.insert _id) - writeChan clientMsgChan $ Response r wrap f - let withNotification old f = Just $ \r@NotificationMessage{_method} -> - writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r)) - let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id, _method} -> do - atomically $ modifyTVar pendingRequests (Set.insert _id) - writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f - let withInitialize f = Just $ \r -> - writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x) let cancelRequest reqId = atomically $ do queued <- readTVar pendingRequests -- We want to avoid that the list of cancelled requests @@ -105,160 +94,117 @@ let waitForCancel reqId = atomically $ do cancelled <- readTVar cancelledRequests unless (reqId `Set.member` cancelled) retry - let PartialHandlers parts = - initializeRequestHandler <> - setHandlersIgnore <> -- least important - setHandlersDefinition <> setHandlersTypeDefinition <> - setHandlersDocHighlight <> setHandlersReferences <> setHandlersWsSymbols <> - setHandlersOutline <> - userHandlers <> - setHandlersNotifications <> -- absolutely critical, join them with user notifications - cancelHandler cancelRequest <> - exitHandler exit - -- Cancel requests are special since they need to be handled - -- out of order to be useful. Existing handlers are run afterwards. - handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def - let initializeCallbacks = LSP.InitializeCallbacks - { LSP.onInitialConfiguration = onInitialConfig - , LSP.onConfigurationChange = onConfigChange - , LSP.onStartup = handleInit exit clearReqId waitForCancel clientMsgChan + let ideHandlers = mconcat + [ setIdeHandlers + , userHandlers + , setHandlersNotifications -- absolutely critical, join them with user notifications + ] + + -- Send everything over a channel, since you need to wait until after initialise before + -- LspFuncs is available + clientMsgChan :: Chan ReactorMessage <- newChan + + let asyncHandlers = mconcat + [ ideHandlers + , cancelHandler cancelRequest + , exitHandler exit + ] + -- Cancel requests are special since they need to be handled + -- out of order to be useful. Existing handlers are run afterwards. + + + let serverDefinition = LSP.ServerDefinition + { LSP.onConfigurationChange = \v -> do + (_chan, ide) <- ask + liftIO $ onConfigurationChange ide v + , LSP.doInitialize = handleInit exit clearReqId waitForCancel clientMsgChan + , LSP.staticHandlers = asyncHandlers + , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO + , LSP.options = modifyOptions options } void $ waitAnyCancel =<< traverse async - [ void $ LSP.runWithHandles + [ void $ LSP.runServerWithHandles stdin newStdout - initializeCallbacks - handlers - (modifyOptions options) - Nothing + serverDefinition , void $ waitBarrier clientMsgBarrier ] + where - handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err) - handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do + handleInit + :: 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 + traceWithSpan sp params + let root = LSP.resRootPath env - ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities - withProgress withIndefiniteProgress config rootPath + dir <- getCurrentDirectory + dbLoc <- getHieDbLoc dir - _ <- flip forkFinally (const exitClientMsg) $ forever $ do + -- 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 + logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig + registerIdeConfiguration (shakeExtras ide) initConfig + + _ <- 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 case msg of - Notification x@NotificationMessage{_params, _method} act -> - otTracedHandler "Notification" (show _method) $ \sp -> do - traceWithSpan sp _params - catch (act lspFuncs ide _params) $ \(e :: SomeException) -> - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on notification, please report!\n" ++ - "Message: " ++ show x ++ "\n" ++ - "Exception: " ++ show e - Response x@RequestMessage{_id, _method, _params} wrap act -> void $ async $ - otTracedHandler "Request" (show _method) $ \sp -> do - traceWithSpan sp _params - checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ - \case - Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e) - Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r) - ResponseAndRequest x@RequestMessage{_id, _method, _params} wrap wrapNewReq act -> void $ async $ - otTracedHandler "Request" (show _method) $ \sp -> do - traceWithSpan sp _params - checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ - \(res, newReq) -> do - case res of - Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e) - Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r) - whenJust newReq $ \(rm, newReqParams) -> do - reqId <- getNextReqId - sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams - InitialParams x@RequestMessage{_id, _method, _params} act -> - otTracedHandler "Initialize" (show _method) $ \sp -> do - traceWithSpan sp _params - catch (act lspFuncs ide _params) $ \(e :: SomeException) -> - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on InitializeRequest handler, please report!\n" ++ - "Message: " ++ show x ++ "\n" ++ - "Exception: " ++ show e - pure Nothing + ReactorNotification act -> do + catch act $ \(e :: SomeException) -> + logError (ideLogger ide) $ T.pack $ + "Unexpected exception on notification, please report!\n" ++ + "Exception: " ++ show e + ReactorRequest _id act k -> void $ async $ + checkCancelled ide clearReqId waitForCancel _id act k + pure $ Right (env,ide) - checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k = + checkCancelled + :: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId + -> IO () -> (ResponseError -> IO ()) -> IO () + checkCancelled ide clearReqId waitForCancel _id act k = 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 (waitForCancel _id) $ act lspFuncs ide _params + cancelOrRes <- race (waitForCancel _id) act case cancelOrRes of Left () -> do - logDebug (ideLogger ide) $ T.pack $ - "Cancelled request " <> show _id - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left - $ ResponseError RequestCancelled "" Nothing - Right res -> k res + logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id + k $ ResponseError RequestCancelled "" Nothing + Right res -> pure res ) $ \(e :: SomeException) -> do logError (ideLogger ide) $ T.pack $ "Unexpected exception on request, please report!\n" ++ - "Message: " ++ show msg ++ "\n" ++ "Exception: " ++ show e - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left - $ ResponseError InternalError (T.pack $ show e) Nothing + k $ ResponseError InternalError (T.pack $ show e) Nothing -initializeRequestHandler :: PartialHandlers config -initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{ - LSP.initializeRequestHandler = withInitialize initHandler - } -initHandler - :: LSP.LspFuncs c - -> IdeState - -> InitializeParams - -> IO () -initHandler _ ide params = do - let initConfig = parseConfiguration params - logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig - registerIdeConfiguration (shakeExtras ide) initConfig - --- | Things that get sent to us, but we don't deal with. --- Set them to avoid a warning in VS Code output. -setHandlersIgnore :: PartialHandlers config -setHandlersIgnore = PartialHandlers $ \_ x -> return x - {LSP.responseHandler = none - } - where none = Just $ const $ return () - -cancelHandler :: (LspId -> IO ()) -> PartialHandlers config -cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x - {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do - cancelRequest _id - whenJust (LSP.cancelNotificationHandler x) ($ msg) - } - -exitHandler :: IO () -> PartialHandlers c -exitHandler exit = PartialHandlers $ \_ x -> return x - {LSP.exitNotificationHandler = Just $ const exit} +cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) +cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} -> + liftIO $ cancelRequest (SomeLspId _id) --- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety --- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer) -data Message c - = forall m req resp . (Show m, Show req, HasTracing req) => - Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) - | -- | Used for cases in which we need to send not only a response, - -- but also an additional request to the client. - -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request. - forall m rm req resp newReqParams newReqBody. (Show m, Show rm, Show req, HasTracing req) => - ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) - | forall m req . (Show m, Show req, HasTracing req) => - Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ()) - | -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler. - InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ()) +exitHandler :: IO () -> LSP.Handlers (ServerM c) +exitHandler exit = LSP.notificationHandler SExit (const $ liftIO exit) modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS } where - tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing} + tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ InR $ SaveOptions Nothing} origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing + diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -3,27 +3,27 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} module Development.IDE.LSP.Notifications ( setHandlersNotifications ) where -import Development.IDE.LSP.Server -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as LSP -import qualified Language.Haskell.LSP.Messages as LSP -import qualified Language.Haskell.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Capabilities as LSP import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service +import Development.IDE.LSP.Server import Development.IDE.Core.Shake import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options import Control.Monad.Extra -import qualified Data.Aeson as A import Data.Foldable as F import Data.Maybe import qualified Data.HashMap.Strict as M @@ -34,115 +34,111 @@ import Development.IDE.Core.FileExists (modifyFileExists, watchedGlobs) import Development.IDE.Core.OfInterest import Ide.Plugin.Config (CheckParents(CheckOnClose)) +import Control.Monad.IO.Class whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' -setHandlersNotifications :: PartialHandlers c -setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x - {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $ - \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do - updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) - whenUriFile _uri $ \file -> do - -- We don't know if the file actually exists, or if the contents match those on disk - -- For example, vscode restores previously unsaved contents on open - modifyFilesOfInterest ide (M.insert file Modified) - setFileModified ide False file - logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri - - ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $ - \_ ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> do - updatePositionMapping ide identifier changes - whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.insert file Modified) - setFileModified ide False file - logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri +setHandlersNotifications :: LSP.Handlers (ServerM c) +setHandlersNotifications = mconcat + [ notificationHandler LSP.STextDocumentDidOpen $ + \ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do + updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) + whenUriFile _uri $ \file -> do + -- We don't know if the file actually exists, or if the contents match those on disk + -- For example, vscode restores previously unsaved contents on open + modifyFilesOfInterest ide (M.insert file Modified{firstOpen=True}) + setFileModified ide False file + logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri - ,LSP.didSaveTextDocumentNotificationHandler = withNotification (LSP.didSaveTextDocumentNotificationHandler x) $ - \_ ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do - whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.insert file OnDisk) - setFileModified ide True file - logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri + , notificationHandler LSP.STextDocumentDidChange $ + \ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do + updatePositionMapping ide identifier changes + whenUriFile _uri $ \file -> do + modifyFilesOfInterest ide (M.insert file Modified{firstOpen=False}) + setFileModified ide False file + logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri - ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $ - \_ ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do - whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.delete file) - -- Refresh all the files that depended on this - IdeOptions{optCheckParents} <- getIdeOptionsIO $ shakeExtras ide - when (optCheckParents >= CheckOnClose) $ typecheckParents ide file - logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri - ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $ - \_ ide (DidChangeWatchedFilesParams fileEvents) -> do - -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and - -- what we do with them - let events = - mapMaybe - (\(FileEvent uri ev) -> - (, ev /= FcDeleted) . toNormalizedFilePath' - <$> LSP.uriToFilePath uri - ) - ( F.toList fileEvents ) - let msg = Text.pack $ show events - logDebug (ideLogger ide) $ "Files created or deleted: " <> msg - modifyFileExists ide events - setSomethingModified ide + , notificationHandler LSP.STextDocumentDidSave $ + \ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file -> do + modifyFilesOfInterest ide (M.insert file OnDisk) + setFileModified ide True file + logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri - ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $ - \_ ide (DidChangeWorkspaceFoldersParams events) -> do - let add = S.union - substract = flip S.difference - modifyWorkspaceFolders ide - $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) - . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) + , notificationHandler LSP.STextDocumentDidClose $ + \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do + whenUriFile _uri $ \file -> do + modifyFilesOfInterest ide (M.delete file) + -- Refresh all the files that depended on this + checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide) + when (checkParents >= CheckOnClose) $ typecheckParents ide file + logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri - ,LSP.didChangeConfigurationParamsHandler = withNotification (LSP.didChangeConfigurationParamsHandler x) $ - \_ ide (DidChangeConfigurationParams cfg) -> do - let msg = Text.pack $ show cfg - logInfo (ideLogger ide) $ "Configuration changed: " <> msg - modifyClientSettings ide (const $ Just cfg) - setSomethingModified ide + , notificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ + \ide (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do + -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and + -- what we do with them + let events = + mapMaybe + (\(FileEvent uri ev) -> + (, ev /= FcDeleted) . toNormalizedFilePath' + <$> LSP.uriToFilePath uri + ) + ( F.toList fileEvents ) + let msg = Text.pack $ show events + logDebug (ideLogger ide) $ "Files created or deleted: " <> msg + modifyFileExists ide events + setSomethingModified ide - -- Initialized handler, good time to dynamically register capabilities - ,LSP.initializedHandler = withNotification (LSP.initializedHandler x) $ \lsp@LSP.LspFuncs{..} ide _ -> do - let watchSupported = case () of - _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities - , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace - , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles - , Just True <- _dynamicRegistration - -> True - | otherwise -> False + , notificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ + \ide (DidChangeWorkspaceFoldersParams events) -> liftIO $ do + let add = S.union + substract = flip S.difference + modifyWorkspaceFolders ide + $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) + . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) - if watchSupported - then registerWatcher lsp ide - else logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling" + , notificationHandler LSP.SWorkspaceDidChangeConfiguration $ + \ide (DidChangeConfigurationParams cfg) -> liftIO $ do + let msg = Text.pack $ show cfg + logDebug (ideLogger ide) $ "Configuration changed: " <> msg + modifyClientSettings ide (const $ Just cfg) + setSomethingModified ide - } - where - registerWatcher LSP.LspFuncs{..} ide = do - lspId <- getNextReqId - opts <- getIdeOptionsIO $ shakeExtras ide - let - req = RequestMessage "2.0" lspId ClientRegisterCapability regParams - regParams = RegistrationParams (List [registration]) - -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't). - -- We could also use something like a random UUID, as some other servers do, but this works for - -- our purposes. - registration = Registration "globalFileWatches" - WorkspaceDidChangeWatchedFiles - (Just (A.toJSON regOptions)) - regOptions = - DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } - -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind - watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True} - -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is - -- The patterns will be something like "**/.hs", i.e. "any number of directory segments, - -- followed by a file with an extension 'hs'. - watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind } - -- We use multiple watchers instead of one using '{}' because lsp-test doesn't - -- support that: https://github.com/bubba/lsp-test/issues/77 - watchers = [ watcher glob | glob <- watchedGlobs opts ] + , notificationHandler LSP.SInitialized $ \ide _ -> do + clientCapabilities <- LSP.getClientCapabilities + let watchSupported = case () of + _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities + , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace + , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles + , Just True <- _dynamicRegistration + -> True + | otherwise -> False + if watchSupported + then do + opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide + let + regParams = RegistrationParams (List [SomeRegistration registration]) + -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't). + -- We could also use something like a random UUID, as some other servers do, but this works for + -- our purposes. + registration = Registration "globalFileWatches" + SWorkspaceDidChangeWatchedFiles + regOptions + regOptions = + DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } + -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind + watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True} + -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is + -- The patterns will be something like "**/.hs", i.e. "any number of directory segments, + -- followed by a file with an extension 'hs'. + watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind } + -- We use multiple watchers instead of one using '{}' because lsp-test doesn't + -- support that: https://github.com/bubba/lsp-test/issues/77 + watchers = [ watcher (Text.pack glob) | glob <- watchedGlobs opts ] - sendFunc $ LSP.ReqRegisterCapability req + void $ LSP.sendRequest SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response + else liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling" + ] diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} #include "ghc-api-version.h" module Development.IDE.LSP.Outline - ( setHandlersOutline - -- * For haskell-language-server - , moduleOutline + ( moduleOutline ) where -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types +import Language.LSP.Types +import Language.LSP.Server (LspM) +import Control.Monad.IO.Class import Data.Functor import Data.Generics import Data.Maybe @@ -23,26 +24,20 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error ( realSrcSpanToRange ) -import Development.IDE.LSP.Server import Development.IDE.Types.Location import Outputable ( Outputable , ppr , showSDocUnsafe ) -setHandlersOutline :: PartialHandlers c -setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x - { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline - } - moduleOutline - :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult) -moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri } - = case uriToFilePath uri of + :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) +moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } + = liftIO $ case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) pure $ Right $ case mb_decls of - Nothing -> DSDocumentSymbols (List []) + Nothing -> InL (List []) Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls @@ -64,10 +59,10 @@ } ] in - DSDocumentSymbols (List allSymbols) + InL (List allSymbols) - Nothing -> pure $ Right $ DSDocumentSymbols (List []) + Nothing -> pure $ Right $ InL (List []) documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) diff --git a/src/Development/IDE/LSP/Protocol.hs b/src/Development/IDE/LSP/Protocol.hs deleted file mode 100644 --- a/src/Development/IDE/LSP/Protocol.hs +++ /dev/null @@ -1,23 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE PatternSynonyms #-} - -module Development.IDE.LSP.Protocol - ( pattern EventFileDiagnostics - ) where - -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Location -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types - ----------------------------------------------------------------------------------------------------- --- Pretty printing ----------------------------------------------------------------------------------------------------- - --- | Pattern synonym to make it a bit more convenient to match on diagnostics --- in things like damlc test. -pattern EventFileDiagnostics :: FilePath -> [Diagnostic] -> FromServerMessage -pattern EventFileDiagnostics fp diags <- - NotPublishDiagnostics - (NotificationMessage _ _ (PublishDiagnosticsParams (uriToFilePath' -> Just fp) (List diags))) diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -5,81 +5,57 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} module Development.IDE.LSP.Server - ( WithMessage(..) - , PartialHandlers(..) - , HasTracing(..) - ,setUriAnd) where + ( ReactorMessage(..) + , ReactorChan + , ServerM + , requestHandler + , notificationHandler + ) where +import Language.LSP.Server (LspM, Handlers) +import Language.LSP.Types +import qualified Language.LSP.Server as LSP +import Development.IDE.Core.Shake +import UnliftIO.Chan +import Control.Monad.Reader +import Ide.Types (HasTracing, traceWithSpan) +import Development.IDE.Core.Tracing -import Control.Lens ((^.)) -import Data.Default +data ReactorMessage + = ReactorNotification (IO ()) + | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Core as LSP -import qualified Language.Haskell.LSP.Messages as LSP -import Language.Haskell.LSP.Types.Lens (HasTextDocument (textDocument), HasUri (uri)) -import Development.IDE.Core.Service -import Data.Aeson (Value) -import Development.IDE.Core.Tracing (otSetUri) -import OpenTelemetry.Eventlog (SpanInFlight, setTag) -import Data.Text.Encoding (encodeUtf8) +type ReactorChan = Chan ReactorMessage +type ServerM c = ReaderT (ReactorChan, IdeState) (LspM c) -data WithMessage c = WithMessage - {withResponse :: forall m req resp . (Show m, Show req, HasTracing req) => - (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response - (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work - Maybe (LSP.Handler (RequestMessage m req resp)) - ,withNotification :: forall m req . (Show m, Show req, HasTracing req) => - Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler - (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work - Maybe (LSP.Handler (NotificationMessage m req)) - ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody . - (Show m, Show rm, Show req, Show newReqParams, Show newReqBody, HasTracing req) => - (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response - (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req - (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work - Maybe (LSP.Handler (RequestMessage m req resp)) - , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ()) - -> Maybe (LSP.Handler InitializeRequest) - } +requestHandler + :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) => + SMethod m + -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m))) + -> Handlers (ServerM c) +requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do + st@(chan,ide) <- ask + env <- LSP.getLspEnv + let resp' = flip runReaderT st . resp + trace x = otTracedHandler "Request" (show _method) $ \sp -> do + traceWithSpan sp _params + x + writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) -newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers) +notificationHandler + :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) => + SMethod m + -> (IdeState -> MessageParams m -> LspM c ()) + -> Handlers (ServerM c) +notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do + (chan,ide) <- ask + env <- LSP.getLspEnv + let trace x = otTracedHandler "Notification" (show _method) $ \sp -> do + traceWithSpan sp _params + x + writeChan chan $ ReactorNotification (trace $ LSP.runLspT env $ k ide _params) -instance Default (PartialHandlers c) where - def = PartialHandlers $ \_ x -> pure x -instance Semigroup (PartialHandlers c) where - PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w - -instance Monoid (PartialHandlers c) where - mempty = def - -class HasTracing a where - traceWithSpan :: SpanInFlight -> a -> IO () - traceWithSpan _ _ = pure () - -instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where - traceWithSpan sp a = otSetUri sp (a ^. textDocument . uri) - -instance HasTracing Value -instance HasTracing ExecuteCommandParams -instance HasTracing DidChangeWatchedFilesParams -instance HasTracing DidChangeWorkspaceFoldersParams -instance HasTracing DidChangeConfigurationParams -instance HasTracing InitializeParams -instance HasTracing (Maybe InitializedParams) -instance HasTracing WorkspaceSymbolParams where - traceWithSpan sp (WorkspaceSymbolParams query _) = setTag sp "query" (encodeUtf8 query) - -setUriAnd :: - (HasTextDocument params a, HasUri a Uri) => - (lspFuncs -> ide -> params -> IO res) -> - lspFuncs -> - SpanInFlight -> - ide -> - params -> - IO res -setUriAnd k lf sp ide params = do - otSetUri sp (params ^. textDocument . uri) - k lf ide params diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Main.hs @@ -0,0 +1,224 @@ +module Development.IDE.Main (Arguments(..), defaultMain) where +import Control.Concurrent.Extra (readVar) +import Control.Exception.Safe ( + Exception (displayException), + catchAny, + ) +import Control.Monad.Extra (concatMapM, unless, when) +import Data.Default (Default (def)) +import qualified Data.HashMap.Strict as HashMap +import Data.List.Extra ( + intercalate, + isPrefixOf, + nub, + nubOrd, + partition, + ) +import Data.Maybe (catMaybes, fromMaybe, isJust) +import qualified Data.Text as T +import Development.IDE (Action, Rules, noLogging) +import Development.IDE.Core.Debouncer (newAsyncDebouncer) +import Development.IDE.Core.FileStore (makeVFSHandle) +import Development.IDE.Core.OfInterest ( + FileOfInterestStatus (OnDisk), + kick, + setFilesOfInterest, + ) +import Development.IDE.Core.RuleTypes ( + GenerateCore (GenerateCore), + GetHieAst (GetHieAst), + GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + TypeCheck (TypeCheck), + ) +import Development.IDE.Core.Rules ( + GhcSessionIO (GhcSessionIO), + mainRule, + ) +import Development.IDE.Core.Service (initialise, runAction) +import Development.IDE.Core.Shake ( + IdeState (shakeExtras), + ShakeExtras (state), + uses, + ) +import Development.IDE.Core.Tracing (measureMemory) +import Development.IDE.LSP.LanguageServer (runLanguageServer) +import Development.IDE.Plugin ( + Plugin (pluginHandlers, pluginRules), + ) +import Development.IDE.Plugin.HLS (asGhcIdePlugin) +import Development.IDE.Session (SessionLoadingOptions, loadSessionWithOptions, setInitialDynFlags, getHieDbLoc, runWithDb) +import Development.IDE.Types.Location (toNormalizedFilePath') +import Development.IDE.Types.Logger (Logger) +import Development.IDE.Types.Options ( + IdeGhcSession, + IdeOptions (optCheckParents, optCheckProject, optReportProgress), + clientSupportsProgress, + defaultIdeOptions, + ) +import Development.IDE.Types.Shake (Key (Key)) +import Development.Shake (action) +import HIE.Bios.Cradle (findCradle) +import Ide.Plugin.Config (CheckParents (NeverCheck), Config, getConfigFromNotification) +import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins) +import Ide.Types (IdePlugins) +import qualified Language.LSP.Server as LSP +import qualified System.Directory.Extra as IO +import System.Exit (ExitCode (ExitFailure), exitWith) +import System.FilePath (takeExtension, takeFileName) +import System.IO (hPutStrLn, hSetEncoding, stderr, stdout, utf8) +import System.Time.Extra (offsetTime, showDuration) +import Text.Printf (printf) +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide + +data Arguments = Arguments + { argsOTMemoryProfiling :: Bool + , argFiles :: Maybe [FilePath] -- ^ Nothing: lsp server ; Just: typecheck and exit + , argsLogger :: Logger + , 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 + } + +instance Default Arguments where + def = Arguments + { argsOTMemoryProfiling = False + , argFiles = Nothing + , argsLogger = noLogging + , argsRules = mainRule >> action kick + , argsGhcidePlugin = mempty + , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors + , argsSessionLoadingOptions = def + , argsIdeOptions = const defaultIdeOptions + , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."} + , argsDefaultHlsConfig = def + , argsGetHieDbLoc = getHieDbLoc + } + +defaultMain :: Arguments -> IO () +defaultMain Arguments{..} = do + pid <- T.pack . show <$> getProcessID + + let hlsPlugin = asGhcIdePlugin argsHlsPlugins + hlsCommands = allLspCmdIds' pid argsHlsPlugins + plugins = hlsPlugin <> argsGhcidePlugin + options = argsLspOptions { LSP.executeCommandCommands = Just hlsCommands } + argsOnConfigChange _ide = pure . getConfigFromNotification argsDefaultHlsConfig + rules = argsRules >> pluginRules plugins + + case argFiles of + Nothing -> 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 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') + -- before calling this function + _mlibdir <- + setInitialDynFlags argsSessionLoadingOptions + `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) + + sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath + config <- LSP.runLspT env LSP.getConfig + let options = (argsIdeOptions config sessionLoader) + { optReportProgress = clientSupportsProgress caps + } + caps = LSP.resClientCapabilities env + debouncer <- newAsyncDebouncer + initialise + rules + (Just env) + argsLogger + debouncer + options + vfs + 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 + + putStrLn $ "ghcide setup tester in " ++ dir ++ "." + putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" + + putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir + files <- expandFiles (argFiles ++ ["." | null argFiles]) + -- LSP works with absolute file paths, so try and behave similarly + files <- nubOrd <$> mapM IO.canonicalizePath files + putStrLn $ "Found " ++ show (length files) ++ " files" + + putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup" + cradles <- mapM findCradle files + let ucradles = nubOrd cradles + let n = length ucradles + putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] + when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" + putStrLn "\nStep 3/4: Initializing the IDE" + vfs <- makeVFSHandle + debouncer <- newAsyncDebouncer + sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir + let options = (argsIdeOptions Nothing sessionLoader) + { optCheckParents = pure NeverCheck + , optCheckProject = pure False + } + ide <- initialise rules Nothing argsLogger debouncer options vfs hiedb hieChan + + putStrLn "\nStep 4/4: Type checking the files" + setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files + results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files) + _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files) + _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files) + let (worked, failed) = partition fst $ zip (map isJust results) files + when (failed /= []) $ + putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed + + let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" + putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" + + when argsOTMemoryProfiling $ do + let valuesRef = state $ shakeExtras ide + values <- readVar valuesRef + let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6) + consoleObserver (Just k) = return $ \size -> printf " - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3) + + printf "# Shake value store contents(%d):\n" (length values) + let keys = + nub $ + Key GhcSession : + Key GhcSessionDeps : + [k | (_, k) <- HashMap.keys values, k /= Key GhcSessionIO] + ++ [Key GhcSessionIO] + measureMemory argsLogger [keys] consoleObserver valuesRef + + unless (null failed) (exitWith $ ExitFailure (length failed)) +{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-} + +expandFiles :: [FilePath] -> IO [FilePath] +expandFiles = concatMapM $ \x -> do + b <- IO.doesFileExist x + if b + then return [x] + else do + let recurse "." = True + recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc + recurse x = takeFileName x `notElem` ["dist", "dist-newstyle"] -- cabal directories + files <- filter (\x -> takeExtension x `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x + when (null files) $ + fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x + return files diff --git a/src/Development/IDE/Plugin.hs b/src/Development/IDE/Plugin.hs --- a/src/Development/IDE/Plugin.hs +++ b/src/Development/IDE/Plugin.hs @@ -1,22 +1,21 @@ -module Development.IDE.Plugin - ( Plugin(..) - ) where +module Development.IDE.Plugin ( Plugin(..) ) where import Data.Default import Development.Shake -import Development.IDE.LSP.Server +import Development.IDE.LSP.Server +import qualified Language.LSP.Server as LSP data Plugin c = Plugin {pluginRules :: Rules () - ,pluginHandler :: PartialHandlers c + ,pluginHandlers :: LSP.Handlers (ServerM c) } instance Default (Plugin c) where - def = Plugin mempty def + def = Plugin mempty mempty instance Semigroup (Plugin c) where - Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2) + Plugin x1 h1 <> Plugin x2 h2 = Plugin (x1<>x2) (h1 <> h2) instance Monoid (Plugin c) where mempty = def diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -2,7 +2,9 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} #include "ghc-api-version.h" -- | Go to the definition of a variable. @@ -14,6 +16,7 @@ ) where import Control.Monad (join, guard) +import Control.Monad.IO.Class import Development.IDE.GHC.Compat import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes @@ -29,9 +32,9 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Data.HashMap.Strict as Map -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.VFS -import Language.Haskell.LSP.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.VFS +import Language.LSP.Types import qualified Data.Rope.UTF16 as Rope import Data.Char import Data.Maybe @@ -58,42 +61,49 @@ import qualified GHC.LanguageExtensions as Lang import Control.Lens (alaf) import Data.Monoid (Ap(..)) +import TcRnTypes (TcGblEnv(..), ImportAvails(..)) +import HscTypes (ImportedModsVal(..), importedByUser) +import RdrName (GlobalRdrElt(..), lookupGlobalRdrEnv) +import SrcLoc (realSrcSpanStart) +import Module (moduleEnvElts) +import qualified Data.Map as M +import qualified Data.Set as S descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginRules = mempty, - pluginCodeActionProvider = Just codeAction + pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction } -- | Generate code actions. codeAction - :: LSP.LspFuncs c - -> IdeState + :: IdeState -> PluginId - -> TextDocumentIdentifier - -> Range - -> CodeActionContext - -> IO (Either ResponseError (List CAResult)) -codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do - contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri + -> CodeActionParams + -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction))) +codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do + contents <- LSP.getVirtualFile $ toNormalizedUri uri + liftIO $ do let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state - (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS) <- runAction "CodeAction" state $ - (,,,) <$> getIdeOptions + (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har) <- runAction "CodeAction" state $ + (,,,,,) <$> getIdeOptions <*> getParsedModule `traverse` mbFile <*> use GhcSession `traverse` mbFile <*> use GetAnnotatedParsedSource `traverse` mbFile + <*> use TypeCheck `traverse` mbFile + <*> use GetHieAst `traverse` mbFile -- This is quite expensive 0.6-0.7s on GHC - let pkgExports = envPackageExports <$> env + pkgExports <- maybe mempty envPackageExports env localExports <- readVar (exportsMap $ shakeExtras state) let - exportsMap = localExports <> fromMaybe mempty pkgExports + exportsMap = localExports <> pkgExports df = ms_hspp_opts . pm_mod_summary <$> parsedModule actions = [ mkCA title [x] edit - | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS x + | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har x , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing ] actions' = caRemoveRedundantImports parsedModule text diag xs uri @@ -101,9 +111,9 @@ <> caRemoveInvalidExports parsedModule text diag xs uri pure $ Right $ List actions' -mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> CAResult +mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) mkCA title diags edit = - CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) (Just edit) Nothing + InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) Nothing Nothing (Just edit) Nothing rewrite :: Maybe DynFlags -> @@ -123,9 +133,11 @@ -> Maybe T.Text -> Maybe DynFlags -> Maybe (Annotated ParsedSource) + -> Maybe TcModuleResult + -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [TextEdit])] -suggestAction packageExports ideOptions parsedModule text df annSource diag = +suggestAction packageExports ideOptions parsedModule text df annSource tcM har diag = concat -- Order these suggestions by priority [ suggestSignature True diag @@ -140,6 +152,7 @@ , suggestAddTypeAnnotationToSatisfyContraints text diag , rewrite df annSource $ \df ps -> suggestConstraint df ps diag , rewrite df annSource $ \_ ps -> suggestImplicitParameter ps diag + , rewrite df annSource $ \_ ps -> suggestHideShadow ps tcM har diag ] ++ concat [ suggestNewDefinition ideOptions pm text diag ++ suggestNewImport packageExports pm diag @@ -169,9 +182,84 @@ findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a) findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l) +-- Single: +-- This binding for ‘mod’ shadows the existing binding +-- imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40 +-- (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing) +-- Multi: +--This binding for ‘pack’ shadows the existing bindings +-- imported from ‘Data.ByteString’ at B.hs:6:1-22 +-- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 +-- imported from ‘Data.Text’ at B.hs:7:1-16 +suggestHideShadow :: ParsedSource -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Rewrite])] +suggestHideShadow pm@(L _ HsModule {hsmodImports}) mTcM mHar Diagnostic {_message, _range} + | Just [identifier, modName, s] <- + matchRegexUnifySpaces + _message + "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" = + suggests identifier modName s + | Just [identifier] <- + matchRegexUnifySpaces + _message + "This binding for ‘([^`]+)’ shadows the existing bindings", + Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)", + mods <- [(modName, s) | [_, modName, s] <- matched], + result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier), + hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) = + result <> [hideAll] + | otherwise = [] + where + suggests identifier modName s + | Just tcM <- mTcM, + Just har <- mHar, + [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s'), + mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, + title <- "Hide " <> identifier <> " from " <> modName = + if modName == "Prelude" && null mDecl + then [(title, maybeToList $ hideImplicitPreludeSymbol (T.unpack identifier) pm)] + else maybeToList $ (title,) . pure . hideSymbol (T.unpack identifier) <$> mDecl + | otherwise = [] + +findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) +findImportDeclByModuleName decls modName = flip find decls $ \case + (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName) + _ -> error "impossible" + +isTheSameLine :: SrcSpan -> SrcSpan -> Bool +isTheSameLine s1 s2 + | Just sl1 <- getStartLine s1, + Just sl2 <- getStartLine s2 = + sl1 == sl2 + | otherwise = False + where + getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x + +isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool +isUnusedImportedId + TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}} + HAR {refMap} + identifier + modName + importSpan + | occ <- mkVarOcc identifier, + impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods, + Just rdrEnv <- + listToMaybe + [ imv_all_exports + | ImportedModsVal {..} <- impModsVals, + imv_name == mkModuleName modName, + isTheSameLine imv_span importSpan + ], + [GRE {..}] <- lookupGlobalRdrEnv rdrEnv occ, + importedIdentifier <- Right gre_name, + refs <- M.lookup importedIdentifier refMap = + maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs + | otherwise = False + suggestDisableWarning :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestDisableWarning pm contents Diagnostic{..} - | Just (StringValue (T.stripPrefix "-W" -> Just w)) <- _code = + | Just (InR (T.stripPrefix "-W" -> Just w)) <- _code = pure ( "Disable \"" <> w <> "\" warnings" , [TextEdit (endOfModuleHeader pm contents) $ "{-# OPTIONS_GHC -Wno-" <> w <> " #-}\n"] @@ -197,7 +285,7 @@ = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] | otherwise = [] -caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [CAResult] +caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] caRemoveRedundantImports m contents digs ctxDigs uri | Just pm <- m, r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs, @@ -212,16 +300,18 @@ removeSingle title tedit diagnostic = mkCA title [diagnostic] WorkspaceEdit{..} where _changes = Just $ Map.singleton uri $ List tedit _documentChanges = Nothing - removeAll tedit = CACodeAction CodeAction {..} where + removeAll tedit = InR $ CodeAction{..} where _changes = Just $ Map.singleton uri $ List tedit _title = "Remove all redundant imports" _kind = Just CodeActionQuickFix _diagnostics = Nothing _documentChanges = Nothing _edit = Just WorkspaceEdit{..} + _isPreferred = Nothing _command = Nothing + _disabled = Nothing -caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [CAResult] +caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] caRemoveInvalidExports m contents digs ctxDigs uri | Just pm <- m, Just txt <- contents, @@ -245,7 +335,7 @@ | otherwise = Nothing removeSingle (_, _, []) = Nothing - removeSingle (title, diagnostic, ranges) = Just $ CACodeAction CodeAction{..} where + removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges _changes = Just $ Map.singleton uri $ List tedit _title = title @@ -254,8 +344,10 @@ _documentChanges = Nothing _edit = Just WorkspaceEdit{..} _command = Nothing + _isPreferred = Nothing + _disabled = Nothing removeAll [] = Nothing - removeAll ranges = Just $ CACodeAction CodeAction {..} where + removeAll ranges = Just $ InR $ CodeAction{..} where tedit = concatMap (\r -> [TextEdit r ""]) ranges _changes = Just $ Map.singleton uri $ List tedit _title = "Remove all redundant exports" @@ -264,6 +356,8 @@ _documentChanges = Nothing _edit = Just WorkspaceEdit{..} _command = Nothing + _isPreferred = Nothing + _disabled = Nothing suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} @@ -614,7 +708,7 @@ Valid refinement hole fits include fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers) fromJust (_ :: Maybe LSP.Handlers) - haskell-lsp-types-0.22.0.0:Language.Haskell.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams + haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams LSP.Handlers) T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers) (_ :: LSP.Handlers) diff --git a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs --- a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -31,18 +31,18 @@ import Development.IDE.GHC.ExactPrint ( Annotate, ASTElement(parseAST) ) import FieldLabel (flLabel) -import GhcPlugins (sigPrec) +import GhcPlugins (sigPrec, mkRealSrcLoc) import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) -import Language.Haskell.LSP.Types +import Language.LSP.Types import OccName import Outputable (ppr, showSDocUnsafe, showSDoc) import Retrie.GHC (rdrNameOcc, unpackFS, mkRealSrcSpan, realSrcSpanEnd) import Development.IDE.Spans.Common import Development.IDE.GHC.Error -import Safe (lastMay) import Data.Generics (listify) import GHC.Exts (IsList (fromList)) +import Control.Monad.Extra (whenJust) ------------------------------------------------------------------------------ @@ -205,6 +205,7 @@ -- extendImportTopLevel "foo" AST: -- -- import A --> Error +-- import A (foo) --> Error -- import A (bar) --> import A (bar, foo) extendImportTopLevel :: DynFlags -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) extendImportTopLevel df idnetifier (L l it@ImportDecl {..}) @@ -382,6 +383,8 @@ lidecl' = L l $ idecl { ideclHiding = Just (False, edited) } + -- avoid import A (foo,) + whenJust (lastMaybe deletedLies) removeTrailingCommaT when (not (null lies) && null deletedLies) $ do transferAnn llies edited id addSimpleAnnT edited dp00 @@ -408,13 +411,16 @@ (filter ((/= symbol) . T.pack . unpackFS . flLabel . unLoc) flds) killLie v = Just v +-- | Insert a import declaration hiding a symbole from Prelude hideImplicitPreludeSymbol :: String -> ParsedSource -> Maybe Rewrite hideImplicitPreludeSymbol symbol (L _ HsModule{..}) = do - existingImp <- lastMay hsmodImports - exisImpSpan <- realSpan $ getLoc existingImp - let indentation = srcSpanStartCol exisImpSpan - beg = realSrcSpanEnd exisImpSpan + let predLine old = mkRealSrcLoc (srcLocFile old) (srcLocLine old - 1) (srcLocCol old) + existingImpSpan = (fmap (id,) . realSpan . getLoc) =<< lastMaybe hsmodImports + existingDeclSpan = (fmap (predLine, ) . realSpan . getLoc) =<< headMaybe hsmodDecls + (f, s) <- existingImpSpan <|> existingDeclSpan + let beg = f $ realSrcSpanEnd s + indentation = srcSpanStartCol s ran = RealSrcSpan $ mkRealSrcSpan beg beg pure $ Rewrite ran $ \df -> do let symOcc = mkVarOcc symbol @@ -424,6 +430,6 @@ -- Re-labeling is needed to reflect annotations correctly L _ idecl0 <- liftParseAST @(ImportDecl GhcPs) df $ T.unpack impStmt let idecl = L ran idecl0 - addSimpleAnnT idecl (DP (1,indentation - 1)) + addSimpleAnnT idecl (DP (1, indentation - 1)) [(G AnnImport, DP (1, indentation - 1))] pure idecl diff --git a/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs --- a/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +++ b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -12,7 +12,7 @@ import Data.Char import Data.List -import Language.Haskell.LSP.Types +import Language.LSP.Types type PositionIndexed a = [(Position, a)] diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} #include "ghc-api-version.h" @@ -7,16 +8,17 @@ , LocalCompletions(..) , NonLocalCompletions(..) ) where -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Core as LSP -import qualified Language.Haskell.LSP.VFS as VFS import Control.Monad +import Control.Monad.Extra import Control.Monad.Trans.Maybe import Data.Aeson import Data.List (find) import Data.Maybe import qualified Data.Text as T +import Language.LSP.Types +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.VFS as VFS import Development.Shake.Classes import Development.Shake import GHC.Generics @@ -36,16 +38,16 @@ import Ide.Types import TcRnDriver (tcRnImportDecls) import Control.Concurrent.Async (concurrently) -#if defined(GHC_LIB) -import Development.IDE.Import.DependencyInformation -#endif +import GHC.Exts (toList) +import Development.IDE.GHC.Error (rangeToSrcSpan) +import Development.IDE.GHC.Util (prettyPrint) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = produceCompletions, - pluginCompletionProvider = Just (getCompletionsLSP plId), - pluginCommands = [extendImportCommand] - } + { pluginRules = produceCompletions + , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP + , pluginCommands = [extendImportCommand] + } produceCompletions :: Rules () produceCompletions = do @@ -64,15 +66,6 @@ ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file sess <- fmap fst <$> useWithStale GhcSessionDeps file --- When possible, rely on the haddocks embedded in our interface files --- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc' -#if !defined(GHC_LIB) - let parsedDeps = [] -#else - deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file - parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps) -#endif - case (ms, sess) of (Just (ms,imps), Just sess) -> do let env = hscEnv sess @@ -81,7 +74,7 @@ case (global, inScope) of ((_, Just globalEnv), (_, Just inScopeEnv)) -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file - cdata <- liftIO $ cacheDataProducer uri env (ms_mod ms) globalEnv inScopeEnv imps parsedDeps + cdata <- liftIO $ cacheDataProducer uri sess (ms_mod ms) globalEnv inScopeEnv imps return ([], Just cdata) (_diag, _) -> return ([], Nothing) @@ -115,20 +108,19 @@ -- | Generate code actions. getCompletionsLSP - :: PluginId - -> LSP.LspFuncs Config - -> IdeState + :: IdeState + -> PluginId -> CompletionParams - -> IO (Either ResponseError CompletionResponseResult) -getCompletionsLSP plId lsp ide + -> LSP.LspM Config (Either ResponseError (ResponseResult TextDocumentCompletion)) +getCompletionsLSP ide plId CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position ,_context=completionContext} = do - contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri + contents <- LSP.getVirtualFile $ toNormalizedUri uri fmap Right $ case (contents, uriToFilePath' uri) of (Just cnts, Just path) -> do let npath = toNormalizedFilePath' path - (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do + (ideOpts, compls) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide localCompls <- useWithStaleFast LocalCompletions npath nonLocalCompls <- useWithStaleFast NonLocalCompletions npath @@ -140,16 +132,16 @@ pfix <- VFS.getCompletionPrefix position cnts case (pfix, completionContext) of (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) - -> return (Completions $ List []) + -> return (InL $ List []) (Just pfix', _) -> do let clientCaps = clientCapabilities $ shakeExtras ide - config <- getClientConfig lsp + config <- getClientConfig let snippets = WithSnippets . completionSnippetsOn $ config - allCompletions <- getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps snippets - pure $ Completions (List allCompletions) - _ -> return (Completions $ List []) - _ -> return (Completions $ List []) - _ -> return (Completions $ List []) + allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps snippets + pure $ InL (List allCompletions) + _ -> return (InL $ List []) + _ -> return (InL $ List []) + _ -> return (InL $ List []) ---------------------------------------------------------------------------------------------------- @@ -158,16 +150,29 @@ PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler extendImportHandler :: CommandFunction IdeState ExtendImport -extendImportHandler _lsp ideState edit = do - res <- runMaybeT $ extendImportHandler' ideState edit - return (Right Null, res) +extendImportHandler ideState edit@ExtendImport {..} = do + res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit + whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do + let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . toList + srcSpan = rangeToSrcSpan nfp _range + LSP.sendNotification SWindowShowMessage $ + ShowMessageParams MtInfo $ + "Import " + <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent + <> "’ from " + <> importName + <> " (at " + <> T.pack (prettyPrint srcSpan) + <> ")" + void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right Null -extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (ServerMethod, ApplyWorkspaceEditParams) +extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) extendImportHandler' ideState ExtendImport {..} | Just fp <- uriToFilePath doc, nfp <- toNormalizedFilePath' fp = do - (ms, ps, imps) <- MaybeT $ + (ms, ps, imps) <- MaybeT $ liftIO $ runAction "extend import" ideState $ runMaybeT $ do -- We want accurate edits, so do not use stale data here @@ -178,11 +183,9 @@ wantedModule = mkModuleName (T.unpack importName) wantedQual = mkModuleName . T.unpack <$> importQual imp <- liftMaybe $ find (isWantedModule wantedModule wantedQual) imps - wedit <- - liftEither $ - rewriteToWEdit df doc (annsA ps) $ - extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp - return (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit) + fmap (nfp,) $ liftEither $ + rewriteToWEdit df doc (annsA ps) $ + extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp | otherwise = mzero diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -27,16 +27,15 @@ import Name import RdrName import Type -import Packages #if MIN_GHC_API_VERSION(8,10,0) import Predicate (isDictTy) import Pair import Coercion #endif -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities -import qualified Language.Haskell.LSP.VFS as VFS +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import qualified Language.LSP.VFS as VFS import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping import Development.IDE.Plugin.Completions.Types @@ -59,6 +58,7 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), PluginId, WithSnippets (..)) import Control.Monad +import Development.IDE.Types.HscEnvEq -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -203,16 +203,16 @@ T.intercalate sectionSeparator docs' mkAdditionalEditsCommand :: PluginId -> ExtendImport -> IO Command -mkAdditionalEditsCommand pId edits = +mkAdditionalEditsCommand pId edits = pure $ mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) -mkNameCompItem :: Uri -> Maybe T.Text -> Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem +mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI {..} where - compKind = occNameToComKind typeText $ occName origName + compKind = occNameToComKind typeText origName importedFrom = Right $ showModName origMod - isTypeCompl = isTcOcc $ occName origName - label = showGhc origName + isTypeCompl = isTcOcc origName + label = stripPrefix $ showGhc origName insertText = case isInfix of Nothing -> case getArgText <$> thingType of Nothing -> label @@ -294,9 +294,10 @@ Nothing Nothing Nothing Nothing Nothing -cacheDataProducer :: Uri -> HscEnv -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO CachedCompletions -cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = do - let dflags = hsc_dflags packageState +cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions +cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do + let + packageState = hscEnv env curModName = moduleName curMod importMap = Map.fromList [ (getLoc imp, imp) | imp <- limports ] @@ -309,8 +310,6 @@ -- Full canonical names of imported modules importDeclerations = map unLoc limports - -- The list of all importable Modules from all packages - moduleNames = map showModName (listVisibleModuleNames dflags) -- The given namespaces for the imported modules (ie. full name, or alias if used) allModNamesAsNS = map (showModName . asNamespace) importDeclerations @@ -344,11 +343,11 @@ toCompItem :: Parent -> Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem] toCompItem par m mn n imp' = do - docs <- getDocumentationTryGhc packageState curMod deps n - let mbParent = case par of - NoParent -> Nothing - ParentIs n -> Just (showNameWithoutUniques n) - FldParent n _ -> Just (showNameWithoutUniques n) + docs <- getDocumentationTryGhc packageState curMod n + let (mbParent, originName) = case par of + NoParent -> (Nothing, nameOccName n) + ParentIs n' -> (Just $ showNameWithoutUniques n', nameOccName n) + FldParent n' lbl -> (Just $ showNameWithoutUniques n', maybe (nameOccName n) mkVarOccFS lbl) tys <- catchSrcErrors (hsc_dflags packageState) "completion" $ do name' <- lookupName packageState m n return ( name' >>= safeTyThingType @@ -361,11 +360,14 @@ [mkRecordSnippetCompItem uri mbParent ctxStr flds (ppr mn) docs imp'] _ -> [] - return $ mkNameCompItem uri mbParent n mn ty Nothing docs imp' + return $ mkNameCompItem uri mbParent originName mn ty Nothing docs imp' : recordCompls (unquals,quals) <- getCompls rdrElts + -- The list of all importable Modules from all packages + moduleNames <- maybe [] (map showModName) <$> envVisibleModuleNames env + return $ CC { allModNamesAsNS = allModNamesAsNS , unqualCompls = unquals @@ -588,7 +590,7 @@ -> return $ filtPragmaCompls (pragmaSuffix fullLine) | otherwise -> do let uniqueFiltCompls = nubOrdOn insertText filtCompls - compls <- mapM (mkCompl plId ideOpts . stripAutoGenerated) uniqueFiltCompls + compls <- mapM (mkCompl plId ideOpts) uniqueFiltCompls return $ filtModNameCompls ++ filtKeywordCompls ++ map ( toggleSnippets caps withSnippets) compls @@ -657,16 +659,11 @@ -- | Under certain circumstance GHC generates some extra stuff that we -- don't want in the autocompleted symbols -stripAutoGenerated :: CompItem -> CompItem -stripAutoGenerated ci = - ci {label = stripPrefix (label ci)} {- When e.g. DuplicateRecordFields is enabled, compiler generates names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation -} - -- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace. - stripPrefix :: T.Text -> T.Text stripPrefix name = T.takeWhile (/=':') $ go prefixes where diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -13,7 +13,9 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import GHC.Generics (Generic) -import Language.Haskell.LSP.Types (CompletionItemKind, Uri) +import Language.LSP.Types (CompletionItemKind, Uri) + +-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs data Backtick = Surrounded | LeftSide deriving (Eq, Ord, Show) diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -1,67 +1,55 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} module Development.IDE.Plugin.HLS ( asGhcIdePlugin ) where -import Control.Exception(SomeException, catch) -import Control.Lens ((^.)) +import Control.Exception(SomeException) import Control.Monad import qualified Data.Aeson as J -import qualified Data.DList as DList import Data.Either import qualified Data.List as List import qualified Data.Map as Map -import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Shake import Development.IDE.LSP.Server import Development.IDE.Plugin -import Development.IDE.Plugin.HLS.Formatter -import GHC.Generics import Ide.Plugin.Config import Ide.Types as HLS -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as J -import qualified Language.Haskell.LSP.Types.Capabilities as C -import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) -import qualified Language.Haskell.LSP.VFS as VFS +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as J +import Language.LSP.Types import Text.Regex.TDFA.Text() import Development.Shake (Rules) -import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID) +import Ide.PluginUtils (getClientConfig) import Development.IDE.Core.Tracing -import Development.IDE.Types.Logger (logDebug) -import Control.Concurrent.Async (mapConcurrently) +import UnliftIO.Async (forConcurrently) +import UnliftIO.Exception (catchAny) +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum +import Data.List.NonEmpty (nonEmpty,NonEmpty,toList) +import UnliftIO (MonadUnliftIO) +import Data.String +import Data.Bifunctor -- --------------------------------------------------------------------- +-- --- | Map a set of plugins to the underlying ghcide engine. Main point is --- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message --- category ('Notifaction', 'Request' etc). +-- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config asGhcIdePlugin mp = - mkPlugin rulesPlugins (Just . HLS.pluginRules) <> - mkPlugin executeCommandPlugins (Just . pluginCommands) <> - mkPlugin codeActionPlugins pluginCodeActionProvider <> - mkPlugin codeLensPlugins pluginCodeLensProvider <> - -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider - mkPlugin hoverPlugins pluginHoverProvider <> - mkPlugin symbolsPlugins pluginSymbolsProvider <> - mkPlugin formatterPlugins pluginFormattingProvider <> - mkPlugin completionsPlugins pluginCompletionProvider <> - mkPlugin renamePlugins pluginRenameProvider + mkPlugin rulesPlugins HLS.pluginRules <> + mkPlugin executeCommandPlugins HLS.pluginCommands <> + mkPlugin extensiblePlugins HLS.pluginHandlers where - justs (p, Just x) = [(p, x)] - justs (_, Nothing) = [] - ls = Map.toList (ipMap mp) - mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> Maybe b) -> Plugin Config + mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config mkPlugin maker selector = - case concatMap (\(pid, p) -> justs (pid, selector p)) ls of + case map (second selector) ls of -- If there are no plugins that provide a descriptor, use mempty to -- create the plugin – otherwise we we end up declaring handlers for -- capabilities that there are no plugins for @@ -75,418 +63,123 @@ where rules = foldMap snd rs -codeActionPlugins :: [(PluginId, CodeActionProvider IdeState)] -> Plugin Config -codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) - -codeActionRules :: Rules () -codeActionRules = mempty - -codeActionHandlers :: [(PluginId, CodeActionProvider IdeState)] -> PartialHandlers Config -codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.codeActionHandler - = withResponse RspCodeAction (makeCodeAction cas) - } - -makeCodeAction :: [(PluginId, CodeActionProvider IdeState)] - -> LSP.LspFuncs Config -> IdeState - -> CodeActionParams - -> IO (Either ResponseError (List CAResult)) -makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do - let caps = LSP.clientCapabilities lf - unL (List ls) = ls - makeAction (pid,provider) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcCodeActionsOn - then otTracedProvider pid "codeAction" $ provider lf ideState pid docId range context - else return $ Right (List []) - r <- mapConcurrently makeAction cas - let actions = filter wasRequested . foldMap unL $ rights r - res <- send caps actions - return $ Right res - where - wasRequested :: CAResult -> Bool - wasRequested (CACommand _) = True - wasRequested (CACodeAction ca) - | Nothing <- only context = True - | Just (List allowed) <- only context - , Just caKind <- ca ^. kind = caKind `elem` allowed - | otherwise = False - - wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult) - wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd) - wrapCodeAction caps (CACodeAction action) = do - - let (C.ClientCapabilities _ textDocCaps _ _) = caps - let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport - - case literalSupport of - Nothing -> do - let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] - cmd <- mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams) - return $ Just (CACommand cmd) - Just _ -> return $ Just (CACodeAction action) - - send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult) - send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions - -data FallbackCodeActionParams = - FallbackCodeActionParams - { fallbackWorkspaceEdit :: Maybe WorkspaceEdit - , fallbackCommand :: Maybe Command - } - deriving (Generic, J.ToJSON, J.FromJSON) - --- ----------------------------------------------------------- - -codeLensPlugins :: [(PluginId, CodeLensProvider IdeState)] -> Plugin Config -codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas) - -codeLensRules :: Rules () -codeLensRules = mempty - -codeLensHandlers :: [(PluginId, CodeLensProvider IdeState)] -> PartialHandlers Config -codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.codeLensHandler - = withResponse RspCodeLens (makeCodeLens cas) - } - -makeCodeLens :: [(PluginId, CodeLensProvider IdeState)] - -> LSP.LspFuncs Config - -> IdeState - -> CodeLensParams - -> IO (Either ResponseError (List CodeLens)) -makeCodeLens cas lf ideState params = do - logDebug (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ - let - makeLens (pid, provider) = do - pluginConfig <- getPluginConfig lf pid - r <- if pluginEnabled pluginConfig plcCodeLensOn - then otTracedProvider pid "codeLens" $ provider lf ideState pid params - else return $ Right (List []) - return (pid, r) - breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)]) - breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls) - where - doOneLeft (pid, Left err) = [(pid,err)] - doOneLeft (_, Right _) = [] - - doOneRight (pid, Right a) = [(pid,a)] - doOneRight (_, Left _) = [] - - r <- mapConcurrently makeLens cas - case breakdown r of - ([],[]) -> return $ Right $ List [] - (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing - (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs) - --- ----------------------------------------------------------- +-- --------------------------------------------------------------------- executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) -executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> PartialHandlers Config -executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ - LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs) - } - -makeExecuteCommands :: [(PluginId, [PluginCommand IdeState])] -> LSP.LspFuncs Config -> ExecuteCommandProvider IdeState -makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do - let - pluginMap = Map.fromList ecs - parseCmdId :: T.Text -> Maybe (PluginId, CommandId) - parseCmdId x = case T.splitOn ":" x of - [plugin, command] -> Just (PluginId plugin, CommandId command) - [_, plugin, command] -> Just (PluginId plugin, CommandId command) - _ -> Nothing - - execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) - execCmd (ExecuteCommandParams cmdId args _) = do - -- The parameters to the HIE command are always the first element - let cmdParams :: J.Value - cmdParams = case args of - Just (J.List (x:_)) -> x - _ -> J.Null - - case parseCmdId cmdId of - -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions - Just ("hls", "fallbackCodeAction") -> - case J.fromJSON cmdParams of - J.Success (FallbackCodeActionParams mEdit mCmd) -> do - - -- Send off the workspace request if it has one - forM_ mEdit $ \edit -> do - let eParams = J.ApplyWorkspaceEditParams edit - reqId <- LSP.getNextReqId lf - LSP.sendFunc lf $ ReqApplyWorkspaceEdit $ RequestMessage "2.0" reqId WorkspaceApplyEdit eParams - - case mCmd of - -- If we have a command, continue to execute it - Just (J.Command _ innerCmdId innerArgs) - -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing) - Nothing -> return (Right J.Null, Nothing) - - J.Error _str -> return (Right J.Null, Nothing) - - -- Just an ordinary HIE command - Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams +executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) +executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd + where + pluginMap = Map.fromList ecs - -- Couldn't parse the command identifier - _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing) + parseCmdId :: T.Text -> Maybe (PluginId, CommandId) + parseCmdId x = case T.splitOn ":" x of + [plugin, command] -> Just (PluginId plugin, CommandId command) + [_, plugin, command] -> Just (PluginId plugin, CommandId command) + _ -> Nothing - execCmd + -- The parameters to the HLS command are always the first element + execCmd ide (ExecuteCommandParams _ cmdId args) = do + let cmdParams :: J.Value + cmdParams = case args of + Just (J.List (x:_)) -> x + _ -> J.Null + case parseCmdId cmdId of + -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions + Just ("hls", "fallbackCodeAction") -> + case J.fromJSON cmdParams of + J.Success (FallbackCodeActionParams mEdit mCmd) -> do --- ----------------------------------------------------------- -wrapUnhandledExceptions :: - (a -> IO (Either ResponseError J.Value, Maybe b)) -> - a -> IO (Either ResponseError J.Value, Maybe b) -wrapUnhandledExceptions action input = - catch (action input) $ \(e::SomeException) -> do - let resp = ResponseError InternalError (T.pack $ show e) Nothing - return (Left resp, Nothing) + -- Send off the workspace request if it has one + forM_ mEdit $ \edit -> + LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + case mCmd of + -- If we have a command, continue to execute it + Just (J.Command _ innerCmdId innerArgs) + -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) + Nothing -> return $ Right J.Null --- | Runs a plugin command given a PluginId, CommandId and --- arguments in the form of a JSON object. -runPluginCommand :: Map.Map PluginId [PluginCommand IdeState] - -> LSP.LspFuncs Config - -> IdeState - -> PluginId - -> CommandId - -> J.Value - -> IO (Either ResponseError J.Value, - Maybe (ServerMethod, ApplyWorkspaceEditParams)) -runPluginCommand m lf ide p@(PluginId p') com@(CommandId com') arg = - case Map.lookup p m of - Nothing -> return - (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing) - Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> return (Left $ - ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' - <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing) - Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> return (Left $ - ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' - <> ": " <> T.pack err - <> "\narg = " <> T.pack (show arg)) Nothing, Nothing) - J.Success a -> f lf ide a + J.Error _str -> return $ Right J.Null --- ----------------------------------------------------------- + -- Just an ordinary HIE command + Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams -mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command -mkLspCommand plid cn title args' = do - pid <- T.pack . show <$> getProcessID - let cmdId = mkLspCmdId pid plid cn - let args = List <$> args' - return $ Command title cmdId args + -- Couldn't parse the command identifier + _ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing -mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text -mkLspCmdId pid (PluginId plid) (CommandId cid) - = pid <> ":" <> plid <> ":" <> cid + runPluginCommand ide p@(PluginId p') com@(CommandId com') arg = + case Map.lookup p pluginMap of + Nothing -> return + (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing) + Just xs -> case List.find ((com ==) . commandId) xs of + Nothing -> return $ Left $ + ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' + <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing + Just (PluginCommand _ _ f) -> case J.fromJSON arg of + J.Error err -> return $ Left $ + ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' + <> ": " <> T.pack err + <> "\narg = " <> T.pack (show arg)) Nothing + J.Success a -> f ide a -- --------------------------------------------------------------------- -hoverPlugins :: [(PluginId, HoverProvider IdeState)] -> Plugin Config -hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) - -hoverRules :: Rules () -hoverRules = mempty - -hoverHandlers :: [(PluginId, HoverProvider IdeState)] -> PartialHandlers Config -hoverHandlers hps = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)} - -makeHover :: [(PluginId, HoverProvider IdeState)] - -> LSP.LspFuncs Config -> IdeState - -> TextDocumentPositionParams - -> IO (Either ResponseError (Maybe Hover)) -makeHover hps lf ideState params - = do - let - makeHover(pid,p) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcHoverOn - then otTracedProvider pid "hover" $ p ideState params - else return $ Right Nothing - mhs <- mapConcurrently makeHover hps - -- TODO: We should support ServerCapabilities and declare that - -- we don't support hover requests during initialization if we - -- don't have any hover providers - -- TODO: maybe only have provider give MarkedString and - -- work out range here? - let hs = catMaybes (rights mhs) - r = listToMaybe $ mapMaybe (^. range) hs - h = case foldMap (^. contents) hs of - HoverContentsMS (List []) -> Nothing - hh -> Just $ Hover hh r - return $ Right h - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -symbolsPlugins :: [(PluginId, SymbolsProvider IdeState)] -> Plugin Config -symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs) - -symbolsRules :: Rules () -symbolsRules = mempty - -symbolsHandlers :: [(PluginId, SymbolsProvider IdeState)] -> PartialHandlers Config -symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x -> - return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)} - -makeSymbols :: [(PluginId, SymbolsProvider IdeState)] - -> LSP.LspFuncs Config - -> IdeState - -> DocumentSymbolParams - -> IO (Either ResponseError DSResult) -makeSymbols sps lf ideState params - = do - let uri' = params ^. textDocument . uri - (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf - supportsHierarchy = Just True == (tdc >>= C._documentSymbol >>= C._hierarchicalDocumentSymbolSupport) - convertSymbols :: [DocumentSymbol] -> DSResult - convertSymbols symbs - | supportsHierarchy = DSDocumentSymbols $ List symbs - | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs) - where - go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] - go parent ds = - let children' :: [SymbolInformation] - children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) - loc = Location uri' (ds ^. range) - name' = ds ^. name - si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent - in [si] <> children' - - makeSymbols (pid,p) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcSymbolsOn - then otTracedProvider pid "symbols" $ p lf ideState params - else return $ Right [] - mhs <- mapConcurrently makeSymbols sps - case rights mhs of - [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs - hs -> return $ Right $ convertSymbols $ concat hs - - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -renamePlugins :: [(PluginId, RenameProvider IdeState)] -> Plugin Config -renamePlugins providers = Plugin rules handlers +extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config +extensiblePlugins xs = Plugin mempty handlers where - rules = mempty - handlers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.renameHandler = withResponse RspRename (renameWith providers)} - -renameWith :: - [(PluginId, RenameProvider IdeState)] -> - LSP.LspFuncs Config -> - IdeState -> - RenameParams -> - IO (Either ResponseError WorkspaceEdit) -renameWith providers lspFuncs state params = do - let - makeAction (pid,p) = do - pluginConfig <- getPluginConfig lspFuncs pid - if pluginEnabled pluginConfig plcRenameOn - then otTracedProvider pid "rename" $ p lspFuncs state params - else return $ Right $ WorkspaceEdit Nothing Nothing - -- TODO:AZ: we need to consider the right way to combine possible renamers - results <- mapConcurrently makeAction providers - case partitionEithers results of - (errors, []) -> return $ Left $ responseError $ T.pack $ show errors - (_, edits) -> return $ Right $ mconcat edits - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -formatterPlugins :: [(PluginId, FormattingProvider IdeState IO)] -> Plugin Config -formatterPlugins providers - = Plugin formatterRules - (formatterHandlers (Map.fromList (("none",noneProvider):providers))) - -formatterRules :: Rules () -formatterRules = mempty - -formatterHandlers :: Map.Map PluginId (FormattingProvider IdeState IO) -> PartialHandlers Config -formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.documentFormattingHandler - = withResponse RspDocumentFormatting (formatting providers) - , LSP.documentRangeFormattingHandler - = withResponse RspDocumentRangeFormatting (rangeFormatting providers) - } - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -completionsPlugins :: [(PluginId, CompletionProvider IdeState)] -> Plugin Config -completionsPlugins cs = Plugin completionsRules (completionsHandlers cs) - -completionsRules :: Rules () -completionsRules = mempty - -completionsHandlers :: [(PluginId, CompletionProvider IdeState)] -> PartialHandlers Config -completionsHandlers cps = PartialHandlers $ \WithMessage{..} x -> - return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)} - -makeCompletions :: [(PluginId, CompletionProvider IdeState)] - -> LSP.LspFuncs Config - -> IdeState - -> CompletionParams - -> IO (Either ResponseError CompletionResponseResult) -makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt) - = do - mprefix <- getPrefixAtPos lf doc pos - maxCompletions <- maxCompletions <$> getClientConfig lf - - let - combine :: [CompletionResponseResult] -> CompletionResponseResult - combine cs = go True mempty cs - - go !comp acc [] = - CompletionList (CompletionListType comp (List $ DList.toList acc)) - go comp acc (Completions (List ls) : rest) = - go comp (acc <> DList.fromList ls) rest - go comp acc (CompletionList (CompletionListType comp' (List ls)) : rest) = - go (comp && comp') (acc <> DList.fromList ls) rest + IdeHandlers handlers' = foldMap bakePluginId xs + bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers + bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map + (\(PluginHandler f) -> IdeHandler [(pid,f pid)]) + hs + handlers = mconcat $ do + (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers' + pure $ requestHandler m $ \ide params -> do + config <- getClientConfig + let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs' + case nonEmpty fs of + Nothing -> pure $ Left $ ResponseError InvalidRequest + ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs)) + Nothing + Just fs -> do + let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e) + es <- runConcurrently msg (show m) fs ide params + let (errs,succs) = partitionEithers $ toList es + case nonEmpty succs of + Nothing -> pure $ Left $ combineErrors errs + Just xs -> do + caps <- LSP.getClientCapabilities + pure $ Right $ combineResponses m config caps params xs - makeAction :: - (PluginId, CompletionProvider IdeState) -> - IO (Either ResponseError CompletionResponseResult) - makeAction (pid, p) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcCompletionOn - then otTracedProvider pid "completions" $ p lf ideState params - else return $ Right $ Completions $ List [] +runConcurrently + :: MonadUnliftIO m + => (SomeException -> PluginId -> T.Text) + -> String -- ^ label + -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) + -> a + -> b + -> m (NonEmpty (Either ResponseError d)) +runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do + f a b + `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) - case mprefix of - Nothing -> return $ Right $ Completions $ List [] - Just _prefix -> do - mhs <- mapConcurrently makeAction sps - case rights mhs of - [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs - hs -> return $ Right $ snd $ consumeCompletionResponse maxCompletions $ combine hs +combineErrors :: [ResponseError] -> ResponseError +combineErrors [x] = x +combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing --- | Crops a completion response. Returns the final number of completions and the cropped response -consumeCompletionResponse :: Int -> CompletionResponseResult -> (Int, CompletionResponseResult) -consumeCompletionResponse limit it@(CompletionList (CompletionListType _ (List xx))) = - case splitAt limit xx of - -- consumed all the items, return the result as is - (_, []) -> (limit - length xx, it) - -- need to crop the response, set the 'isIncomplete' flag - (xx', _) -> (0, CompletionList (CompletionListType isIncompleteResponse (List xx'))) -consumeCompletionResponse n (Completions (List xx)) = - consumeCompletionResponse n (CompletionList (CompletionListType isCompleteResponse (List xx))) +-- | Combine the 'PluginHandler' for all plugins +newtype IdeHandler (m :: J.Method FromClient Request) + = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] --- boolean disambiguators -isCompleteResponse, isIncompleteResponse :: Bool -isIncompleteResponse = True -isCompleteResponse = False +-- | Combine the 'PluginHandlers' for all plugins +newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler) -getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo) -getPrefixAtPos lf uri pos = do - mvf <- LSP.getVirtualFileFunc lf (J.toNormalizedUri uri) - case mvf of - Just vf -> VFS.getCompletionPrefix pos vf - Nothing -> return Nothing +instance Semigroup IdeHandlers where + (IdeHandlers a) <> (IdeHandlers b) = IdeHandlers $ DMap.unionWithKey go a b + where + go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a ++ b) +instance Monoid IdeHandlers where + mempty = IdeHandlers mempty diff --git a/src/Development/IDE/Plugin/HLS/Formatter.hs b/src/Development/IDE/Plugin/HLS/Formatter.hs deleted file mode 100644 --- a/src/Development/IDE/Plugin/HLS/Formatter.hs +++ /dev/null @@ -1,70 +0,0 @@ - -module Development.IDE.Plugin.HLS.Formatter - ( - formatting - , rangeFormatting - ) -where - -import qualified Data.Map as Map -import qualified Data.Text as T -import Development.IDE -import Ide.PluginUtils -import Ide.Types -import Ide.Plugin.Config -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Types -import Text.Regex.TDFA.Text() - --- --------------------------------------------------------------------- - -formatting :: Map.Map PluginId (FormattingProvider IdeState IO) - -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams - -> IO (Either ResponseError (List TextEdit)) -formatting providers lf ideState - (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress) - = doFormatting lf providers ideState FormatText uri params - --- --------------------------------------------------------------------- - -rangeFormatting :: Map.Map PluginId (FormattingProvider IdeState IO) - -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams - -> IO (Either ResponseError (List TextEdit)) -rangeFormatting providers lf ideState - (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress) - = doFormatting lf providers ideState (FormatRange range) uri params - --- --------------------------------------------------------------------- - -doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IdeState IO) - -> IdeState -> FormattingType -> Uri -> FormattingOptions - -> IO (Either ResponseError (List TextEdit)) -doFormatting lf providers ideState ft uri params = do - mc <- LSP.config lf - let mf = maybe "none" formattingProvider mc - case Map.lookup (PluginId mf) providers of - Just provider -> - case uriToFilePath uri of - Just (toNormalizedFilePath -> fp) -> do - (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp - case mb_contents of - Just contents -> do - logDebug (ideLogger ideState) $ T.pack $ - "Formatter.doFormatting: contents=" ++ show contents -- AZ - provider lf ideState ft contents fp params - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri - Nothing -> return $ Left $ responseError $ mconcat - [ "Formatter plugin: no formatter found for:[" - , mf - , "]" - , if mf == "brittany" - then T.unlines - [ "\nThe haskell-language-server must be compiled with the agpl flag to provide Brittany." - , "Stack users add 'agpl: true' in the flags section of the 'stack.yaml' file." - , "The 'haskell-language-server.cabal' file already has this flag enabled by default." - , "For more information see: https://github.com/haskell/haskell-language-server/issues/269" - ] - else "" - ] - diff --git a/src/Development/IDE/Plugin/HLS/GhcIde.hs b/src/Development/IDE/Plugin/HLS/GhcIde.hs --- a/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -9,13 +9,14 @@ import Development.IDE import Development.IDE.LSP.HoverDefinition import Development.IDE.LSP.Outline -import Ide.PluginUtils import Ide.Types -import Language.Haskell.LSP.Types +import Language.LSP.Types +import Language.LSP.Server (LspM) import Text.Regex.TDFA.Text() import qualified Development.IDE.Plugin.CodeAction as CodeAction import qualified Development.IDE.Plugin.Completions as Completions import qualified Development.IDE.Plugin.TypeLenses as TypeLenses +import Control.Monad.IO.Class descriptors :: [PluginDescriptor IdeState] descriptors = @@ -29,25 +30,19 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginHoverProvider = Just hover' - , pluginSymbolsProvider = Just symbolsProvider + { pluginHandlers = mkPluginHandler STextDocumentHover hover' + <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider } -- --------------------------------------------------------------------- -hover' :: HoverProvider IdeState -hover' ideState params = do - logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ - hover ideState params +hover' :: IdeState -> PluginId -> HoverParams -> LspM c (Either ResponseError (Maybe Hover)) +hover' ideState _ HoverParams{..} = do + liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ + hover ideState TextDocumentPositionParams{..} -- --------------------------------------------------------------------- -symbolsProvider :: SymbolsProvider IdeState -symbolsProvider ls ide params = do - ds <- moduleOutline ls ide params - case ds of - Right (DSDocumentSymbols (List ls)) -> return $ Right ls - Right (DSSymbolInformation (List _si)) -> - return $ Left $ responseError "GhcIde.symbolsProvider: DSSymbolInformation deprecated" - Left err -> return $ Left err +symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) +symbolsProvider ide _ params = moduleOutline ide params -- --------------------------------------------------------------------- diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DerivingStrategies #-} -- | A plugin that adds custom messages for use in tests module Development.IDE.Plugin.Test @@ -10,6 +11,7 @@ ) where import Control.Monad.STM +import Control.Monad.IO.Class import Data.Aeson import Data.Aeson.Types import Data.CaseInsensitive (CI, original) @@ -17,14 +19,12 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.Types.HscEnvEq (HscEnvEq(hscEnv)) -import Development.IDE.LSP.Server import Development.IDE.Plugin +import Development.IDE.LSP.Server import Development.IDE.Types.Action import GHC.Generics (Generic) import GhcPlugins (HscEnv(hsc_dflags)) -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types +import Language.LSP.Types import System.Time.Extra import Development.IDE.Core.RuleTypes import Control.Monad @@ -36,7 +36,7 @@ import Development.IDE.Types.Location (fromUri) import Control.Concurrent (threadDelay) import Ide.Types -import qualified Language.Haskell.LSP.Core as LSP +import qualified Language.LSP.Server as LSP data TestRequest = BlockSeconds Seconds -- ^ :: Null @@ -53,42 +53,39 @@ plugin :: Plugin c plugin = Plugin { pluginRules = return (), - pluginHandler = PartialHandlers $ \WithMessage{..} x -> return x { - customRequestHandler = withResponse RspCustomServer requestHandler' - } + pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler' } where - requestHandler' lsp ide req + testRequestHandler' ide req | Just customReq <- parseMaybe parseJSON req - = requestHandler lsp ide customReq + = testRequestHandler ide customReq | otherwise = return $ Left $ ResponseError InvalidRequest "Cannot parse request" Nothing -requestHandler :: LspFuncs c - -> IdeState + +testRequestHandler :: IdeState -> TestRequest - -> IO (Either ResponseError Value) -requestHandler lsp _ (BlockSeconds secs) = do - sendFunc lsp $ NotCustomServer $ - NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/request") $ - toJSON secs - sleep secs + -> LSP.LspM c (Either ResponseError Value) +testRequestHandler _ (BlockSeconds secs) = do + LSP.sendNotification (SCustomMethod "ghcide/blocking/request") $ + toJSON secs + liftIO $ sleep secs return (Right Null) -requestHandler _ s (GetInterfaceFilesDir fp) = do +testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do let nfp = toNormalizedFilePath fp sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp let hiPath = hiDir $ hsc_dflags $ hscEnv sess return $ Right (toJSON hiPath) -requestHandler _ s GetShakeSessionQueueCount = do +testRequestHandler s GetShakeSessionQueueCount = liftIO $ do n <- atomically $ countQueue $ actionQueue $ shakeExtras s return $ Right (toJSON n) -requestHandler _ s WaitForShakeQueue = do +testRequestHandler s WaitForShakeQueue = liftIO $ do atomically $ do n <- countQueue $ actionQueue $ shakeExtras s when (n>0) retry return $ Right Null -requestHandler _ s (WaitForIdeRule k file) = do +testRequestHandler s (WaitForIdeRule k file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp let res = WaitForIdeRuleResult <$> success @@ -120,9 +117,7 @@ } blockCommandHandler :: CommandFunction state ExecuteCommandParams -blockCommandHandler lsp _ideState _params - = do - LSP.sendFunc lsp $ NotCustomServer $ - NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null - threadDelay maxBound - return (Right Null, Nothing) +blockCommandHandler _ideState _params = do + LSP.sendNotification (SCustomMethod "ghcide/blocking/command") Null + liftIO $ threadDelay maxBound + return (Right Null) diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -6,6 +6,7 @@ ) where +import Control.Monad.IO.Class import Data.Aeson.Types (Value (..), toJSON) import qualified Data.HashMap.Strict as Map import qualified Data.Text as T @@ -24,22 +25,23 @@ ( CommandFunction, CommandId (CommandId), PluginCommand (PluginCommand), - PluginDescriptor (pluginCodeLensProvider, pluginCommands), + PluginDescriptor(..), PluginId, defaultPluginDescriptor, + mkPluginHandler ) -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types ( ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), CodeLens (CodeLens), CodeLensParams (CodeLensParams, _textDocument), Diagnostic (..), List (..), ResponseError, - ServerMethod (WorkspaceApplyEdit), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), + SMethod(..) ) import Text.Regex.TDFA ((=~)) @@ -49,19 +51,18 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginCodeLensProvider = Just codeLensProvider, + { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider, pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] } codeLensProvider :: - LSP.LspFuncs c -> IdeState -> PluginId -> CodeLensParams -> - IO (Either ResponseError (List CodeLens)) -codeLensProvider _lsp ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do + LSP.LspM c (Either ResponseError (List CodeLens)) +codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do fmap (Right . List) $ case uriToFilePath' uri of - Just (toNormalizedFilePath' -> filePath) -> do + Just (toNormalizedFilePath' -> filePath) -> liftIO $ do _ <- runAction "codeLens" ideState (use TypeCheck filePath) diag <- getDiagnostics ideState hDiag <- getHiddenDiagnostics ideState @@ -76,12 +77,13 @@ generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> IO CodeLens generateLens pId _range title edit = do - cId <- mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) + let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) return $ CodeLens _range (Just cId) Nothing commandHandler :: CommandFunction IdeState WorkspaceEdit -commandHandler _lsp _ideState wedit = - return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) +commandHandler _ideState wedit = do + _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right Null suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])] suggestSignature isQuickFix Diagnostic {_range = _range@Range {..}, ..} diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -22,7 +22,7 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans() import Development.IDE.Types.Location -import Language.Haskell.LSP.Types +import Language.LSP.Types -- compiler and infrastructure import Development.IDE.GHC.Compat @@ -318,7 +318,15 @@ mod <- MaybeT $ return $ nameModule_maybe name erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) case erow of - [] -> MaybeT $ pure Nothing + [] -> do + -- If the lookup failed, try again without specifying a unit-id. + -- This is a hack to make find definition work better with ghcide's nascent multi-component support, + -- where names from a component that has been indexed in a previous session but not loaded in this + -- session may end up with different unit ids + erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) Nothing + case erow of + [] -> MaybeT $ pure Nothing + xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs defRowToLocation :: Monad m => LookupModule m -> Res DefRow -> MaybeT m Location diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -35,7 +35,7 @@ import GhcMonad import Packages import Name -import Language.Haskell.LSP.Types (getUri, filePathToUri) +import Language.LSP.Types (getUri, filePathToUri) import TcRnTypes import ExtractDocs import NameEnv @@ -43,11 +43,10 @@ mkDocMap :: HscEnv - -> [ParsedModule] -> RefMap a -> TcGblEnv -> IO DocAndKindMap -mkDocMap env sources rm this_mod = +mkDocMap env rm this_mod = do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names k <- foldrM getType (tcg_type_env this_mod) names @@ -56,7 +55,7 @@ getDocs n map | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist | otherwise = do - doc <- getDocumentationTryGhc env mod sources n + doc <- getDocumentationTryGhc env mod n pure $ extendNameEnv map n doc getType n map | isTcOcc $ occName n = do @@ -71,23 +70,21 @@ lookupKind env mod = fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod -getDocumentationTryGhc :: HscEnv -> Module -> [ParsedModule] -> Name -> IO SpanDoc -getDocumentationTryGhc env mod deps n = head <$> getDocumentationsTryGhc env mod deps [n] +getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc +getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] -getDocumentationsTryGhc :: HscEnv -> Module -> [ParsedModule] -> [Name] -> IO [SpanDoc] --- Interfaces are only generated for GHC >= 8.6. --- In older versions, interface files do not embed Haddocks anyway -getDocumentationsTryGhc env mod sources names = do +getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] +getDocumentationsTryGhc env mod names = do res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names case res of - Left _ -> mapM mkSpanDocText names + Left _ -> return [] Right res -> zipWithM unwrap res names where unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n unwrap _ n = mkSpanDocText n mkSpanDocText name = - SpanDocText (getDocumentation sources name) <$> getUris name + SpanDocText [] <$> getUris name -- Get the uris to the documentation and source html pages if they exist getUris name = do @@ -212,8 +209,8 @@ go pkgDocDir = map (mkDocPath pkgDocDir) mns ui = moduleUnitId m -- try to locate html file from most to least specific name e.g. - -- first Language.Haskell.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html - -- then Language.Haskell.LSP.Types.html and Language-Haskell-LSP-Types.html etc. + -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html + -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. mns = do chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m -- The file might use "." or "-" as separator diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -20,12 +20,12 @@ import Data.Maybe as Maybe import qualified Data.Text as T import Data.Text.Prettyprint.Doc -import Language.Haskell.LSP.Types as LSP (DiagnosticSource, +import Language.LSP.Types as LSP (DiagnosticSource, DiagnosticSeverity(..) , Diagnostic(..) , List(..) ) -import Language.Haskell.LSP.Diagnostics +import Language.LSP.Diagnostics import Data.Text.Prettyprint.Doc.Render.Text import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color) diff --git a/src/Development/IDE/Types/HscEnvEq.hs b/src/Development/IDE/Types/HscEnvEq.hs --- a/src/Development/IDE/Types/HscEnvEq.hs +++ b/src/Development/IDE/Types/HscEnvEq.hs @@ -6,6 +6,7 @@ newHscEnvEqWithImportPaths, envImportPaths, envPackageExports, + envVisibleModuleNames, deps ) where @@ -16,7 +17,7 @@ import Module (InstalledUnitId) import System.Directory (canonicalizePath) import Development.IDE.GHC.Compat -import GhcPlugins(HscEnv (hsc_dflags), PackageState (explicitPackages), InstalledPackageInfo (exposedModules), Module(..), packageConfigId) +import GhcPlugins(HscEnv (hsc_dflags), PackageState (explicitPackages), InstalledPackageInfo (exposedModules), Module(..), packageConfigId, listVisibleModuleNames) import System.FilePath import Development.IDE.GHC.Util (lookupPackageConfig) import Control.Monad.IO.Class @@ -24,8 +25,13 @@ import LoadIface (loadInterface) import qualified Maybes import OpenTelemetry.Eventlog (withSpan) -import System.IO.Unsafe (unsafePerformIO) -import Control.Monad.Extra (mapMaybeM) +import Control.Monad.Extra (mapMaybeM, join, eitherM) +import Control.Concurrent.Extra (newVar, modifyVar) +import Control.Concurrent.Async (Async, async, waitCatch) +import Control.Exception (throwIO, mask, evaluate) +import Development.IDE.GHC.Error (catchSrcErrors) +import Control.DeepSeq (force) +import Data.Either (fromRight) -- | An 'HscEnv' with equality. Two values are considered equal -- if they are created with the same call to 'newHscEnvEq'. @@ -39,7 +45,12 @@ , envImportPaths :: Maybe [String] -- ^ If Just, import dirs originally configured in this env -- If Nothing, the env import dirs are unaltered - , envPackageExports :: ExportsMap + , envPackageExports :: IO ExportsMap + , envVisibleModuleNames :: IO (Maybe [ModuleName]) + -- ^ 'listVisibleModuleNames' is a pure function, + -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365 + -- So it's wrapped in IO here for error handling + -- If Nothing, 'listVisibleModuleNames' panic } -- | Wrap an 'HscEnv' into an 'HscEnvEq'. @@ -56,13 +67,15 @@ newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do + + let dflags = hsc_dflags hscEnv + envUnique <- newUnique - let - -- evaluate lazily, using unsafePerformIO for a pure API - envPackageExports = unsafePerformIO $ withSpan "Package Exports" $ \_sp -> do + -- it's very important to delay the package exports computation + envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do -- compute the package imports - let pkgst = pkgState (hsc_dflags hscEnv) + let pkgst = pkgState dflags depends = explicitPackages pkgst targets = [ (pkg, mn) @@ -81,6 +94,15 @@ Maybes.Succeeded mi -> Just mi modIfaces <- mapMaybeM doOne targets return $ createExportsMap modIfaces + + -- similar to envPackageExports, evaluated lazily + envVisibleModuleNames <- onceAsync $ + fromRight Nothing + <$> catchSrcErrors + dflags + "listVisibleModuleNames" + (evaluate . force . Just $ listVisibleModuleNames dflags) + return HscEnvEq{..} -- | Wrap an 'HscEnv' into an 'HscEnvEq'. @@ -107,8 +129,8 @@ a == b = envUnique a == envUnique b instance NFData HscEnvEq where - rnf (HscEnvEq a b c d _) = - -- deliberately skip the package exports map + rnf (HscEnvEq a b c d _ _) = + -- deliberately skip the package exports map and visible module names rnf (hashUnique a) `seq` b `seq` c `seq` rnf d instance Hashable HscEnvEq where @@ -119,3 +141,19 @@ instance Binary HscEnvEq where put _ = error "not really" get = error "not really" + +-- | Given an action, produce a wrapped action that runs at most once. +-- The action is run in an async so it won't be killed by async exceptions +-- If the function raises an exception, the same exception will be reraised each time. +onceAsync :: IO a -> IO (IO a) +onceAsync act = do + var <- newVar OncePending + let run as = eitherM throwIO pure (waitCatch as) + pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of + OnceRunning x -> pure (v, unmask $ run x) + OncePending -> do + x <- async (unmask act) + pure (OnceRunning x, unmask $ run x) + +data Once a = OncePending | OnceRunning (Async a) + diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -26,12 +26,12 @@ ) where import Control.Applicative -import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..)) +import Language.LSP.Types (Location(..), Range(..), Position(..)) import Control.Monad import Data.Hashable (Hashable(hash)) import Data.String import FastString -import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.LSP.Types as LSP import SrcLoc as GHC import Text.ParserCombinators.ReadP as ReadP import Data.Maybe (fromMaybe) diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -17,12 +17,11 @@ , OptHaddockParse(..) ,optShakeFiles) where -import Data.Default import Development.Shake import Development.IDE.Types.HscEnvEq (HscEnvEq) import GHC hiding (parseModule, typecheckModule) import GhcPlugins as GHC hiding (fst3, (<>)) -import qualified Language.Haskell.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Types.Capabilities as LSP import qualified Data.Text as T import Development.IDE.Types.Diagnostics import Control.DeepSeq (NFData(..)) @@ -72,9 +71,9 @@ -- features such as diagnostics and go-to-definition, in -- situations in which they would become unavailable because of -- the presence of type errors, holes or unbound variables. - , optCheckProject :: !Bool + , optCheckProject :: IO Bool -- ^ Whether to typecheck the entire project on load - , optCheckParents :: CheckParents + , optCheckParents :: IO CheckParents -- ^ When to typecheck reverse dependencies of a file , optHaddockParse :: OptHaddockParse -- ^ Whether to return result of parsing module with Opt_Haddock. @@ -133,8 +132,8 @@ ,optKeywords = haskellKeywords ,optDefer = IdeDefer True ,optTesting = IdeTesting False - ,optCheckProject = checkProject def - ,optCheckParents = checkParents def + ,optCheckProject = pure True + ,optCheckParents = pure CheckOnSaveAndClose ,optHaddockParse = HaddockParse ,optCustomDynFlags = id } diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -28,7 +28,7 @@ import Development.Shake (RuleResult, ShakeException (shakeExceptionInner)) import Development.Shake.Classes import GHC.Generics -import Language.Haskell.LSP.Types +import Language.LSP.Types import Development.IDE.Core.PositionMapping data Value v diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -5,7 +5,12 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} #include "ghc-api-version.h" module Main (main) where @@ -15,7 +20,7 @@ import qualified Control.Lens as Lens import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (FromJSON, Value, toJSON,fromJSON) +import Data.Aeson (toJSON,fromJSON) import qualified Data.Aeson as A import qualified Data.Binary as Binary import Data.Default @@ -29,7 +34,6 @@ import Development.IDE.Core.Shake (Q(..)) import Development.IDE.GHC.Util import qualified Data.Text as T -import Data.Typeable import Development.IDE.Plugin.Completions.Types (extendImportCommandId) import Development.IDE.Plugin.TypeLenses (typeLensCommandId) import Development.IDE.Spans.Common @@ -50,12 +54,11 @@ import Development.Shake (getDirectoryFilesIO) import Ide.Plugin.Config import qualified Experiments as Bench -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities -import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message) -import Language.Haskell.LSP.VFS (applyChange) +import Language.LSP.Test +import Language.LSP.Types hiding (mkRange) +import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as Lsp (diagnostics, params, message) +import Language.LSP.VFS (applyChange) import Network.URI import System.Environment.Blank (unsetEnv, getEnv, setEnv) import System.FilePath @@ -66,7 +69,7 @@ import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc) import System.Info.Extra (isWindows) import Test.QuickCheck -import Test.QuickCheck.Instances () +-- import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.Ingredients.Rerun @@ -76,21 +79,31 @@ import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) import Development.IDE.Plugin.Test (TestRequest (BlockSeconds, GetInterfaceFilesDir), WaitForIdeRuleResult (..), blockCommandId) import Control.Monad.Extra (whenJust) -import qualified Language.Haskell.LSP.Types.Lens as L +import qualified Language.LSP.Types.Lens as L import Control.Lens ((^.)) import Data.Functor import Data.Tuple.Extra +waitForProgressBegin :: Session () +waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just () + _ -> Nothing + +waitForProgressDone :: Session () +waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + _ -> Nothing + main :: IO () main = do -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" [ testSession "open close" $ do doc <- createDoc "Testing.hs" "haskell" "" - void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest) - void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification) + void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate) + waitForProgressBegin closeDoc doc - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + waitForProgressDone , initializeResponseTests , completionTests , cppTests @@ -130,50 +143,50 @@ -- response. Currently the server advertises almost no capabilities -- at all, in some cases failing to announce capabilities that it -- actually does provide! Hopefully this will change ... - tests :: IO InitializeResponse -> TestTree + tests :: IO (ResponseMessage Initialize) -> TestTree tests getInitializeResponse = testGroup "initialize response capabilities" [ chk " text doc sync" _textDocumentSync tds - , chk " hover" _hoverProvider (Just True) - , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing) - , chk "NO signature help" _signatureHelpProvider Nothing - , chk " goto definition" _definitionProvider (Just True) - , chk " goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic True) + , chk " hover" _hoverProvider (Just $ InL True) + , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False)) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just $ InL True) + , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) -- BUG in lsp-test, this test fails, just change the accepted response -- for now - , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic True) - , chk " find references" _referencesProvider (Just True) - , chk " doc highlight" _documentHighlightProvider (Just True) - , chk " doc symbol" _documentSymbolProvider (Just True) - , chk " workspace symbol" _workspaceSymbolProvider (Just True) - , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True - , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing - , chk "NO doc formatting" _documentFormattingProvider Nothing + , chk "NO goto implementation" _implementationProvider (Just $ InL False) + , chk " find references" _referencesProvider (Just $ InL True) + , chk " doc highlight" _documentHighlightProvider (Just $ InL True) + , chk " doc symbol" _documentSymbolProvider (Just $ InL True) + , chk " workspace symbol" _workspaceSymbolProvider (Just True) + , chk " code action" _codeActionProvider (Just $ InL True) + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) + , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) , chk "NO doc range formatting" - _documentRangeFormattingProvider Nothing + _documentRangeFormattingProvider (Just $ InL False) , chk "NO doc formatting on typing" - _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider (Just $ RenameOptionsStatic False) - , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False) - , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False) + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider (Just $ InL False) + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" _colorProvider (Just $ InL False) + , chk "NO folding range" _foldingRangeProvider (Just $ InL False) , che " execute command" _executeCommandProvider [blockCommandId, extendImportCommandId, typeLensCommandId] - , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )})) - , chk "NO experimental" _experimental Nothing + , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) + , chk "NO experimental" _experimental Nothing ] where - tds = Just (TDSOptions (TextDocumentSyncOptions + tds = Just (InL (TextDocumentSyncOptions { _openClose = Just True , _change = Just TdSyncIncremental , _willSave = Nothing , _willSaveWaitUntil = Nothing - , _save = Just (SaveOptions {_includeText = Nothing})})) + , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) - chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree chk title getActual expected = testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir - che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree che title getActual expected = testCase title doTest where doTest = do @@ -181,15 +194,14 @@ let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands - - innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner - innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c - innerCaps _ = error "this test only expects inner capabilities" + innerCaps :: ResponseMessage Initialize -> ServerCapabilities + innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" - acquire :: IO InitializeResponse + acquire :: IO (ResponseMessage Initialize) acquire = run initializeResponse - release :: InitializeResponse -> IO () + release :: ResponseMessage Initialize -> IO () release = const $ pure () @@ -209,8 +221,8 @@ , testSessionWait "introduce syntax error" $ do let content = T.unlines [ "module Testing where" ] doc <- createDoc "Testing.hs" "haskell" content - void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest) - void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification) + void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate) + waitForProgressBegin let change = TextDocumentContentChangeEvent { _range = Just (Range (Position 0 15) (Position 0 18)) , _rangeLength = Nothing @@ -488,9 +500,8 @@ in filePathToUri (joinDrive (lower drive) suffix) let itemA = TextDocumentItem uriA "haskell" 0 aContent let a = TextDocumentIdentifier uriA - sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA) - diagsNot <- skipManyTill anyMessage diagnostic - let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification) + sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA) + NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic -- Check that if we put a lower-case drive in for A.A -- the diagnostics for A.B will also be lower-case. liftIO $ fileUri @?= uriB @@ -693,6 +704,7 @@ , removeImportTests , extendImportTests , suggestImportTests + , suggestHideShadowTests , suggestImportDisambiguationTests , disableWarningTests , fixConstructorImportTests @@ -727,7 +739,7 @@ [ testSession' "workspace files" $ \sessionDir -> do liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification + watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics -- Expect 1 subscription: we only ever send one liftIO $ length watchedFileRegs @?= 1 @@ -736,7 +748,7 @@ tmpDir <- liftIO getTemporaryDirectory liftIO $ writeFile (sessionDir "hie.yaml") ("cradle: {direct: {arguments: [\"-i" <> tmpDir <> "\", \"A\", \"WatchedFilesMissingModule\"]}}") _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification + watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics -- Expect 1 subscription: we only ever send one liftIO $ length watchedFileRegs @?= 1 @@ -803,7 +815,7 @@ doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20)) - [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] + [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] executeCodeAction fixTypo contentAfterAction <- documentContents doc let expectedContentAfterAction = T.unlines @@ -826,7 +838,7 @@ doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands , "Use type signature" `T.isInfixOf` actionTitle ] executeCodeAction addSignature @@ -846,7 +858,7 @@ doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands , "Use type signature" `T.isInfixOf` actionTitle ] executeCodeAction addSignature @@ -869,7 +881,7 @@ doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands , "Use type signature" `T.isInfixOf` actionTitle ] executeCodeAction addSignature @@ -1101,7 +1113,7 @@ ] where caWithTitle t = \case - CACodeAction a@CodeAction{_title} -> guard (_title == t) >> Just a + InR a@CodeAction{_title} -> guard (_title == t) >> Just a _ -> Nothing extendImportTests :: TestTree @@ -1357,7 +1369,7 @@ codeActionTitle CodeAction{_title=x} = x template setUpModules moduleUnderTest range expectedTitles expectedContentB = do - sendNotification WorkspaceDidChangeConfiguration + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams $ toJSON def{checkProject = overrideCheckProject}) @@ -1365,12 +1377,12 @@ mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) _ <- waitForDiagnostics - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + waitForProgressDone actionsOrCommands <- getCodeActions docB range let codeActions = filter (T.isPrefixOf "Add" . codeActionTitle) - [ca | CACodeAction ca <- actionsOrCommands] + [ca | InR ca <- actionsOrCommands] actualTitles = codeActionTitle <$> codeActions -- Note that we are not testing the order of the actions, as the -- order of the expected actions indicates which one we'll execute @@ -1460,7 +1472,7 @@ cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}" liftIO $ writeFileUTF8 (dir "hie.yaml") cradle doc <- createDoc "Test.hs" "haskell" before - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + waitForProgressDone _diags <- waitForDiagnostics -- there isn't a good way to wait until the whole project is checked atm when waitForCheckProject $ liftIO $ sleep 0.5 @@ -1474,7 +1486,7 @@ contentAfterAction <- documentContents doc liftIO $ after @=? contentAfterAction else - liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= [] + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= [] suggestImportDisambiguationTests :: TestTree suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" @@ -1524,13 +1536,13 @@ assertBool "EVec.fromList must not be suggested" $ "Replace with qualified: EVec.fromList" `notElem` [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions + | InR CodeAction { _title = actionTitle } <- actions ] liftIO $ assertBool "EVec.++ must not be suggested" $ "Replace with qualified: EVec.++" `notElem` [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions + | InR CodeAction { _title = actionTitle } <- actions ] , testGroup "fromList" [ testCase "EVec" $ @@ -1577,8 +1589,7 @@ liftIO $ mapM_ (\fp -> copyFile (hidingDir fp) $ dir fp) $ file : auxFiles doc <- openDoc file "haskell" - void (skipManyTill anyMessage message - :: Session WorkDoneProgressEndNotification) + waitForProgressDone void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] contents <- documentContents doc let range = Range (Position 0 0) (Position (length $ T.lines contents) 0) @@ -1586,6 +1597,193 @@ k doc actions withHideFunction = withTarget ("HideFunction" <.> "hs") +suggestHideShadowTests :: TestTree +suggestHideShadowTests = + testGroup + "suggest hide shadow" + [ testGroup + "single" + [ testOneCodeAction + "hide unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function" + , "f on = on" + , "g on = on" + ] + [ "import Data.Function hiding (on)" + , "f on = on" + , "g on = on" + ] + , testOneCodeAction + "extend hiding unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function hiding ((&))" + , "f on = on" + ] + [ "import Data.Function hiding (on, (&))" + , "f on = on" + ] + , testOneCodeAction + "delete unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function ((&), on)" + , "f on = on" + ] + [ "import Data.Function ((&))" + , "f on = on" + ] + , testOneCodeAction + "hide operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function" + , "f (&) = (&)" + ] + [ "import Data.Function hiding ((&))" + , "f (&) = (&)" + ] + , testOneCodeAction + "remove operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function ((&), on)" + , "f (&) = (&)" + ] + [ "import Data.Function ( on)" + , "f (&) = (&)" + ] + , noCodeAction + "don't remove already used" + (2, 2) + (2, 4) + [ "import Data.Function" + , "g = on" + , "f on = on" + ] + ] + , testGroup + "multi" + [ testOneCodeAction + "hide from B" + "Hide ++ from B" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from C" + "Hide ++ from C" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from Prelude" + "Hide ++ from Prelude" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testMultiCodeActions + "manual hide all" + [ "Hide ++ from Prelude" + , "Hide ++ from C" + , "Hide ++ from B" + ] + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "auto hide all" + "Hide ++ from all occurence imports" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + ] + ] + where + testOneCodeAction testName actionName start end origin expected = + helper testName start end origin expected $ \cas -> do + action <- liftIO $ pickActionWithTitle actionName cas + executeCodeAction action + noCodeAction testName start end origin = + helper testName start end origin origin $ \cas -> do + liftIO $ cas @?= [] + testMultiCodeActions testName actionNames start end origin expected = + helper testName start end origin expected $ \cas -> do + let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames] + liftIO $ + (length r == length actionNames) + @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset" + forM_ r executeCodeAction + helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do + void $ createDoc "B.hs" "haskell" $ T.unlines docB + void $ createDoc "C.hs" "haskell" $ T.unlines docC + doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) + void waitForDiagnostics + waitForProgressDone + cas <- getCodeActions doc (Range (Position (line1 + length header) col1) (Position (line2 + length header) col2)) + void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] + contentAfter <- documentContents doc + liftIO $ contentAfter @?= T.unlines (header <> expected) + header = + [ "{-# OPTIONS_GHC -Wname-shadowing #-}" + , "module A where" + , "" + ] + -- for multi group + docB = + [ "module B where" + , "(++) = id" + ] + docC = + [ "module C where" + , "(++) = id" + ] + disableWarningTests :: TestTree disableWarningTests = testGroup "disable warnings" $ @@ -1634,8 +1832,8 @@ liftIO $ expectedContent @=? contentAfterAction where caResultToCodeAct = \case - CACommand _ -> Nothing - CACodeAction c -> Just c + InL _ -> Nothing + InR c -> Just c insertNewDefinitionTests :: TestTree insertNewDefinitionTests = testGroup "insert new definition actions" @@ -1651,8 +1849,8 @@ ] docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions docB (R 1 0 1 50) liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" executeCodeAction action @@ -1675,8 +1873,8 @@ ] docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions docB (R 1 0 1 50) liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" executeCodeAction action @@ -1993,8 +2191,8 @@ _docA <- createDoc "ModuleA.hs" "haskell" contentA docB <- createDoc "ModuleB.hs" "haskell" contentB _diags <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions docB range liftIO $ expectedAction @=? actionTitle executeCodeAction action @@ -2013,7 +2211,7 @@ doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16)) - let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] + let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] executeCodeAction changeToMap contentAfterAction <- documentContents doc let expectedContentAfterAction = T.unlines @@ -2392,7 +2590,7 @@ $ all isDisableWarningAction actionsOrCommands where isDisableWarningAction = \case - CACodeAction CodeAction{_title} -> "Disable" `T.isPrefixOf` _title && "warnings" `T.isSuffixOf` _title + InR CodeAction{_title} -> "Disable" `T.isPrefixOf` _title && "warnings" `T.isSuffixOf` _title _ -> False in testGroup "remove redundant function constraints" @@ -2723,7 +2921,7 @@ contentAfterAction <- documentContents doc liftIO $ content @=? contentAfterAction Nothing -> - liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == expectedAction ] @?= [] + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= [] removeExportTests :: TestTree removeExportTests = testGroup "remove export actions" @@ -2917,7 +3115,7 @@ doc <- createDoc "Sigs.hs" "haskell" originalCode [CodeLens {_command = Just c}] <- getCodeLenses doc executeCommand c - modifiedCode <- getDocumentEdit doc + modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) liftIO $ expectedCode @=? modifiedCode in testGroup "add signature" @@ -2937,9 +3135,11 @@ ] ] -checkDefs :: [Location] -> Session [Expect] -> Session () -checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where +linkToLocation :: [LocationLink] -> [Location] +linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) +checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session () +checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where check (ExpectRange expectedRange) = do assertNDefinitionsFound 1 defs assertRangeCorrect (head defs) expectedRange @@ -2966,6 +3166,7 @@ findDefinitionAndHoverTests :: TestTree findDefinitionAndHoverTests = let + tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> Session [Expect] -> String -> TestTree tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do -- Dirty the cache to check that definitions work even in the presence of iface files @@ -2977,7 +3178,7 @@ closeDoc fooDoc doc <- openTestDataDoc (dir sourceFilePath) - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + waitForProgressDone found <- get doc pos check found targetRange @@ -3148,7 +3349,6 @@ pluginSimpleTests :: TestTree pluginSimpleTests = - ignoreTest8101 "GHC #18070" $ ignoreInWindowsForGHC88And810 $ testSessionWithExtraFiles "plugin" "simple plugin" $ \dir -> do _ <- openDoc (dir "KnownNat.hs") "haskell" @@ -3163,7 +3363,6 @@ pluginParsedResultTests :: TestTree pluginParsedResultTests = - ignoreTest8101 "GHC #18070" $ ignoreInWindowsForGHC88And810 $ testSessionWithExtraFiles "plugin" "parsedResultAction plugin" $ \dir -> do _ <- openDoc (dir "RecordDot.hs") "haskell" @@ -3436,7 +3635,7 @@ completionCommandTest name src pos wanted expected = testSession name $ do docId <- createDoc "A.hs" "haskell" (T.unlines src) _ <- waitForDiagnostics - compls <- getCompletions docId pos + compls <- skipManyTill anyMessage (getCompletions docId pos) let wantedC = find ( \case CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x _ -> False @@ -3449,10 +3648,11 @@ executeCommand c if src /= expected then do - modifiedCode <- getDocumentEdit docId + void $ skipManyTill anyMessage loggingNotification + modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) liftIO $ modifiedCode @?= T.unlines expected else do - expectMessages @ApplyWorkspaceEditRequest 1 $ \edit -> + expectMessages SWorkspaceApplyEdit 1 $ \edit -> liftIO $ assertFailure $ "Expected no edit but got: " <> show edit completionNoCommandTest :: @@ -3762,6 +3962,27 @@ (Position 3 11) [("Integer", CiStruct, "Integer ", True, True, Nothing)], + testSession "duplicate record fields" $ do + void $ + createDoc "B.hs" "haskell" $ + T.unlines + [ "{-# LANGUAGE DuplicateRecordFields #-}", + "module B where", + "newtype Foo = Foo { member :: () }", + "newtype Bar = Bar { member :: () }" + ] + docA <- + createDoc "A.hs" "haskell" $ + T.unlines + [ "module A where", + "import B", + "memb" + ] + _ <- waitForDiagnostics + compls <- getCompletions docA $ Position 2 4 + let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] + liftIO $ compls' @?= ["member ${1:Foo}", "member ${1:Bar}"], + testSessionWait "maxCompletions" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}", @@ -3779,7 +4000,7 @@ doc <- createDoc "A.hs" "haskell" source _ <- waitForDiagnostics highlights <- getHighlights doc (Position 3 2) - liftIO $ highlights @?= + liftIO $ highlights @?= List [ DocumentHighlight (R 2 0 2 3) (Just HkRead) , DocumentHighlight (R 3 0 3 3) (Just HkWrite) , DocumentHighlight (R 4 6 4 9) (Just HkRead) @@ -3789,7 +4010,7 @@ doc <- createDoc "A.hs" "haskell" source _ <- waitForDiagnostics highlights <- getHighlights doc (Position 2 8) - liftIO $ highlights @?= + liftIO $ highlights @?= List [ DocumentHighlight (R 2 7 2 10) (Just HkRead) , DocumentHighlight (R 3 11 3 14) (Just HkRead) ] @@ -3797,7 +4018,7 @@ doc <- createDoc "A.hs" "haskell" source _ <- waitForDiagnostics highlights <- getHighlights doc (Position 6 5) - liftIO $ highlights @?= + liftIO $ highlights @?= List [ DocumentHighlight (R 6 4 6 7) (Just HkWrite) , DocumentHighlight (R 6 10 6 13) (Just HkRead) , DocumentHighlight (R 7 12 7 15) (Just HkRead) @@ -3806,7 +4027,7 @@ doc <- createDoc "A.hs" "haskell" recsource _ <- waitForDiagnostics highlights <- getHighlights doc (Position 4 15) - liftIO $ highlights @?= + liftIO $ highlights @?= List -- Span is just the .. on 8.10, but Rec{..} before #if MIN_GHC_API_VERSION(8,10,0) [ DocumentHighlight (R 4 8 4 10) (Just HkWrite) @@ -3816,7 +4037,7 @@ , DocumentHighlight (R 4 14 4 20) (Just HkRead) ] highlights <- getHighlights doc (Position 3 17) - liftIO $ highlights @?= + liftIO $ highlights @?= List [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) -- Span is just the .. on 8.10, but Rec{..} before #if MIN_GHC_API_VERSION(8,10,0) @@ -4026,11 +4247,6 @@ xfail :: TestTree -> String -> TestTree xfail = flip expectFailBecause -ignoreTest8101 :: String -> TestTree -> TestTree -ignoreTest8101 - | GHC_API_VERSION == ("8.10.1" :: String) = ignoreTestBecause - | otherwise = const id - ignoreInWindowsBecause :: String -> TestTree -> TestTree ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x) @@ -4128,7 +4344,7 @@ [testGroup "dependencies" [sessionDepsArePickedUp] ,testGroup "ignore-fatal" [ignoreFatalWarning] ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] - ,testGroup "multi" [simpleMultiTest, simpleMultiTest2] + ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiDefTest] ,testGroup "sub-directory" [simpleSubDirectoryTest] ] @@ -4145,13 +4361,13 @@ implicit dir = test dir test _dir = do doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" - msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 1 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 0 _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 0 retryFailedCradle :: TestTree @@ -4230,7 +4446,7 @@ cradleLoadedMessage :: Session FromServerMessage cradleLoadedMessage = satisfy $ \case - NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod + FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod _ -> False cradleLoadedMethod :: T.Text @@ -4288,6 +4504,28 @@ 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/ @@ -4351,7 +4589,7 @@ -- Change y from Int to B changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] -- save so that we can that the error propogates to A - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams bdoc) + sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) -- Check that the error propogates to A expectDiagnostics @@ -4359,10 +4597,11 @@ -- Check that we wrote the interfaces for B when we saved - lid <- sendRequest (CustomClientMethod "hidir") $ GetInterfaceFilesDir bPath - res <- skipManyTill anyMessage $ responseForId lid + let m = SCustomMethod "test" + lid <- sendRequest m $ toJSON $ GetInterfaceFilesDir bPath + res <- skipManyTill anyMessage $ responseForId m lid liftIO $ case res of - ResponseMessage{_result=Right hidir} -> do + ResponseMessage{_result=Right (A.fromJSON -> A.Success hidir)} -> do hi_exists <- doesFileExist $ hidir "B.hi" assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res @@ -4505,6 +4744,8 @@ assertBool "did not successfully complete 5 repetitions" $ Bench.success res | e <- Bench.experiments , Bench.name e /= "edit" -- the edit experiment does not ever fail + -- the cradle experiments are way too slow + , not ("cradle" `isInfixOf` Bench.name e) ] -- | checks if we use InitializeParams.rootUri for loading session @@ -4526,8 +4767,8 @@ [ testSession "command" $ do -- Execute a command that will block forever - let req = ExecuteCommandParams blockCommandId Nothing Nothing - void $ sendRequest WorkspaceExecuteCommand req + let req = ExecuteCommandParams Nothing blockCommandId Nothing + void $ sendRequest SWorkspaceExecuteCommand req -- Load a file and check for code actions. Will only work if the command is run asynchronously doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS -Wmissing-signatures #-}" @@ -4535,13 +4776,13 @@ ] void waitForDiagnostics actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0)) - liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? + liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? [ "add signature: foo :: a -> a" , "Disable \"missing-signatures\" warnings" ] , testSession "request" $ do -- Execute a custom request that will block for 1000 seconds - void $ sendRequest (CustomClientMethod "test") $ BlockSeconds 1000 + void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 -- Load a file and check for code actions. Will only work if the request is run asynchronously doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS -Wmissing-signatures #-}" @@ -4549,7 +4790,7 @@ ] void waitForDiagnostics actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0)) - liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? + liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? [ "add signature: foo :: a -> a" , "Disable \"missing-signatures\" warnings" ] @@ -4558,19 +4799,15 @@ clientSettingsTest :: TestTree clientSettingsTest = testGroup "client settings handling" - [ - testSession "ghcide does not support update config" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) - logNot <- skipManyTill anyMessage loggingNotification - isMessagePresent "Updating Not supported" [getLogMessage logNot] - , testSession "ghcide restarts shake session on config changes" $ do - void $ skipManyTill anyMessage $ message @RegisterCapabilityRequest - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) + [ testSession "ghcide restarts shake session on config changes" $ do + void $ skipManyTill anyMessage $ message SClientRegisterCapability + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) nots <- skipManyTill anyMessage $ count 3 loggingNotification isMessagePresent "Restarting build session" (map getLogMessage nots) ] - where getLogMessage (NotLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg + where getLogMessage :: FromServerMessage -> T.Text + getLogMessage (FromServerMess SWindowLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg getLogMessage _ = "" isMessagePresent expectedMsg actualMsgs = liftIO $ @@ -4698,7 +4935,7 @@ YesIncludeDeclaration | NoExcludeDeclaration -getReferences' :: SymbolLocation -> IncludeDeclaration -> Session [Location] +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location) getReferences' (file, l, c) includeDeclaration = do doc <- openDoc file "haskell" getReferences doc (Position l c) $ toBool includeDeclaration @@ -4711,10 +4948,11 @@ -- Initial Index docid <- openDoc thisDoc "haskell" let + loop :: [FilePath] -> Session () loop [] = pure () loop docs = do doc <- skipManyTill anyMessage $ satisfyMaybe $ \case - NotCustomServer (NotificationMessage _ (CustomServerMethod "ghcide/reference/ready") fp) -> do + FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do A.Success fp' <- pure $ fromJSON fp find (fp' ==) docs _ -> Nothing @@ -4728,7 +4966,7 @@ referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree referenceTest name loc includeDeclaration expected = referenceTestSession name (fst3 loc) docs $ \dir -> do - actual <- getReferences' loc includeDeclaration + List actual <- getReferences' loc includeDeclaration liftIO $ actual `expectSameLocations` map (first3 (dir )) expected where docs = map fst3 expected @@ -4771,18 +5009,18 @@ -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. ( >> expectNoMoreDiagnostics 0.5) -pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction +pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction pickActionWithTitle title actions = do assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches) return $ head matches where titles = [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions + | InR CodeAction { _title = actionTitle } <- actions ] matches = [ action - | CACodeAction action@CodeAction { _title = actionTitle } <- actions + | InR action@CodeAction { _title = actionTitle } <- actions , title == actionTitle ] @@ -4864,12 +5102,12 @@ let matches = sequence [ listToMaybe [ action - | CACodeAction action@CodeAction { _title = actionTitle } <- actions + | InR action@CodeAction { _title = actionTitle } <- actions , expectedTitle `op` actionTitle] | expectedTitle <- expectedTitles] let msg = show [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions + | InR CodeAction { _title = actionTitle } <- actions ] ++ " " <> errMsg <> " " ++ show expectedTitles @@ -5085,13 +5323,13 @@ | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r) | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r -getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value] -getWatchedFilesSubscriptionsUntil = do - msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end) +getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] +getWatchedFilesSubscriptionsUntil m = do + msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m) return [ args | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs - , Registration _id WorkspaceDidChangeWatchedFiles args <- regs + , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs ] -- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -2,6 +2,8 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} module Development.IDE.Test ( Cursor @@ -20,6 +22,7 @@ , waitForAction ) where +import qualified Data.Aeson as A import Control.Applicative.Combinators import Control.Lens hiding (List) import Control.Monad @@ -27,18 +30,15 @@ import Data.Bifunctor (second) import qualified Data.Map.Strict as Map import qualified Data.Text as T -import Language.Haskell.LSP.Test hiding (message) -import qualified Language.Haskell.LSP.Test as LspTest -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens as Lsp +import Language.LSP.Test hiding (message) +import qualified Language.LSP.Test as LspTest +import Language.LSP.Types +import Language.LSP.Types.Lens as Lsp import System.Time.Extra import Test.Tasty.HUnit import System.Directory (canonicalizePath) import Data.Maybe (fromJust) -import Development.IDE.Plugin.Test (WaitForIdeRuleResult, TestRequest(WaitForIdeRule)) -import Data.Aeson (FromJSON) -import Data.Typeable (Typeable) - +import Development.IDE.Plugin.Test (WaitForIdeRuleResult, TestRequest(..)) -- | (0-based line number, 0-based column number) type Cursor = (Int, Int) @@ -70,7 +70,7 @@ -- if any diagnostic messages arrive in that period expectNoMoreDiagnostics :: Seconds -> Session () expectNoMoreDiagnostics timeout = - expectMessages @PublishDiagnosticsNotification timeout $ \diagsNot -> do + expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do let fileUri = diagsNot ^. params . uri actual = diagsNot ^. params . diagnostics liftIO $ @@ -79,31 +79,29 @@ <> " got " <> show actual -expectMessages :: (FromJSON msg, Typeable msg) => Seconds -> (msg -> Session ()) -> Session () -expectMessages timeout handle = do +expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session () +expectMessages m timeout handle = do -- Give any further diagnostic messages time to arrive. liftIO $ sleep timeout -- Send a dummy message to provoke a response from the server. -- This guarantees that we have at least one message to -- process, so message won't block or timeout. - void $ sendRequest (CustomClientMethod "non-existent-method") () - handleMessages + let cm = SCustomMethod "test" + i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount + go cm i where - handleMessages = (LspTest.message >>= handle) <|> handleCustomMethodResponse <|> ignoreOthers - ignoreOthers = void anyMessage >> handleMessages - -handleCustomMethodResponse :: Session () -handleCustomMethodResponse = - -- the CustomClientMethod triggers a RspCustomServer - -- handle that and then exit - void (LspTest.message :: Session CustomResponse) + go cm i = handleMessages + where + handleMessages = (LspTest.message m >>= handle) <|> (void $ responseForId cm i) <|> ignoreOthers + ignoreOthers = void anyMessage >> handleMessages flushMessages :: Session () flushMessages = do - void $ sendRequest (CustomClientMethod "non-existent-method") () - handleCustomMethodResponse <|> ignoreOthers + let cm = SCustomMethod "non-existent-method" + i <- sendRequest cm A.Null + void (responseForId cm i) <|> ignoreOthers cm i where - ignoreOthers = void anyMessage >> flushMessages + ignoreOthers cm i = skipManyTill anyMessage (responseForId cm i) >> flushMessages -- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics, -- only that existing diagnostics have been cleared. @@ -115,7 +113,7 @@ = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) -unwrapDiagnostic :: PublishDiagnosticsNotification -> (Uri, List Diagnostic) +unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () @@ -180,8 +178,8 @@ canonicalizeUri :: Uri -> IO Uri canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) -diagnostic :: Session PublishDiagnosticsNotification -diagnostic = LspTest.message +diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) +diagnostic = LspTest.message STextDocumentPublishDiagnostics standardizeQuotes :: T.Text -> T.Text standardizeQuotes msg = let @@ -193,6 +191,11 @@ waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) waitForAction key TextDocumentIdentifier{_uri} = do - waitId <- sendRequest (CustomClientMethod "test") (WaitForIdeRule key _uri) - ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId waitId - return _result + let cm = SCustomMethod "test" + waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri) + ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + return $ do + e <- _result + case A.fromJSON e of + A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing + A.Success a -> pure a