ghcide 0.3.0 → 0.4.0

raw patch · 45 files changed

+2078/−788 lines, 45 filesdep +implicit-hie-cradledep +record-dot-preprocessordep +record-hasfielddep ~ghc-checkdep ~hie-biosdep ~lsp-testPVP ok

version bump matches the API change (PVP)

Dependencies added: implicit-hie-cradle, record-dot-preprocessor, record-hasfield

Dependency ranges changed: ghc-check, hie-bios, lsp-test

API changes (from Hackage documentation)

Files

• CHANGELOG.md +23/−1
• README.md +25/−5
• bench/hist/Main.hs +51/−20
• exe/Main.hs +23/−9
• ghcide.cabal +25/−12
• session-loader/Development/IDE/Session.hs +154/−44
• src-ghc810/Development/IDE/GHC/HieAst.hs +1/−1
• src-ghc86/Development/IDE/GHC/HieAst.hs +1/−1
• src-ghc88/Development/IDE/GHC/HieAst.hs +1/−1
• src/Development/IDE.hs +46/−0
• src/Development/IDE/Core/Compile.hs +36/−32
• src/Development/IDE/Core/FileStore.hs +80/−50
• src/Development/IDE/Core/OfInterest.hs +25/−15
• src/Development/IDE/Core/PositionMapping.hs +56/−17
• src/Development/IDE/Core/Preprocessor.hs +12/−11
• src/Development/IDE/Core/RuleTypes.hs +33/−1
• src/Development/IDE/Core/Rules.hs +103/−55
• src/Development/IDE/Core/Service.hs +1/−1
• src/Development/IDE/Core/Shake.hs +104/−94
• src/Development/IDE/GHC/Compat.hs +100/−3
• src/Development/IDE/GHC/Error.hs +18/−13
• src/Development/IDE/GHC/Orphans.hs +5/−0
• src/Development/IDE/GHC/Util.hs +43/−18
• src/Development/IDE/Import/DependencyInformation.hs +24/−3
• src/Development/IDE/Import/FindImports.hs +8/−8
• src/Development/IDE/LSP/LanguageServer.hs +14/−6
• src/Development/IDE/LSP/Notifications.hs +18/−6
• src/Development/IDE/LSP/Outline.hs +33/−33
• src/Development/IDE/Plugin/CodeAction.hs +282/−123
• src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +20/−1
• src/Development/IDE/Plugin/CodeAction/RuleTypes.hs +3/−40
• src/Development/IDE/Plugin/CodeAction/Rules.hs +8/−24
• src/Development/IDE/Plugin/Completions.hs +5/−1
• src/Development/IDE/Plugin/Completions/Logic.hs +2/−1
• src/Development/IDE/Plugin/Test.hs +64/−0
• src/Development/IDE/Spans/AtPoint.hs +1/−1
• src/Development/IDE/Spans/Common.hs +16/−8
• src/Development/IDE/Spans/Documentation.hs +8/−6
• src/Development/IDE/Types/Action.hs +88/−0
• src/Development/IDE/Types/Exports.hs +75/−0
• src/Development/IDE/Types/Location.hs +8/−8
• src/Development/IDE/Types/Options.hs +54/−0
• test/data/hover/GotoHover.hs +1/−1
• test/exe/Main.hs +378/−112
• test/src/Development/IDE/Test.hs +2/−2

@@ -1,4 +1,26 @@-### unreleased+### 0.4.0 (2020-09-15)+* Fixes for GHC source plugins: dotpreprocessor works now - (srid)+* Use implicit-hie when no explicit hie.yaml (#782) - (Javier Neira)+* Extend position mapping with fuzzy ranges (#785) - (wz1000)+* Sort import suggestions (#793) - (Pepe Iborra)+* Save source files with HIE files (#701) - (fendor)+* Fully asynchronous request handling (#767) - (Pepe Iborra)+* Refinement holes (#748) - (Pepe Iborra)+* Fix haddock to markdown conversion (#757) - (George Thomas)+* Expose `getCompletionsLSP` to allow completions in hls (#756) - (wz1000)+* Suggestions for missing imports from local modules (#739) - (Pepe Iborra)+* Dynamically load libm on Linux for each new session (#723) - (Luke Lau)+* Use InitializeParams.rootUri for initial session setup (#713) - (shaurya gupta)+* Show documentation on hover for symbols defined in the same module (#691) - (wz1000)+* Suggest open imports (#740) - (Pepe Iborra)+* module Development.IDE (#724) - (Pepe Iborra)+* Ignore -Werror (#738) - (Pepe Iborra)+* Fix issue #710: fix suggest delete binding  (#728) - (Ray Shih)+* Generate doc file URL via LSP (to fix it for Windows) (#721) - (Nick Dunets)+* Fix `.hie` file location for `.hs-boot` files (#690) - (wz1000)+* Use argsVerbose to determine log level in test mode (#717) - (Ziyang Liu)+* output which cradle files were found (#716) - (Adam Sandberg Eriksson)+* Typecheck entire project on Initial Load and typecheck reverse dependencies of a file on saving (#688) - (wz1000)  ### 0.3.0 (2020-09-02) 

@@ -95,6 +95,24 @@  `ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist. +### Configuration++`ghcide` accepts the following lsp configuration options:++```typescript+{+  // When to check the dependents of a module+  // AlwaysCheck means retypechecking them on every change+  // CheckOnSave means dependent/parent modules will only be checked when you save+  // "CheckOnSaveAndClose" by default+  checkParents : "NeverCheck" | "CheckOnClose" | "CheckOnSaveAndClose" | "AlwaysCheck" | ,+  // Whether to check the entire project on initial load+  // true by default+  checkProject : boolean++}+```+ ### Using with VS Code  You can install the VSCode extension from the [VSCode@@ -311,15 +329,17 @@ See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options.  If you are touching performance sensitive code, take the time to run a differential-benchmark between HEAD and upstream using the benchHist script. The configuration in-`bench/hist.yaml` is setup to do this by default assuming upstream is-`origin/master`. Run the benchmarks with `stack`:+benchmark between HEAD and master using the benchHist script. This assumes that+"master" points to the upstream master. +Run the benchmarks with `stack`:+     export STACK_YAML=...     stack bench -It should take around 15 minutes and the results will be stored in the `bench-hist` folder.-To interpret the results, see the comments in the `bench/hist/Main.hs` module.+It should take around 15 minutes and the results will be stored in the `bench-hist` folder. To interpret the results, see the comments in the `bench/hist/Main.hs` module.++More details in [bench/README](bench/README.md)  ### Building the extension 

@@ -25,15 +25,14 @@    For diff graphs, the "previous version" is the preceding entry in the list of versions    in the config file. A possible improvement is to obtain this info via `git rev-list`. -   The script relies on stack for building and running all the binaries.-    To execute the script: -   > stack bench+   > cabal/stack bench     To build a specific analysis, enumerate the desired file artifacts     > stack bench --ba "bench-hist/HEAD/results.csv bench-hist/HEAD/edit.diff.svg"+   > cabal bench --benchmark-options "bench-hist/HEAD/results.csv bench-hist/HEAD/edit.diff.svg"   -} {-# LANGUAGE DeriveAnyClass    #-}@@ -42,6 +41,7 @@  import Control.Applicative (Alternative (empty)) import Control.Monad (when, forM, forM_, replicateM)+import Data.Char (toLower) import Data.Foldable (find) import Data.Maybe (fromMaybe) import Data.Text (Text)@@ -103,8 +103,10 @@       readSamples = askOracle $ GetSamples ()       getParent = askOracle . GetParent -  build <- liftIO $ outputFolder <$> readConfigIO config+  configStatic <- liftIO $ readConfigIO config   ghcideBenchPath <- ghcideBench <$> liftIO (readConfigIO config)+  let build = outputFolder configStatic+      buildSystem = buildTool configStatic    phony "all" $ do     Config {..} <- readConfig config@@ -139,11 +141,8 @@     &%> \[out, ghcpath] -> do       liftIO $ createDirectoryIfMissing True $ dropFileName out       need =<< getDirectoryFiles "." ["src//*.hs", "exe//*.hs", "ghcide.cabal"]-      cmd_-          ( "stack --local-bin-path=" <> takeDirectory out-              <> " --stack-yaml=stack88.yaml build ghcide:ghcide --copy-bins --ghc-options -rtsopts"-          )-      Stdout ghcLoc <- cmd (s "stack --stack-yaml=stack88.yaml exec which ghc")+      cmd_ $ buildGhcide buildSystem (takeDirectory out)+      ghcLoc <- findGhc buildSystem       writeFile' ghcpath ghcLoc    [ build -/- "*/ghcide",@@ -155,13 +154,8 @@       commitid <- readFile' $ b </> ver </> "commitid"       cmd_ $ "git worktree add bench-temp " ++ commitid       flip actionFinally (cmd_ (s "git worktree remove bench-temp --force")) $ do-        Stdout ghcLoc <- cmd [Cwd "bench-temp"] (s "stack --stack-yaml=stack88.yaml exec which ghc")-        cmd_-          [Cwd "bench-temp"]-          ( "stack --local-bin-path=../"-              <> takeDirectory out-              <> " --stack-yaml=stack88.yaml build ghcide:ghcide --copy-bins --ghc-options -rtsopts"-          )+        ghcLoc <- findGhc buildSystem+        cmd_ [Cwd "bench-temp"] $ buildGhcide buildSystem (".." </> takeDirectory out)         writeFile' ghcpath ghcLoc    priority 8000 $@@ -198,7 +192,7 @@                 RemEnv "GHC_PACKAGE_PATH",                 AddPath [takeDirectory ghcPath, "."] []               ]-              ghcideBenchPath+              ghcideBenchPath $               [ "--timeout=3000",                 "-v",                 "--samples=" <> show samples,@@ -208,7 +202,8 @@                 "--ghcide=" <> ghcide,                 "--select",                 unescaped (unescapeExperiment (Escaped $ dropExtension exp))-              ]+              ] +++              [ "--stack" | Stack == buildSystem]           cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv    build -/- "results.csv" %> \out -> do@@ -259,8 +254,31 @@         title = show (unescapeExperiment exp) <> " - live bytes over time"     plotDiagram False diagram out -----------------------------------------------------------------------------------------------------+-------------------------------------------------------------------------------- +buildGhcide :: BuildSystem -> String -> String+buildGhcide Cabal out = unwords+    ["cabal install"+    ,"exe:ghcide"+    ,"--installdir=" ++ out+    ,"--install-method=copy"+    ,"--overwrite-policy=always"+    ,"--ghc-options -rtsopts"+    ]+buildGhcide Stack out =+    "stack --local-bin-path=" <> out+        <> " build ghcide:ghcide --copy-bins --ghc-options -rtsopts"+++findGhc :: BuildSystem -> Action FilePath+findGhc Cabal =+    liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc"+findGhc Stack = do+    Stdout ghcLoc <- cmd (s "stack exec which ghc")+    return ghcLoc++--------------------------------------------------------------------------------+ data Config = Config   { experiments :: [Unescaped String],     samples :: Natural,@@ -268,7 +286,8 @@     -- | Path to the ghcide-bench binary for the experiments     ghcideBench :: FilePath,     -- | Output folder ('foo' works, 'foo/bar' does not)-    outputFolder :: String+    outputFolder :: String,+    buildTool :: BuildSystem   }   deriving (Generic, Show)   deriving anyclass (FromJSON, ToJSON)@@ -312,6 +331,18 @@   | otherwise = findPrev name (y : xx) findPrev name _ = name +data BuildSystem = Cabal | Stack+  deriving (Eq, Read, Show)++instance FromJSON BuildSystem where+    parseJSON x = fromString . map toLower <$> parseJSON x+      where+        fromString "stack" = Stack+        fromString "cabal" = Cabal+        fromString other = error $ "Unknown build system: " <> other++instance ToJSON BuildSystem where+    toJSON = toJSON . show ----------------------------------------------------------------------------------------------------  -- | A line in the output of -S

@@ -8,6 +8,7 @@ import Arguments import Control.Concurrent.Extra import Control.Monad.Extra+import Control.Lens ( (^.) ) import Data.Default import Data.List.Extra import Data.Maybe@@ -29,10 +30,12 @@ import Development.IDE.Plugin import Development.IDE.Plugin.Completions as Completions import Development.IDE.Plugin.CodeAction as CodeAction+import Development.IDE.Plugin.Test as Test import Development.IDE.Session 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@@ -43,7 +46,8 @@ import System.Time.Extra import Paths_ghcide import Development.GitRev-import qualified Data.HashSet as HashSet+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Aeson as J  import HIE.Bios.Cradle @@ -78,8 +82,14 @@     command <- makeLspCommandId "typesignature.add"      let plugins = Completions.plugin <> CodeAction.plugin-        onInitialConfiguration = const $ Right ()-        onConfigurationChange  = const $ Right ()+            <> if argsTesting then Test.plugin else mempty+        onInitialConfiguration :: InitializeRequest -> Either T.Text LspConfig+        onInitialConfiguration x = case x ^. params . initializationOptions of+          Nothing -> Right defaultLspConfig+          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 [command]                       , LSP.completionTriggerCharacters = Just "."                       }@@ -88,15 +98,18 @@         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 -> do+        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-            sessionLoader <- loadSession dir+            sessionLoader <- loadSession $ fromMaybe dir rootPath+            config <- fromMaybe defaultLspConfig <$> getConfig             let options = (defaultIdeOptions sessionLoader)                     { optReportProgress = clientSupportsProgress caps                     , optShakeProfiling = argsShakeProfiling                     , optTesting        = IdeTesting argsTesting                     , optThreads        = argsThreads+                    , optCheckParents   = checkParents config+                    , optCheckProject   = checkProject config                     }                 logLevel = if argsVerbose then minBound else Info             debouncer <- newAsyncDebouncer@@ -121,15 +134,17 @@         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 ()))+        let logLevel = if argsVerbose then minBound else Info+            dummyWithProg _ _ f = f (const (pure ()))         sessionLoader <- loadSession dir-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger minBound) debouncer (defaultIdeOptions sessionLoader)  vfs+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer (defaultIdeOptions sessionLoader)  vfs          putStrLn "\nStep 4/4: Type checking the files"-        setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files+        setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files         results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)         let (worked, failed) = partition fst $ zip (map isJust results) files         when (failed /= []) $@@ -157,4 +172,3 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =     withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags showEvent lock e = withLock lock $ print e-

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            0.3.0+version:            0.4.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.5+tested-with:        GHC>=8.4.4 extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md                     test/data/hover/*.hs                     test/data/multi/cabal.project@@ -83,10 +83,11 @@         ghc >= 8.4,         -- These dependencies are used by Development.IDE.Session and are         -- Haskell specific. So don't use them when building with -fghc-lib!-        ghc-check,+        ghc-check >=0.5.0.1,         ghc-paths,         cryptohash-sha1 >=0.11.100 && <0.12,-        hie-bios == 0.6.*,+        hie-bios >= 0.7.1 && < 0.8.0,+        implicit-hie-cradle >= 0.2.0.0 && < 0.3,         base16-bytestring >=0.1.1 && <0.2     if os(windows)       build-depends:@@ -101,6 +102,7 @@         BangPatterns         DeriveFunctor         DeriveGeneric+        FlexibleContexts         GeneralizedNewtypeDeriving         LambdaCase         NamedFieldPuns@@ -117,6 +119,7 @@     include-dirs:         include     exposed-modules:+        Development.IDE         Development.IDE.Compat         Development.IDE.Core.Debouncer         Development.IDE.Core.FileStore@@ -138,12 +141,14 @@         Development.IDE.LSP.Server         Development.IDE.Spans.Common         Development.IDE.Types.Diagnostics+        Development.IDE.Types.Exports         Development.IDE.Types.Location         Development.IDE.Types.Logger         Development.IDE.Types.Options         Development.IDE.Plugin         Development.IDE.Plugin.Completions         Development.IDE.Plugin.CodeAction+        Development.IDE.Plugin.Test      -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses     -- the real GHC library and the types are incompatible. Furthermore, when@@ -177,6 +182,7 @@         Development.IDE.Plugin.CodeAction.RuleTypes         Development.IDE.Plugin.Completions.Logic         Development.IDE.Plugin.Completions.Types+        Development.IDE.Types.Action     if (impl(ghc > 8.5) && impl(ghc < 8.7)) && !flag(ghc-lib)       hs-source-dirs: src-ghc86       other-modules:@@ -195,11 +201,7 @@       other-modules:         Development.IDE.GHC.HieAst         Development.IDE.GHC.HieBin-    ghc-options: -Wall -Wno-name-shadowing-    -- This is needed to prevent a GHC crash when building-    -- Development.IDE.Session with stack on 8.10.1 on Windows-    if (impl(ghc > 8.9) && os(windows))-      ghc-options: -fexternal-interpreter+    ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns  executable ghcide-test-preprocessor     default-language: Haskell2010@@ -221,6 +223,7 @@         BangPatterns         DeriveFunctor         DeriveGeneric+        FlexibleContexts         GeneralizedNewtypeDeriving         LambdaCase         NamedFieldPuns@@ -254,6 +257,7 @@     ghc-options:                 -threaded                 -Wall+                -Wincomplete-uni-patterns                 -Wno-name-shadowing                 -- allow user RTS overrides                 -rtsopts@@ -263,6 +267,7 @@                 "-with-rtsopts=-I0 -qg -A128M"     main-is: Main.hs     build-depends:+        aeson,         base == 4.*,         data-default,         directory,@@ -272,8 +277,9 @@         hashable,         haskell-lsp,         haskell-lsp-types,-        hie-bios >= 0.6.0 && < 0.7,+        hie-bios,         ghcide,+        lens,         optparse-applicative,         text,         unordered-containers@@ -285,6 +291,7 @@         BangPatterns         DeriveFunctor         DeriveGeneric+        FlexibleContexts         GeneralizedNewtypeDeriving         LambdaCase         NamedFieldPuns@@ -328,7 +335,7 @@         haskell-lsp-types,         network-uri,         lens,-        lsp-test >= 0.11.0.1 && < 0.12,+        lsp-test >= 0.11.0.5 && < 0.12,         optparse-applicative,         process,         QuickCheck,@@ -343,9 +350,13 @@         tasty-quickcheck,         tasty-rerun,         text+    if (impl(ghc >= 8.6))+      build-depends:+          record-dot-preprocessor,+          record-hasfield     hs-source-dirs: test/cabal test/exe test/src bench/lib     include-dirs: include-    ghc-options: -threaded -Wall -Wno-name-shadowing+    ghc-options: -threaded -Wall -Wno-name-shadowing -O0     main-is: Main.hs     other-modules:         Development.IDE.Test@@ -355,6 +366,7 @@         BangPatterns         DeriveFunctor         DeriveGeneric+        FlexibleContexts         GeneralizedNewtypeDeriving         LambdaCase         NamedFieldPuns@@ -393,6 +405,7 @@         BangPatterns         DeriveFunctor         DeriveGeneric+        FlexibleContexts         GeneralizedNewtypeDeriving         LambdaCase         NamedFieldPuns

@@ -25,6 +25,7 @@ import qualified Data.ByteString.Base16 as B16 import Data.Either.Extra import Data.Function+import Data.Hashable import Data.List import Data.IORef import Data.Maybe@@ -32,9 +33,12 @@ import Data.Version import Development.IDE.Core.OfInterest import Development.IDE.Core.Shake+import Development.IDE.Core.RuleTypes+import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import Development.IDE.Session.VersionCheck import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options@@ -43,21 +47,25 @@ import HIE.Bios 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 System.Directory+import qualified System.Directory.Extra as IO import System.FilePath import System.Info import System.IO -import GHC+import GHCi import DynFlags import HscTypes import Linker import Module import NameCache import Packages+import Control.Exception (evaluate)+import Data.Char  -- | Given a root directory, return a Shake 'Action' which setups an -- 'IdeGhcSession' given a file.@@ -96,9 +104,29 @@   runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))    return $ do-    ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress, ideNc} <- getShakeExtras-    IdeOptions{optTesting = IdeTesting optTesting} <- getIdeOptions+    extras@ShakeExtras{logger, eventer, restartShakeSession,+                       withIndefiniteProgress, ideNc, knownTargetsVar+                      } <- getShakeExtras +    IdeOptions{ optTesting = IdeTesting optTesting+              , optCheckProject = CheckProject checkProject+              , optCustomDynFlags+              } <- getIdeOptions++        -- populate the knownTargetsVar with all the+        -- files in the project so that `knownFiles` can learn about them and+        -- we can generate a complete module graph+    let extendKnownTargets newTargets = do+          knownTargets <- forM newTargets $ \TargetDetails{..} -> do+            found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations+            return (targetModule, found)+          modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do+            let known' = HM.unionWith (<>) known $ HM.fromList knownTargets+            when (known /= known') $+                logDebug logger $ "Known files updated: " <>+                    T.pack(show $ (HM.map . map) fromNormalizedFilePath known')+            evaluate known'+     -- Create a new HscEnv from a hieYaml root and a set of options     -- If the hieYaml file already has an HscEnv, the new component is     -- combined with the components in the old HscEnv into a new HscEnv@@ -109,7 +137,7 @@           -- Parse DynFlags for the newly discovered component           hscEnv <- emptyHscEnv ideNc libDir           (df, targets) <- evalGhcEnv hscEnv $-              setOptions opts (hsc_dflags hscEnv)+              first optCustomDynFlags <$> setOptions opts (hsc_dflags hscEnv)           let deps = componentDependencies opts ++ maybeToList hieYaml           dep_info <- getDependencyInfo deps           -- Now lookup to see whether we are combining with an existing HscEnv@@ -170,9 +198,26 @@       let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)-                -> IO (IdeResult HscEnvEq,[FilePath])+                -> IO ([NormalizedFilePath],(IdeResult HscEnvEq,[FilePath]))         session args@(hieYaml, _cfp, _opts, _libDir) = do           (hscEnv, new, old_deps) <- packageSetup args++          -- Whenever we spin up a session on Linux, dynamically load libm.so.6+          -- in. We need this in case the binary is statically linked, in which+          -- case the interactive session will fail when trying to load+          -- ghc-prim, which happens whenever Template Haskell is being+          -- evaluated or haskell-language-server's eval plugin tries to run+          -- some code. If the binary is dynamically linked, then this will have+          -- no effect.+          -- See https://github.com/haskell/haskell-language-server/issues/221+          when (os == "linux") $ do+            initObjLinker hscEnv+            res <- loadDLL hscEnv "libm.so.6"+            case res of+              Nothing -> pure ()+              Just err -> hPutStrLn stderr $+                "Error dynamically loading libm.so.6:\n" <> err+           -- Make a map from unit-id to DynFlags, this is used when trying to           -- resolve imports. (especially PackageImports)           let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)@@ -182,30 +227,41 @@            -- New HscEnv for the component in question, returns the new HscEnvEq and           -- a mapping from FilePath to the newly created HscEnvEq.-          let new_cache = newComponentCache logger hscEnv uids+          let new_cache = newComponentCache logger hieYaml hscEnv uids           (cs, res) <- new_cache new           -- Modified cache targets for everything else in the hie.yaml file           -- which now uses the same EPS and so on           cached_targets <- concatMapM (fmap fst . new_cache) old_deps++          let all_targets = cs ++ cached_targets+           modifyVar_ fileToFlags $ \var -> do-              pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var+              pure $ Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets)) var +          extendKnownTargets all_targets+           -- Invalidate all the existing GhcSession build nodes by restarting the Shake session           invalidateShakeCache           restartShakeSession [kick] -          return (second Map.keys res)+          let resultCachedTargets = concatMap targetLocations all_targets -    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])+          return (resultCachedTargets, second Map.keys res)++    let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath]))         consultCradle hieYaml cfp = do-           when optTesting $ eventer $ notifyCradleLoaded cfp-           logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)+           lfp <- flip makeRelative cfp <$> getCurrentDirectory+           logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) -           cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml-           -- Display a user friendly progress message here: They probably don't know what a-           -- cradle is-           let progMsg = "Setting up project " <> T.pack (takeBaseName (cradleRootDir cradle))+           when (isNothing hieYaml) $ eventer $ notifyUserImplicitCradle lfp +           cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml++           when optTesting $ eventer $ notifyCradleLoaded lfp++           -- 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 @@ -219,7 +275,7 @@                  InstallationNotFound{..} ->                      error $ "GHC installation not found in libdir: " <> libdir                  InstallationMismatch{..} ->-                     return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])+                     return ([],(([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]))                  InstallationChecked _compileTime _ghcLibCheck ->                    session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)              -- Failure case, either a cradle error or the none cradle@@ -229,11 +285,12 @@                let res = (map (renderCradleError ncfp) err, Nothing)                modifyVar_ fileToFlags $ \var -> do                  pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var-               return (res,[])+               return ([ncfp],(res,[]))      -- This caches the mapping from hie.yaml + Mod.hs -> [String]     -- Returns the Ghc session and the cradle dependencies-    let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath])+    let sessionOpts :: (Maybe FilePath, FilePath)+                    -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath]))         sessionOpts (hieYaml, file) = do           v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags           cfp <- canonicalizePath file@@ -248,29 +305,43 @@                   -- Keep the same name cache                   modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )                   consultCradle hieYaml cfp-                else return (opts, Map.keys old_di)+                else return (HM.keys v, (opts, Map.keys old_di))             Nothing -> consultCradle hieYaml cfp      -- The main function which gets options for a file. We only want one of these running     -- at a time. Therefore the IORef contains the currently running cradle, if we try     -- to get some more options then we wait for the currently running action to finish     -- before attempting to do so.-    let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])+    let getOptions :: FilePath -> IO ([NormalizedFilePath],(IdeResult HscEnvEq, [FilePath]))         getOptions file = do             hieYaml <- cradleLoc file             sessionOpts (hieYaml, file) `catch` \e ->-                return (([renderPackageSetupException file e], Nothing),[])+                return ([],(([renderPackageSetupException file e], Nothing),[]))      returnWithVersion $ \file -> do-      liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do+      (cs, opts) <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do         -- If the cradle is not finished, then wait for it to finish.         void $ wait as         as <- async $ getOptions file-        return (as, wait as)+        return (fmap snd as, wait as)+      unless (null cs) $ do+        cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) cs+        -- Typecheck all files in the project on startup+        void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do+          when checkProject $ do+            mmt <- uses GetModificationTime cfps'+            let cs_exist = catMaybes (zipWith (<$) cfps' mmt)+            modIfaces <- uses GetModIface cs_exist+            -- update xports map+            extras <- getShakeExtras+            let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces+            liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>)+      pure opts  -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory+ cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath                       -> IO (Either [CradleError] (ComponentOptions, FilePath)) cradleToOptsAndLibDir cradle file = do@@ -300,50 +371,79 @@     initDynLinker env     pure $ setNameCache nc env --- | Convert a target to a list of potential absolute paths.--- A TargetModule can be anywhere listed by the supplied include--- directories--- A target file is a relative path but with a specific prefix so just need--- to canonicalise it.-targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath]-targetToFile is (TargetModule mod) = do+data TargetDetails = TargetDetails+  {+      targetModule :: !ModuleName,+      targetEnv :: !(IdeResult HscEnvEq),+      targetDepends :: !DependencyInfo,+      targetLocations :: ![NormalizedFilePath]+  }++fromTargetId :: [FilePath]          -- ^ import paths+             -> TargetId+             -> IdeResult HscEnvEq+             -> DependencyInfo+             -> IO [TargetDetails]+-- For a target module we consider all the import paths+fromTargetId is (TargetModule mod) env dep = do     let fps = [i </> moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ]         exts = ["hs", "hs-boot", "lhs"]-    mapM (fmap toNormalizedFilePath' . canonicalizePath) fps-targetToFile _ (TargetFile f _) = do-  f' <- canonicalizePath f-  return [toNormalizedFilePath' f']+    locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps+    return [TargetDetails mod env dep locs]+-- For a 'TargetFile' we consider all the possible module names+fromTargetId _ (TargetFile f _) env deps = do+    nf <- toNormalizedFilePath' <$> canonicalizePath f+    return [TargetDetails m env deps [nf] | m <- moduleNames f] +-- >>> moduleNames "src/A/B.hs"+-- [A.B,B]+moduleNames :: FilePath -> [ModuleName]+moduleNames f = map (mkModuleName .intercalate ".") $ init $ tails nameSegments+    where+        nameSegments = reverse+                     $ takeWhile (isUpper . head)+                     $ reverse+                     $ splitDirectories+                     $ dropExtension f++toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]+toFlagsMap TargetDetails{..} =+    [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]++ setNameCache :: IORef NameCache -> HscEnv -> HscEnv setNameCache nc hsc = hsc { hsc_NC = nc } - -- | Create a mapping from FilePaths to HscEnvEqs newComponentCache          :: Logger+         -> Maybe FilePath -- Path to cradle          -> HscEnv          -> [(InstalledUnitId, DynFlags)]          -> ComponentInfo-         -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo))-newComponentCache logger hsc_env uids ci = do+         -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))+newComponentCache logger cradlePath hsc_env uids ci = do     let df = componentDynFlags ci     let hscEnv' = hsc_env { hsc_dflags = df                           , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } -    henv <- newHscEnvEq hscEnv' uids-    let res = (([], Just henv), componentDependencyInfo ci)+    let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath+    henv <- newFunc hscEnv' uids+    let targetEnv = ([], Just henv)+        targetDepends = componentDependencyInfo ci+        res = (targetEnv, targetDepends)     logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) -    let is = importPaths df-    ctargets <- concatMapM (targetToFile is  . targetId) (componentTargets ci)+    let mk t = fromTargetId (importPaths df) (targetId t) targetEnv targetDepends+    ctargets <- concatMapM mk (componentTargets ci)+     -- A special target for the file which caused this wonderful     -- component to be created. In case the cradle doesn't list all the targets for     -- the component, in which case things will be horribly broken anyway.     -- Otherwise, we will immediately attempt to reload this module which     -- causes an infinite loop and high CPU usage.-    let special_target = (componentFP ci, res)-    let xs = map (,res) ctargets-    return (special_target:xs, res)+    let special_target = TargetDetails (mkModuleName "special") targetEnv targetDepends [componentFP ci]+    return (special_target:ctargets, res)  {- Note [Avoiding bad interface files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -523,6 +623,7 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do     (dflags', targets) <- addCmdOpts theOpts dflags     let dflags'' =+          disableWarningsAsErrors $           -- disabled, generated directly by ghcide instead           flip gopt_unset Opt_WriteInterface $           -- disabled, generated directly by ghcide instead@@ -531,6 +632,7 @@           setIgnoreInterfacePragmas $           setLinkerOptions $           disableOptimisation $+          setUpTypedHoles $           makeDynFlagsAbsolute compRoot dflags'     -- initPackages parses the -package flags and     -- sets up the visibility for each component.@@ -571,6 +673,14 @@ -- | Sub directory for the cache path cacheDir :: String cacheDir = "ghcide"++notifyUserImplicitCradle:: FilePath -> FromServerMessage+notifyUserImplicitCradle fp =+    NotShowMessage $+    NotificationMessage "2.0" WindowShowMessage $ 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)"  notifyCradleLoaded :: FilePath -> FromServerMessage notifyCradleLoaded fp =

@@ -1,4 +1,4 @@-+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  {- Forked from GHC v8.10.1 to work around the readFile side effect in mkHiefile

@@ -1,4 +1,4 @@-+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile 

@@ -1,4 +1,4 @@-+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile 

@@ -0,0 +1,46 @@+module Development.IDE+(+    -- TODO It would be much nicer to enumerate all the exports+    -- and organize them in sections+    module X++) where++import Development.IDE.Core.RuleTypes as X+import Development.IDE.Core.Rules as X+  (GhcSessionIO(..)+  ,getAtPoint+  ,getDefinition+  ,getParsedModule+  ,getTypeDefinition+  )+import Development.IDE.Core.FileExists as X+  (getFileExists)+import Development.IDE.Core.FileStore as X+  (getFileContents)+import Development.IDE.Core.IdeConfiguration as X+  (IdeConfiguration(..)+  ,isWorkspaceFile)+import Development.IDE.Core.OfInterest as X (getFilesOfInterest)+import Development.IDE.Core.Service as X (runAction)+import Development.IDE.Core.Shake as X+  ( IdeState,+    shakeExtras,+    ShakeExtras,+    IdeRule,+    define, defineEarlyCutoff,+    GetModificationTime(GetModificationTime),+    use, useNoFile, uses, useWithStale, useWithStaleFast, useWithStaleFast',+    FastResult(..),+    use_, useNoFile_, uses_, useWithStale_,+    ideLogger,+    actionLogger,+    IdeAction(..), runIdeAction+  )+import Development.IDE.GHC.Error as X+import Development.IDE.GHC.Util as X+import Development.IDE.Plugin as X+import Development.IDE.Types.Diagnostics as X+import Development.IDE.Types.Location as X+import Development.IDE.Types.Logger as X+import Development.Shake as X (Action, action, Rules, RuleResult)

@@ -19,7 +19,7 @@   , mkTcModuleResult   , generateByteCode   , generateAndWriteHieFile-  , generateAndWriteHiFile+  , writeHiFile   , getModSummaryFromImports   , loadHieFile   , loadInterface@@ -43,7 +43,6 @@ import Development.IDE.Types.Location  #if MIN_GHC_API_VERSION(8,6,0)-import DynamicLoading (initializePlugins) import LoadIface (loadModuleInterface) #endif @@ -73,6 +72,7 @@ import Control.Monad.Except import Control.Monad.Trans.Except import Data.Bifunctor                           (first, second)+import qualified Data.ByteString as BS import qualified Data.Text as T import           Data.IORef import           Data.List.Extra@@ -100,8 +100,8 @@ parseModule IdeOptions{..} env comp_pkgs filename modTime mbContents =     fmap (either (, Nothing) id) $     evalGhcEnv env $ runExceptT $ do-        (contents, dflags) <- preprocessor filename mbContents-        (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename modTime contents+        (contents, dflags) <- preprocessor env filename mbContents+        (diag, modu) <- parseFileContents env optPreprocessor dflags comp_pkgs filename modTime contents         return (diag, Just (contents, modu))  @@ -133,9 +133,10 @@         (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->             GHC.typecheckModule $ enableTopLevelWarnings                                 $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}-        tcm2 <- mkTcModuleResult tcm         let errorPipeline = unDefer . hideDiag dflags-        return (map errorPipeline warnings, tcm2)+            diags = map errorPipeline warnings+        tcm2 <- mkTcModuleResult tcm (any fst diags)+        return (map snd diags, tcm2)     where         demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id @@ -233,11 +234,11 @@ update_pm_mod_summary up pm =   pm{pm_mod_summary = up $ pm_mod_summary pm} -unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic-unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = upgradeWarningToError fd-unDefer (Reason Opt_WarnTypedHoles                 , fd) = upgradeWarningToError fd-unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError fd-unDefer ( _                                        , fd) = fd+unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)+unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = (True, upgradeWarningToError fd)+unDefer (Reason Opt_WarnTypedHoles                 , fd) = (True, upgradeWarningToError fd)+unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd)+unDefer ( _                                        , fd) = (False, fd)  upgradeWarningToError :: FileDiagnostic -> FileDiagnostic upgradeWarningToError (nfp, sh, fd) =@@ -257,8 +258,9 @@ mkTcModuleResult     :: GhcMonad m     => TypecheckedModule+    -> Bool     -> m TcModuleResult-mkTcModuleResult tcm = do+mkTcModuleResult tcm upgradedError = do     session <- getSession     let sf = modInfoSafe (tm_checked_module_info tcm) #if MIN_GHC_API_VERSION(8,10,0)@@ -267,7 +269,7 @@     (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv #endif     let mod_info = HomeModInfo iface details Nothing-    return $ TcModuleResult tcm mod_info+    return $ TcModuleResult tcm mod_info upgradedError   where     (tcGblEnv, details) = tm_internals_ tcm @@ -278,13 +280,13 @@   (tempFilePath, cleanUp) <- newTempFileWithin dir   (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp -generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO [FileDiagnostic]-generateAndWriteHieFile hscEnv tcm =+generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> BS.ByteString -> IO [FileDiagnostic]+generateAndWriteHieFile hscEnv tcm source =   handleGenerationErrors dflags "extended interface generation" $ do     case tm_renamed_source tcm of       Just rnsrc -> do         hf <- runHsc hscEnv $-          GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc ""+          GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc source         atomicFileWrite targetPath $ flip GHC.writeHieFile hf       _ ->         return ()@@ -294,18 +296,14 @@     mod_location = ms_location mod_summary     targetPath   = Compat.ml_hie_file mod_location -generateAndWriteHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]-generateAndWriteHiFile hscEnv tc =+writeHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]+writeHiFile hscEnv tc =   handleGenerationErrors dflags "interface generation" $ do     atomicFileWrite targetPath $ \fp ->       writeIfaceFile dflags fp modIface   where     modIface = hm_iface $ tmrModInfo tc-    modSummary = tmrModSummary tc-    targetPath = withBootSuffix $ ml_hi_file $ ms_location $ tmrModSummary tc-    withBootSuffix = case ms_hsc_src modSummary of-                HsBootFile -> addBootSuffix-                _ -> id+    targetPath = ml_hi_file $ ms_location $ tmrModSummary tc     dflags = hsc_dflags hscEnv  handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]@@ -407,6 +405,10 @@     , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"     ]) +withBootSuffix :: HscSource -> ModLocation -> ModLocation+withBootSuffix HsBootFile = addBootSuffixLocnOut+withBootSuffix _ = id+ -- | Produce a module summary from a StringBuffer. getModSummaryFromBuffer     :: GhcMonad m@@ -423,7 +425,7 @@   let InstalledUnitId unitId = thisInstalledUnitId dflags   return $ ModSummary     { ms_mod          = mkModule (fsToUnitId unitId) modName-    , ms_location     = modLoc+    , ms_location     = withBootSuffix sourceType modLoc     , ms_hs_date      = modTime     , ms_textual_imps = [imp | (False, imp) <- imports]     , ms_hspp_file    = fp@@ -453,12 +455,13 @@ --   Runs preprocessors as needed. getModSummaryFromImports   :: (HasDynFlags m, ExceptionMonad m, MonadIO m)-  => FilePath+  => HscEnv+  -> FilePath   -> UTCTime   -> Maybe SB.StringBuffer   -> ExceptT [FileDiagnostic] m ModSummary-getModSummaryFromImports fp modTime contents = do-    (contents, dflags) <- preprocessor fp contents+getModSummaryFromImports env fp modTime contents = do+    (contents, dflags) <- preprocessor env fp contents     (srcImports, textualImports, L _ moduleName) <-         ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp @@ -483,7 +486,7 @@                 , ms_hspp_file    = fp                 , ms_hspp_opts    = dflags                 , ms_iface_date   = Nothing-                , ms_location     = modLoc+                , ms_location     = withBootSuffix sourceType modLoc                 , ms_obj_date     = Nothing                 , ms_parsed_mod   = Nothing                 , ms_srcimps      = srcImports@@ -529,14 +532,15 @@ -- parsed module (or errors) and any parse warnings. Does not run any preprocessors parseFileContents        :: GhcMonad m-       => (GHC.ParsedSource -> IdePreprocessedSource)+       => HscEnv+       -> (GHC.ParsedSource -> IdePreprocessedSource)        -> DynFlags -- ^ flags to use        -> [PackageName] -- ^ The package imports to ignore        -> FilePath  -- ^ the filename (for source locations)        -> UTCTime   -- ^ the modification timestamp        -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)        -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)-parseFileContents customPreprocessor dflags comp_pkgs filename modTime contents = do+parseFileContents env customPreprocessor dflags comp_pkgs filename modTime contents = do    let loc  = mkRealSrcLoc (mkFastString filename) 1 1    case unP Parser.parseModule (mkPState dflags contents loc) of #if MIN_GHC_API_VERSION(8,10,0)@@ -571,16 +575,16 @@                let parsed' = removePackageImports comp_pkgs parsed                let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns                ms <- getModSummaryFromBuffer filename modTime dflags parsed' contents+               parsed'' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed                let pm =                      ParsedModule {                          pm_mod_summary = ms-                       , pm_parsed_source = parsed'+                       , pm_parsed_source = parsed''                        , pm_extra_src_files=[] -- src imports not allowed                        , pm_annotations = hpm_annotations                       }                    warnings = diagFromErrMsgs "parser" dflags warns                pure (warnings ++ preproc_warnings, pm)-  -- | After parsing the module remove all package imports referring to -- these packages as we have already dealt with what they map to.

@@ -6,20 +6,22 @@ module Development.IDE.Core.FileStore(     getFileContents,     getVirtualFile,-    setBufferModified,     setFileModified,     setSomethingModified,     fileStoreRules,     modificationTime,+    typecheckParents,     VFSHandle,     makeVFSHandle,-    makeLSPVFSHandle+    makeLSPVFSHandle,+    isFileOfInterestRule     ) where  import Development.IDE.GHC.Orphans() import           Development.IDE.Core.Shake import Control.Concurrent.Extra import qualified Data.Map.Strict as Map+import qualified Data.HashMap.Strict as HM import Data.Maybe import qualified Data.Text as T import           Control.Monad.Extra@@ -34,9 +36,11 @@ import qualified Data.ByteString.Char8 as BS import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location-import Development.IDE.Core.OfInterest (kick)+import Development.IDE.Core.OfInterest (getFilesOfInterest, kick) import Development.IDE.Core.RuleTypes+import Development.IDE.Types.Options import qualified Data.Rope.UTF16 as Rope+import Development.IDE.Import.DependencyInformation  #ifdef mingw32_HOST_OS import qualified System.Directory as Dir@@ -90,6 +94,12 @@    }  +isFileOfInterestRule :: Rules ()+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do+    filesOfInterest <- getFilesOfInterest+    let res = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest+    return (Just $ BS.pack $ show $ hash res, ([], Just res))+ -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text) @@ -117,31 +127,31 @@                 if isDoesNotExistError e && not missingFileDiags                     then return (Nothing, ([], Nothing))                     else return (Nothing, ([diag], Nothing))-  where-    -- Dir.getModificationTime is surprisingly slow since it performs-    -- a ton of conversions. Since we do not actually care about-    -- the format of the time, we can get away with something cheaper.-    -- For now, we only try to do this on Unix systems where it seems to get the-    -- time spent checking file modifications (which happens on every change)-    -- from > 0.5s to ~0.15s.-    -- We might also want to try speeding this up on Windows at some point.-    -- TODO leverage DidChangeWatchedFile lsp notifications on clients that-    -- support them, as done for GetFileExists-    getModTime :: FilePath -> IO (Int64, Int64)-    getModTime f =++-- Dir.getModificationTime is surprisingly slow since it performs+-- a ton of conversions. Since we do not actually care about+-- the format of the time, we can get away with something cheaper.+-- For now, we only try to do this on Unix systems where it seems to get the+-- time spent checking file modifications (which happens on every change)+-- from > 0.5s to ~0.15s.+-- We might also want to try speeding this up on Windows at some point.+-- TODO leverage DidChangeWatchedFile lsp notifications on clients that+-- support them, as done for GetFileExists+getModTime :: FilePath -> IO (Int64, Int64)+getModTime f = #ifdef mingw32_HOST_OS-        do time <- Dir.getModificationTime f-           let !day = fromInteger $ toModifiedJulianDay $ utctDay time-               !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time-           pure (day, dayTime)+    do time <- Dir.getModificationTime f+       let !day = fromInteger $ toModifiedJulianDay $ utctDay time+           !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time+       pure (day, dayTime) #else-        withCString f $ \f' ->-        alloca $ \secPtr ->-        alloca $ \nsecPtr -> do-            Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr-            CTime sec <- peek secPtr-            CLong nsec <- peek nsecPtr-            pure (sec, nsec)+    withCString f $ \f' ->+    alloca $ \secPtr ->+    alloca $ \nsecPtr -> do+        Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr+        CTime sec <- peek secPtr+        CLong nsec <- peek nsecPtr+        pure (sec, nsec)  -- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow -- as doing the FFI call ourselves :(.@@ -150,11 +160,14 @@  modificationTime :: FileVersion -> Maybe UTCTime modificationTime VFSVersion{} = Nothing-modificationTime (ModificationTime large small) =+modificationTime (ModificationTime large small) = Just $ internalTimeToUTCTime large small++internalTimeToUTCTime :: Int64 -> Int64 -> UTCTime+internalTimeToUTCTime large small = #ifdef mingw32_HOST_OS-    Just (UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small))+    UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small) #else-    Just (systemToUTCTime $ MkSystemTime large (fromIntegral small))+    systemToUTCTime $ MkSystemTime large (fromIntegral small) #endif  getFileContentsRule :: VFSHandle -> Rules ()@@ -180,7 +193,15 @@ getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text) getFileContents f = do     (fv, txt) <- use_ GetFileContents f-    modTime <- maybe (liftIO getCurrentTime) return $ modificationTime fv+    modTime <- case modificationTime fv of+      Just t -> pure t+      Nothing -> do+        foi <- use_ IsFileOfInterest f+        liftIO $ case foi of+          IsFOI Modified -> getCurrentTime+          _ -> do+            (large,small) <- getModTime $ fromNormalizedFilePath f+            pure $ internalTimeToUTCTime large small     return (modTime, txt)  fileStoreRules :: VFSHandle -> Rules ()@@ -188,31 +209,40 @@     addIdeGlobal vfs     getModificationTimeRule vfs     getFileContentsRule vfs----- | Notify the compiler service that a particular file has been modified.---   Use 'Nothing' to say the file is no longer in the virtual file system---   but should be sourced from disk, or 'Just' to give its new value.-setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()-setBufferModified state absFile contents = do-    VFSHandle{..} <- getIdeGlobalState state-    whenJust setVirtualFileContents $ \set ->-        set (filePathToUri' absFile) contents-    void $ shakeRestart state [kick]+    isFileOfInterestRule  -- | Note that some buffer for a specific file has been modified but not -- with what changes.-setFileModified :: IdeState -> NormalizedFilePath -> IO ()-setFileModified state nfp = do+setFileModified :: IdeState+                -> Bool -- ^ Was the file saved?+                -> NormalizedFilePath+                -> IO ()+setFileModified state saved nfp = do+    ideOptions <- getIdeOptionsIO $ shakeExtras state+    let checkParents = case optCheckParents ideOptions of+          AlwaysCheck -> True+          CheckOnSaveAndClose -> saved+          _ -> False     VFSHandle{..} <- getIdeGlobalState state     when (isJust setVirtualFileContents) $-        fail "setSomethingModified can't be called on this type of VFSHandle"-    let da = mkDelayedAction "FileStoreTC" L.Info $ do-          ShakeExtras{progressUpdate} <- getShakeExtras-          liftIO $ progressUpdate KickStarted-          void $ use GetSpanInfo nfp-          liftIO $ progressUpdate KickCompleted-    shakeRestart state [da]+        fail "setFileModified can't be called on this type of VFSHandle"+    shakeRestart state [kick]+    when checkParents $+      typecheckParents state nfp++typecheckParents :: IdeState -> NormalizedFilePath -> IO ()+typecheckParents state nfp = void $ shakeEnqueue (shakeExtras state) parents+  where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction nfp)++typecheckParentsAction :: NormalizedFilePath -> Action ()+typecheckParentsAction nfp = do+    revs <- reverseDependencies nfp <$> useNoFile_ GetModuleGraph+    logger <- logger <$> getShakeExtras+    let log = L.logInfo logger . T.pack+    liftIO $ do+      (log $ "Typechecking reverse dependencies for" ++ show nfp ++ ": " ++ show revs)+        `catch` \(e :: SomeException) -> log (show e)+    () <$ uses GetModIface revs  -- | Note that some buffer somewhere has been modified, but don't say what. --   Only valid if the virtual file system was initialised by LSP, as that

@@ -9,7 +9,7 @@ module Development.IDE.Core.OfInterest(     ofInterestRules,     getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,-    kick+    kick, FileOfInterestStatus(..)     ) where  import Control.Concurrent.Extra@@ -20,22 +20,24 @@ import Data.Typeable import qualified Data.ByteString.UTF8 as BS import Control.Exception-import Data.HashSet (HashSet)-import qualified Data.HashSet as HashSet+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as T import Data.Tuple.Extra import Development.Shake +import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake-import Control.Monad+import Data.Maybe (mapMaybe)+import GhcPlugins (HomeModInfo(hm_iface)) -newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))+newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar -type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath+type instance RuleResult GetFilesOfInterest = HashMap NormalizedFilePath FileOfInterestStatus  data GetFilesOfInterest = GetFilesOfInterest     deriving (Eq, Show, Typeable, Generic)@@ -47,7 +49,7 @@ -- | The rule that initialises the files of interest state. ofInterestRules :: Rules () ofInterestRules = do-    addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)+    addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)     defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do         alwaysRerun         filesOfInterest <- getFilesOfInterestUntracked@@ -55,7 +57,7 @@   -- | Get the files that are open in the IDE.-getFilesOfInterest :: Action (HashSet NormalizedFilePath)+getFilesOfInterest :: Action (HashMap NormalizedFilePath FileOfInterestStatus) getFilesOfInterest = useNoFile_ GetFilesOfInterest  @@ -65,23 +67,24 @@  -- | Set the files-of-interest - not usually necessary or advisable. --   The LSP client will keep this information up to date.-setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO ()+setFilesOfInterest :: IdeState -> HashMap NormalizedFilePath FileOfInterestStatus -> IO () setFilesOfInterest state files = modifyFilesOfInterest state (const files) -getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath)+getFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) getFilesOfInterestUntracked = do     OfInterestVar var <- getIdeGlobalAction     liftIO $ readVar var  -- | Modify the files-of-interest - not usually necessary or advisable. --   The LSP client will keep this information up to date.-modifyFilesOfInterest :: IdeState -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO ()+modifyFilesOfInterest+  :: IdeState+  -> (HashMap NormalizedFilePath FileOfInterestStatus -> HashMap NormalizedFilePath FileOfInterestStatus)+  -> IO () modifyFilesOfInterest state f = do     OfInterestVar var <- getIdeGlobalState state     files <- modifyVar var $ pure . dupe . f-    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)-    let das = map (\nfp -> mkDelayedAction "OfInterest" Debug (use GetSpanInfo nfp)) (HashSet.toList files)-    shakeRestart state das+    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashMap.toList files)  -- | Typecheck all the files of interest. --   Could be improved@@ -90,5 +93,12 @@     files <- getFilesOfInterest     ShakeExtras{progressUpdate} <- getShakeExtras     liftIO $ progressUpdate KickStarted-    void $ uses TypeCheck $ HashSet.toList files++    -- Update the exports map for the project+    results <-  uses TypeCheck $ HashMap.keys files+    ShakeExtras{exportsMap} <- getShakeExtras+    let modIfaces = mapMaybe (fmap (hm_iface . tmrModInfo)) results+        !exportsMap' = createExportsMap modIfaces+    liftIO $ modifyVar_ exportsMap $ evaluate . (exportsMap' <>)+     liftIO $ progressUpdate KickCompleted

@@ -2,6 +2,10 @@ -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.Core.PositionMapping   ( PositionMapping(..)+  , PositionResult(..)+  , lowerRange+  , upperRange+  , positionResultToMaybe   , fromCurrentPosition   , toCurrentPosition   , PositionDelta(..)@@ -21,17 +25,50 @@ import Language.Haskell.LSP.Types import Data.List +-- | Either an exact position, or the range of text that was substituted+data PositionResult a+  = PositionRange -- ^ Fields need to be non-strict otherwise bind is exponential+  { unsafeLowerRange :: a+  , unsafeUpperRange :: a }+  | PositionExact !a+  deriving (Eq,Ord,Show,Functor)++lowerRange :: PositionResult a -> a+lowerRange (PositionExact a) = a+lowerRange (PositionRange lower _) = lower++upperRange :: PositionResult a -> a+upperRange (PositionExact a) = a+upperRange (PositionRange _ upper) = upper++positionResultToMaybe :: PositionResult a -> Maybe a+positionResultToMaybe (PositionExact a) = Just a+positionResultToMaybe _ = Nothing++instance Applicative PositionResult where+  pure = PositionExact+  (PositionExact f) <*> a = fmap f a+  (PositionRange f g) <*> (PositionExact a) = PositionRange (f a) (g a)+  (PositionRange f g) <*> (PositionRange lower upper) = PositionRange (f lower) (g upper)++instance Monad PositionResult where+  (PositionExact a) >>= f = f a+  (PositionRange lower upper) >>= f = PositionRange lower' upper'+    where+      lower' = lowerRange $ f lower+      upper' = upperRange $ f upper+ -- The position delta is the difference between two versions data PositionDelta = PositionDelta-  { toDelta :: !(Position -> Maybe Position)-  , fromDelta :: !(Position -> Maybe Position)+  { toDelta :: !(Position -> PositionResult Position)+  , fromDelta :: !(Position -> PositionResult Position)   }  fromCurrentPosition :: PositionMapping -> Position -> Maybe Position-fromCurrentPosition (PositionMapping pm) = fromDelta pm+fromCurrentPosition (PositionMapping pm) = positionResultToMaybe . fromDelta pm  toCurrentPosition :: PositionMapping -> Position -> Maybe Position-toCurrentPosition (PositionMapping pm) = toDelta pm+toCurrentPosition (PositionMapping pm) = positionResultToMaybe . toDelta pm  -- A position mapping is the difference from the current version to -- a specific version@@ -59,7 +96,7 @@                 (from1 >=> from2)  idDelta :: PositionDelta-idDelta = PositionDelta Just Just+idDelta = PositionDelta pure pure  -- | Convert a set of changes into a delta from k  to k + 1 mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta@@ -76,16 +113,16 @@     } applyChange posMapping _ = posMapping -toCurrent :: Range -> T.Text -> Position -> Maybe Position-toCurrent (Range (Position startLine startColumn) (Position endLine endColumn)) t (Position line column)+toCurrent :: Range -> T.Text -> Position -> PositionResult Position+toCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column)     | line < startLine || line == startLine && column < startColumn =       -- Position is before the change and thereby unchanged.-      Just $ Position line column+      PositionExact $ Position line column     | line > endLine || line == endLine && column >= endColumn =       -- Position is after the change so increase line and column number       -- as necessary.-      Just $ Position (line + lineDiff) newColumn-    | otherwise = Nothing+      PositionExact $ Position newLine newColumn+    | otherwise = PositionRange start end     -- Position is in the region that was changed.     where         lineDiff = linesNew - linesOld@@ -94,20 +131,21 @@         newEndColumn           | linesNew == 0 = startColumn + T.length t           | otherwise = T.length $ T.takeWhileEnd (/= '\n') t-        newColumn+        !newColumn           | line == endLine = column + newEndColumn - endColumn           | otherwise = column+        !newLine = line + lineDiff -fromCurrent :: Range -> T.Text -> Position -> Maybe Position-fromCurrent (Range (Position startLine startColumn) (Position endLine endColumn)) t (Position line column)+fromCurrent :: Range -> T.Text -> Position -> PositionResult Position+fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column)     | line < startLine || line == startLine && column < startColumn =       -- Position is before the change and thereby unchanged-      Just $ Position line column+      PositionExact $ Position line column     | line > newEndLine || line == newEndLine && column >= newEndColumn =       -- Position is after the change so increase line and column number       -- as necessary.-      Just $ Position (line - lineDiff) newColumn-    | otherwise = Nothing+      PositionExact $ Position newLine newColumn+    | otherwise = PositionRange start end     -- Position is in the region that was changed.     where         lineDiff = linesNew - linesOld@@ -117,6 +155,7 @@         newEndColumn           | linesNew == 0 = startColumn + T.length t           | otherwise = T.length $ T.takeWhileEnd (/= '\n') t-        newColumn+        !newColumn           | line == newEndLine = column - (newEndColumn - endColumn)           | otherwise = column+        !newLine = line - lineDiff

@@ -37,8 +37,8 @@  -- | Given a file and some contents, apply any necessary preprocessors, --   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.-preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)-preprocessor filename mbContents = do+preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)+preprocessor env filename mbContents = do     -- Perform unlit     (isOnDisk, contents) <-         if isLiterate filename then do@@ -51,7 +51,7 @@             return (isOnDisk, contents)      -- Perform cpp-    dflags  <- ExceptT $ parsePragmasIntoDynFlags filename contents+    dflags  <- ExceptT $ parsePragmasIntoDynFlags env filename contents     (isOnDisk, contents, dflags) <-         if not $ xopt LangExt.Cpp dflags then             return (isOnDisk, contents, dflags)@@ -68,7 +68,7 @@                                   [] -> throw e                                   diags -> return $ Left diags                             )-            dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents+            dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents             return (False, contents, dflags)      -- Perform preprocessor@@ -76,7 +76,7 @@         return (contents, dflags)     else do         contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents-        dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents+        dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents         return (contents, dflags)   where     logAction :: IORef [CPPLog] -> LogAction@@ -108,8 +108,8 @@     -- informational log messages and attaches them to the initial log message.     go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]     go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc-    go acc (CPPLog sev span@(RealSrcSpan _) msg : logs) =-      let diag = CPPDiag (srcSpanToRange span) (toDSeverity sev) [msg]+    go acc (CPPLog sev (RealSrcSpan span) msg : logs) =+      let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg]        in go (diag : acc) logs     go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =       go (diag {cdMessage = msg : cdMessage diag} : diags) logs@@ -134,10 +134,11 @@ -- | This reads the pragma information directly from the provided buffer. parsePragmasIntoDynFlags     :: (ExceptionMonad m, HasDynFlags m, MonadIO m)-    => FilePath+    => HscEnv+    -> FilePath     -> SB.StringBuffer     -> m (Either [FileDiagnostic] DynFlags)-parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do+parsePragmasIntoDynFlags env fp contents = catchSrcErrors "pragmas" $ do     dflags0  <- getDynFlags     let opts = Hdr.getOptions dflags0 contents fp @@ -145,8 +146,8 @@     liftIO $ evaluate $ rnf opts      (dflags, _, _) <- parseDynamicFilePragma dflags0 opts-    return dflags-+    dflags' <- liftIO $ initializePlugins env dflags+    return $ disableWarningsAsErrors dflags'  -- | Run (unlit) literate haskell preprocessor on a file, or buffer if set runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

@@ -16,6 +16,7 @@ import           Development.IDE.Import.DependencyInformation import Development.IDE.GHC.Compat import Development.IDE.GHC.Util+import Development.IDE.Core.Shake (KnownTargets) import           Data.Hashable import           Data.Typeable import qualified Data.Set as S@@ -46,11 +47,24 @@ -- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure. type instance RuleResult GetDependencies = TransitiveDependencies +type instance RuleResult GetModuleGraph = DependencyInformation++data GetKnownTargets = GetKnownTargets+  deriving (Show, Generic, Eq, Ord)+instance Hashable GetKnownTargets+instance NFData   GetKnownTargets+instance Binary   GetKnownTargets+type instance RuleResult GetKnownTargets = KnownTargets+ -- | Contains the typechecked module and the OrigNameCache entry for -- that module. data TcModuleResult = TcModuleResult     { tmrModule     :: TypecheckedModule+    -- ^ warning, the ModIface in the tm_checked_module_info of the+    -- TypecheckedModule will always be Nothing, use the ModIface in the+    -- HomeModInfo instead     , tmrModInfo    :: HomeModInfo+    , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module?     } instance Show TcModuleResult where     show = show . pm_mod_summary . tm_parsed_module . tmrModule@@ -117,8 +131,20 @@ -- | Get a module interface details, either from an interface file or a typechecked module type instance RuleResult GetModIface = HiFileResult -type instance RuleResult IsFileOfInterest = Bool+data FileOfInterestStatus = OnDisk | Modified+  deriving (Eq, Show, Typeable, Generic)+instance Hashable FileOfInterestStatus+instance NFData   FileOfInterestStatus+instance Binary   FileOfInterestStatus +data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus+  deriving (Eq, Show, Typeable, Generic)+instance Hashable IsFileOfInterestResult+instance NFData   IsFileOfInterestResult+instance Binary   IsFileOfInterestResult++type instance RuleResult IsFileOfInterest = IsFileOfInterestResult+ -- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. -- without needing to parse the entire source type instance RuleResult GetModSummary = ModSummary@@ -144,6 +170,12 @@ instance Hashable GetDependencyInformation instance NFData   GetDependencyInformation instance Binary   GetDependencyInformation++data GetModuleGraph = GetModuleGraph+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetModuleGraph+instance NFData   GetModuleGraph+instance Binary   GetModuleGraph  data ReportImportCycles = ReportImportCycles     deriving (Eq, Show, Typeable, Generic)

@@ -58,6 +58,7 @@ import Data.List import qualified Data.Set                                 as Set import qualified Data.Text                                as T+import qualified Data.Text.Encoding                       as T import           Development.IDE.GHC.Error import           Development.Shake                        hiding (Diagnostic) import Development.IDE.Core.RuleTypes@@ -87,6 +88,9 @@ import FastString (FastString(uniq)) import qualified HeaderInfo as Hdr import Data.Time (UTCTime(..))+import Data.Hashable+import qualified Data.HashSet as HashSet+import qualified Data.HashMap.Strict as HM  -- | 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@@ -186,11 +190,18 @@       wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do         hsc <- hscEnv <$> use_ GhcSession f         pm <- use_ GetParsedModule f-        typeCheckRuleDefinition hsc pm DoGenerateInterfaceFiles+        source <- getSourceFileSource f+        typeCheckRuleDefinition hsc pm NotFOI (Just source)       _ <- MaybeT $ liftIO $ timeout 1 wait       ncu <- mkUpdater       liftIO $ loadHieFile ncu hie_f +getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString+getSourceFileSource nfp = do+    (_, msource) <- getFileContents nfp+    case msource of+        Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp)+        Just source -> pure $ T.encodeUtf8 source  getPackageHieFile :: ShakeExtras                   -> Module             -- ^ Package Module to load .hie file for@@ -231,6 +242,12 @@ priorityFilesOfInterest :: Priority priorityFilesOfInterest = Priority (-2) +-- | IMPORTANT FOR HLINT INTEGRATION:+-- We currently parse the module both with and without Opt_Haddock, and+-- return the one with Haddocks if it -- succeeds. However, this may not work+-- for hlint, and we might need to save the one without haddocks too.+-- See https://github.com/digital-asset/ghcide/pull/350#discussion_r370878197+-- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490 getParsedModuleRule :: Rules () getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do     sess <- use_ GhcSession file@@ -249,18 +266,28 @@         then             liftIO mainParse         else do-            let haddockParse = do-                    (_, (!diagsHaddock, _)) <--                        getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file modTime contents-                    return diagsHaddock+            let haddockParse = getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file modTime contents -            ((fingerPrint, (diags, res)), diagsHaddock) <--                -- parse twice, with and without Haddocks, concurrently-                -- we want warnings if parsing with Haddock fails-                -- but if we parse with Haddock we lose annotations-                liftIO $ concurrently mainParse haddockParse+            -- parse twice, with and without Haddocks, concurrently+            -- we cannot ignore Haddock parse errors because files of+            -- non-interest are always parsed with Haddocks+            -- If we can parse Haddocks, might as well use them+            --+            -- HLINT INTEGRATION: might need to save the other parsed module too+            ((fp,(diags,res)),(fph,(diagsh,resh))) <- liftIO $ concurrently mainParse haddockParse -            return (fingerPrint, (mergeParseErrorsHaddock diags diagsHaddock, res))+            -- Merge haddock and regular diagnostics so we can always report haddock+            -- parse errors+            let diagsM = mergeParseErrorsHaddock diags diagsh+            case resh of+              Just _+                | HaddockParse <- optHaddockParse opt+                -> pure (fph, (diagsM, resh))+              -- If we fail to parse haddocks, report the haddock diagnostics as well and+              -- return the non-haddock parse.+              -- This seems to be the correct behaviour because the Haddock flag is added+              -- by us and not the user, so our IDE shouldn't stop working because of it.+              _ -> pure (fp, (diagsM, res))   withOptHaddock :: HscEnv -> HscEnv@@ -279,7 +306,6 @@     fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x                  | otherwise = "Haddock: " <> x - getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> UTCTime -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule)) getParsedModuleDefinition packageState opt comp_pkgs file modTime contents = do     let fp = fromNormalizedFilePath file@@ -297,14 +323,23 @@ getLocatedImportsRule =     define $ \GetLocatedImports file -> do         ms <- use_ GetModSummaryWithoutTimestamps file+        targets <- useNoFile_ GetKnownTargets         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]         env_eq <- use_ GhcSession file-        let env = hscEnv env_eq+        let env = hscEnvWithImportPaths env_eq         let import_dirs = deps env_eq-        let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env+        let dflags = hsc_dflags env+            isImplicitCradle = isNothing $ envImportPaths env_eq+        dflags <- return $ if isImplicitCradle+                    then addRelativeImport file (moduleName $ ms_mod ms) dflags+                    else dflags         opt <- getIdeOptions+        let getTargetExists modName nfp+                | isImplicitCradle = getFileExists nfp+                | HM.member modName targets = getFileExists nfp+                | otherwise = return False         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do-            diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource+            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))@@ -442,7 +477,7 @@             | f `elem` fs = Just (imp, fs)           cycleErrorInFile _ _ = Nothing           toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic-            { _range = (_range :: Location -> Range) loc+            { _range = rng             , _severity = Just DsError             , _source = Just "Import cycle detection"             , _message = "Cyclic module dependency between " <> showCycle mods@@ -450,8 +485,8 @@             , _relatedInformation = Nothing             , _tags = Nothing             }-            where loc = srcSpanToLocation (getLoc imp)-                  fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)+            where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp)+                  fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp)           getModuleName file = do            ms <- use_ GetModSummaryWithoutTimestamps file            pure (moduleNameString . moduleName . ms_mod $ ms)@@ -498,13 +533,22 @@     hsc  <- hscEnv <$> use_ GhcSessionDeps file     -- do not generate interface files as this rule is called     -- for files of interest on every keystroke-    typeCheckRuleDefinition hsc pm SkipGenerationOfInterfaceFiles+    source <- getSourceFileSource file+    isFoi <- use_ IsFileOfInterest file+    typeCheckRuleDefinition hsc pm isFoi (Just source) -data GenerateInterfaceFiles-    = DoGenerateInterfaceFiles-    | SkipGenerationOfInterfaceFiles-    deriving (Show)+knownFilesRule :: Rules ()+knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do+  alwaysRerun+  fs <- knownTargets+  pure (BS.pack (show $ hash fs), unhashed fs) +getModuleGraphRule :: Rules ()+getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do+  fs <- toKnownFiles <$> useNoFile_ GetKnownTargets+  rawDepInfo <- rawDependencyInformation (HashSet.toList fs)+  pure $ processDependencyInformation rawDepInfo+ -- This is factored out so it can be directly called from the GetModIface -- rule. Directly calling this rule means that on the initial load we can -- garbage collect all the intermediate typechecked modules rather than@@ -512,19 +556,28 @@ typeCheckRuleDefinition     :: HscEnv     -> ParsedModule-    -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?+    -> IsFileOfInterestResult -- ^ Should generate .hi and .hie files ?+    -> Maybe BS.ByteString     -> Action (IdeResult TcModuleResult)-typeCheckRuleDefinition hsc pm generateArtifacts = do+typeCheckRuleDefinition hsc pm isFoi source = do   setPriority priorityTypeCheck   IdeOptions { optDefer = defer } <- getIdeOptions    addUsageDependencies $ liftIO $ do     res <- typecheckModule defer hsc pm     case res of-      (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do-        diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)-        diagsHi  <- generateAndWriteHiFile hsc tcm-        return (diags <> diagsHi <> diagsHie, Just tcm)+      (diags, Just (hsc,tcm)) -> do+        case isFoi of+          IsFOI Modified -> return (diags, Just tcm)+          _ -> do -- If the file is saved on disk, or is not a FOI, we write out ifaces+            diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm) (fromMaybe "" source)+            -- Don't save interface files for modules that compiled due to defering+            -- type errors, as we won't get proper diagnostics if we load these from+            -- disk+            diagsHi  <- if not $ tmrDeferedError tcm+                        then writeHiFile hsc tcm+                        else pure mempty+            return (diags <> diagsHi <> diagsHie, Just tcm)       (diags, res) ->         return (diags, snd <$> res)  where@@ -636,7 +689,7 @@             setupFinderCache (map hirModSummary ifaces)             mapM_ (uncurry loadDepModule) inLoadOrder -        res <- liftIO $ newHscEnvEq session' []+        res <- liftIO $ newHscEnvEq "" session' []         return ([], Just res)  where   unpack HiFileResult{..} bc = (hirModIface, bc)@@ -662,9 +715,7 @@ isHiFileStableRule = define $ \IsHiFileStable f -> do     ms <- use_ GetModSummaryWithoutTimestamps f     let hiFile = toNormalizedFilePath'-                $ case ms_hsc_src ms of-                    HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)-                    _ -> ml_hi_file $ ms_location ms+                $ ml_hi_file $ ms_location ms     mbHiVersion <- use  GetModificationTime_{missingFileDiagnostics=False} hiFile     modVersion  <- use_ GetModificationTime f     sourceModified <- case mbHiVersion of@@ -684,11 +735,12 @@ getModSummaryRule :: Rules () getModSummaryRule = do     defineEarlyCutoff $ \GetModSummary f -> do-        dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f+        session <- hscEnv <$> use_ GhcSession f+        let dflags = hsc_dflags session         (modTime, mFileContent) <- getFileContents f         let fp = fromNormalizedFilePath f         modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $-                getModSummaryFromImports fp modTime (textToStringBuffer <$> mFileContent)+                getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent)         case modS of             Right ms -> do                 let fingerPrint = hash (computeFingerprint f dflags ms, hashUTC modTime)@@ -726,18 +778,18 @@ getModIfaceRule :: Rules () getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do #if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)-    fileOfInterest <- use_ IsFileOfInterest f-    if fileOfInterest-        then do-            -- Never load from disk for files of interest-            tmr <- use TypeCheck f-            let !hiFile = extractHiFileResult tmr-            let fp = hiFileFingerPrint <$> hiFile-            return (fp, ([], hiFile))-        else do-            hiFile <- use GetModIfaceFromDisk f-            let fp = hiFileFingerPrint <$> hiFile-            return (fp, ([], hiFile))+  fileOfInterest <- use_ IsFileOfInterest f+  case fileOfInterest of+    IsFOI _ -> do+      -- Never load from disk for files of interest+      tmr <- use TypeCheck f+      let !hiFile = extractHiFileResult tmr+      let fp = hiFileFingerPrint <$> hiFile+      return (fp, ([], hiFile))+    NotFOI -> do+      hiFile <- use GetModIfaceFromDisk f+      let fp = hiFileFingerPrint <$> hiFile+      return (fp, ([], hiFile)) #else     tm <- use TypeCheck f     let !hiFile = extractHiFileResult tm@@ -765,9 +817,10 @@     case mb_pm of         Nothing -> return (diags, Nothing)         Just pm -> do+            source <- getSourceFileSource f             -- Invoke typechecking directly to update it without incurring a dependency             -- on the parsed module and the typecheck rules-            (diags', tmr) <- typeCheckRuleDefinition hsc pm DoGenerateInterfaceFiles+            (diags', tmr) <- typeCheckRuleDefinition hsc pm NotFOI (Just source)             -- Bang pattern is important to avoid leaking 'tmr'             let !res = extractHiFileResult tmr             return (diags <> diags', res)@@ -778,12 +831,6 @@     -- Bang patterns are important to force the inner fields     Just $! tmr_hiFileResult tmr -isFileOfInterestRule :: Rules ()-isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do-    filesOfInterest <- getFilesOfInterest-    let res = f `elem` filesOfInterest-    return (Just (if res then "1" else ""), ([], Just res))- -- | A rule that wires per-file rules together mainRule :: Rules () mainRule = do@@ -799,9 +846,10 @@     loadGhcSession     getModIfaceFromDiskRule     getModIfaceRule-    isFileOfInterestRule     getModSummaryRule     isHiFileStableRule+    getModuleGraphRule+    knownFilesRule  -- | Given the path to a module src file, this rule returns True if the -- corresponding `.hi` file is stable, that is, if it is newer

@@ -83,4 +83,4 @@ -- e.g., the ofInterestRule. runAction :: String -> IdeState -> Action a -> IO a runAction herald ide act =-  join $ shakeEnqueue ide (mkDelayedAction herald Logger.Info act)+  join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Info act)

@@ -24,6 +24,7 @@ module Development.IDE.Core.Shake(     IdeState, shakeExtras,     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,+    KnownTargets, toKnownFiles,     IdeRule, IdeResult,     GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),     shakeOpen, shakeShut,@@ -44,6 +45,7 @@     getIdeOptionsIO,     GlobalIdeOptions(..),     garbageCollect,+    knownTargets,     setPriority,     sendEvent,     ideLogger,@@ -66,31 +68,35 @@ import           Development.Shake.Database import           Development.Shake.Classes import           Development.Shake.Rule+import           Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap import qualified Data.Map.Strict as Map import qualified Data.ByteString.Char8 as BS import           Data.Dynamic import           Data.Maybe-import Data.Map.Strict (Map)+import           Data.Map.Strict (Map) import           Data.List.Extra (partition, takeEnd)+import           Data.HashSet (HashSet) import qualified Data.Set as Set import qualified Data.Text as T import Data.Tuple.Extra import Data.Unique import Development.IDE.Core.Debouncer-import Development.IDE.GHC.Compat ( NameCacheUpdater(..), upNameCache )+import Development.IDE.GHC.Compat (ModuleName, NameCacheUpdater(..), upNameCache )+import Development.IDE.GHC.Orphans () import Development.IDE.Core.PositionMapping+import Development.IDE.Types.Action import Development.IDE.Types.Logger hiding (Priority) import qualified Development.IDE.Types.Logger as Logger import Language.Haskell.LSP.Diagnostics import qualified Data.SortedList as SL import           Development.IDE.Types.Diagnostics+import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options import           Control.Concurrent.Async import           Control.Concurrent.Extra-import           Control.Concurrent.STM.TQueue (flushTQueue, writeTQueue, readTQueue, newTQueue, TQueue)-import           Control.Concurrent.STM (readTVar, writeTVar, newTVarIO, TVar, atomically)+import           Control.Concurrent.STM (readTVar, writeTVar, newTVarIO, atomically) import           Control.DeepSeq import           Control.Exception.Extra import           System.Time.Extra@@ -105,18 +111,19 @@ import           GHC.Generics import           System.IO.Unsafe import Language.Haskell.LSP.Types-import Data.Foldable (traverse_) import qualified Control.Monad.STM as STM import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Maybe import Data.Traversable+import Data.Hashable  import Data.IORef import NameCache import UniqSupply import PrelInfo import Data.Int (Int64)+import qualified Data.HashSet as HSet  -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras@@ -148,9 +155,21 @@     ,withIndefiniteProgress :: WithIndefiniteProgressFunc     -- ^ Same as 'withProgress', but for processes that do not report the percentage complete     ,restartShakeSession :: [DelayedAction ()] -> IO ()-    , ideNc :: IORef NameCache+    ,ideNc :: IORef NameCache+    -- | A mapping of module name to known target (or candidate targets, if missing)+    ,knownTargetsVar :: Var (Hashed KnownTargets)+    -- | A mapping of exported identifiers for local modules. Updated on kick+    ,exportsMap :: Var ExportsMap+    -- | A work queue for actions added via 'runInShakeSession'+    ,actionQueue :: ActionQueue     } +-- | A mapping of module name to known files+type KnownTargets = HashMap ModuleName [NormalizedFilePath]++toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath+toKnownFiles = HSet.fromList . concat . HMap.elems+ type WithProgressFunc = forall a.     T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a type WithIndefiniteProgressFunc = forall a.@@ -288,11 +307,9 @@  -- | A live Shake session with the ability to enqueue Actions for running. --   Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database.-data ShakeSession = ShakeSession-  { cancelShakeSession :: !(IO [DelayedActionInternal])-    -- ^ Closes the Shake session and returns the pending user actions-  , runInShakeSession  :: !(forall a . DelayedAction a -> IO (IO a))-    -- ^ Enqueue an action in the Shake session.+newtype ShakeSession = ShakeSession+  { cancelShakeSession :: IO ()+    -- ^ Closes the Shake session   }  -- | A Shake database plus persistent store. Can be thought of as storing@@ -358,6 +375,12 @@             -- (which would be an internal error).             evaluate (r `seqValue` Just r) +-- | Get all the files in the project+knownTargets :: Action (Hashed KnownTargets)+knownTargets = do+  ShakeExtras{knownTargetsVar} <- getShakeExtras+  liftIO $ readVar knownTargetsVar+ -- | Seq the result stored in the Shake value. This only -- evaluates the value to WHNF not NF. We take care of the latter -- elsewhere and doing it twice is expensive.@@ -393,6 +416,7 @@         hiddenDiagnostics <- newVar mempty         publishedDiagnostics <- newVar mempty         positionMapping <- newVar HMap.empty+        knownTargetsVar <- newVar $ hashed HMap.empty         let restartShakeSession = shakeRestart ideState         let session = shakeSession         mostRecentProgressEvent <- newTVarIO KickCompleted@@ -400,14 +424,17 @@         progressAsync <- async $             when reportProgress $                 progressThread mostRecentProgressEvent inProgress+        exportsMap <- newVar mempty +        actionQueue <- newQueue+         pure (ShakeExtras{..}, cancel progressAsync)     (shakeDbM, shakeClose) <-         shakeOpenDatabase             opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts }             rules     shakeDb <- shakeDbM-    initSession <- newSession shakeExtras shakeDb [] []+    initSession <- newSession shakeExtras shakeDb []     shakeSession <- newMVar initSession     let ideState = IdeState{..}     return ideState@@ -511,33 +538,21 @@   mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a-mkDelayedAction = DelayedAction--data DelayedAction a = DelayedAction-  { actionName :: String -- ^ Name we use for debugging-  , actionPriority :: Logger.Priority -- ^ Priority with which to log the action-  , getAction :: Action a -- ^ The payload-  }--type DelayedActionInternal = DelayedAction ()--instance Show (DelayedAction a) where-    show d = "DelayedAction: " ++ actionName d+mkDelayedAction = DelayedAction Nothing  -- | These actions are run asynchronously after the current action is -- finished running. For example, to trigger a key build after a rule -- has already finished as is the case with useWithStaleFast delayedAction :: DelayedAction a -> IdeAction (IO a) delayedAction a = do-  sq <- asks session-  liftIO $ shakeEnqueueSession sq a+  extras <- ask+  liftIO $ shakeEnqueue extras a  -- | Restart the current 'ShakeSession' with the given system actions.---   Any computation running in the current session will be aborted,---   but user actions (added via 'shakeEnqueue') will be requeued.---   Progress is reported only on the system actions.-shakeRestart :: IdeState -> [DelayedAction a] -> IO ()-shakeRestart IdeState{..} systemActs =+--   Any actions running in the current session will be aborted,+--   but actions added via 'shakeEnqueue' will be requeued.+shakeRestart :: IdeState -> [DelayedAction ()] -> IO ()+shakeRestart IdeState{..} acts =     withMVar'         shakeSession         (\runner -> do@@ -554,86 +569,81 @@         -- It is crucial to be masked here, otherwise we can get killed         -- between spawning the new thread and updating shakeSession.         -- See https://github.com/digital-asset/ghcide/issues/79-        (\cancelled -> do-          (_b, dai) <- unzip <$> mapM instantiateDelayedAction systemActs-          (,()) <$> newSession shakeExtras shakeDb dai cancelled)+        (\() -> do+          (,()) <$> newSession shakeExtras shakeDb acts)  -- | Enqueue an action in the existing 'ShakeSession'. --   Returns a computation to block until the action is run, propagating exceptions. --   Assumes a 'ShakeSession' is available. -- --   Appropriate for user actions other than edits.-shakeEnqueue :: IdeState -> DelayedAction a -> IO (IO a)-shakeEnqueue IdeState{shakeSession} act = shakeEnqueueSession shakeSession act--shakeEnqueueSession :: MVar ShakeSession -> DelayedAction a -> IO (IO a)-shakeEnqueueSession sess act = withMVar sess $ \s -> runInShakeSession s act+shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)+shakeEnqueue ShakeExtras{actionQueue, logger} act = do+    (b, dai) <- instantiateDelayedAction act+    atomically $ pushQueue dai actionQueue+    let wait' b =+            waitBarrier b `catches`+              [ Handler(\BlockedIndefinitelyOnMVar ->+                    fail $ "internal bug: forever blocked on MVar for " <>+                            actionName act)+              , Handler (\e@AsyncCancelled -> do+                  logPriority logger Debug $ T.pack $ actionName act <> " was cancelled" --- | Set up a new 'ShakeSession' with a set of initial system and user actions--- Will crash if there is an existing 'ShakeSession' running.--- Progress is reported only on the system actions.--- Only user actions will get re-enqueued-newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> [DelayedActionInternal] -> IO ShakeSession-newSession ShakeExtras{..} shakeDb systemActs userActs = do-    -- A work queue for actions added via 'runInShakeSession'-    actionQueue :: TQueue DelayedActionInternal <- atomically $ do-        q <- newTQueue-        traverse_ (writeTQueue q) userActs-        return q-    actionInProgress :: TVar (Maybe DelayedActionInternal) <- newTVarIO Nothing+                  atomically $ abortQueue dai actionQueue+                  throw e)+              ]+    return (wait' b >>= either throwIO return) +-- | Set up a new 'ShakeSession' with a set of initial actions+--   Will crash if there is an existing 'ShakeSession' running.+newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> IO ShakeSession+newSession ShakeExtras{..} shakeDb acts = do+    reenqueued <- atomically $ peekInProgress actionQueue     let         -- A daemon-like action used to inject additional work         -- Runs actions from the work queue sequentially-        pumpAction =-            forever $ do-                join $ liftIO $ atomically $ do-                    act <- readTQueue actionQueue-                    writeTVar actionInProgress $ Just act-                    return (logDelayedAction logger act)-                liftIO $ atomically $ writeTVar actionInProgress Nothing+        pumpActionThread = do+            d <- liftIO $ atomically $ popQueue actionQueue+            void $ parallel [run d, pumpActionThread] +        run d  = do+            start <- liftIO offsetTime+            getAction d+            liftIO $ atomically $ doneQueue d actionQueue+            runTime <- liftIO start+            liftIO $ logPriority logger (actionPriority d) $ T.pack $+                "finish: " ++ actionName d ++ " (took " ++ showDuration runTime ++ ")"+         workRun restore = do-          let systemActs' = pumpAction : map getAction systemActs+          let acts' = pumpActionThread : map getAction (reenqueued ++ acts)           res <- try @SomeException-                 (restore $ shakeRunDatabase shakeDb systemActs')+                 (restore $ shakeRunDatabase shakeDb acts')           let res' = case res of                       Left e -> "exception: " <> displayException e                       Right _ -> "completed"-              -- Wrap up in a thread to avoid calling interruptible-              -- operations inside the masked section+           let wrapUp = logDebug logger $ T.pack $ "Finishing build session(" ++ res' ++ ")"           return wrapUp      -- Do the work in a background thread     workThread <- asyncWithUnmask workRun -    -- run the wrap up unmasked+    -- run the wrap up in a separate thread since it contains interruptible+    -- commands (and we are not using uninterruptible mask)     _ <- async $ join $ wait workThread --    -- 'runInShakeSession' is used to append work in this Shake session-    --  The session stays open until 'cancelShakeSession' is called-    let runInShakeSession :: forall a . DelayedAction a -> IO (IO a)-        runInShakeSession da = do-          (b, dai) <- instantiateDelayedAction da-          atomically $ writeTQueue actionQueue dai-          return (waitBarrier b >>= either throwIO return)-     --  Cancelling is required to flush the Shake database when either     --  the filesystem or the Ghc configuration have changed-        cancelShakeSession :: IO [DelayedActionInternal]-        cancelShakeSession = do-            cancel workThread-            atomically $ do-                q <- flushTQueue actionQueue-                c <- readTVar actionInProgress-                return (maybe [] pure c ++ q)+    let cancelShakeSession :: IO ()+        cancelShakeSession = cancel workThread      pure (ShakeSession{..}) -instantiateDelayedAction :: DelayedAction a -> IO (Barrier (Either SomeException a), DelayedActionInternal)-instantiateDelayedAction (DelayedAction s p a) = do+instantiateDelayedAction+    :: DelayedAction a+    -> IO (Barrier (Either SomeException a), DelayedActionInternal)+instantiateDelayedAction (DelayedAction _ s p a) = do+  u <- newUnique   b <- newBarrier   let a' = do         -- work gets reenqueued when the Shake session is restarted@@ -642,17 +652,10 @@         alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b         unless alreadyDone $ do           x <- actionCatch @SomeException (Right <$> a) (pure . Left)-          liftIO $ signalBarrier b x-  let d = DelayedAction s p a'-  return (b, d)--logDelayedAction :: Logger -> DelayedActionInternal -> Action ()-logDelayedAction l d  = do-    start <- liftIO offsetTime-    getAction d-    runTime <- liftIO start-    liftIO $ logPriority l (actionPriority d) $ T.pack $-        "finish: " ++ actionName d ++ " (took " ++ showDuration runTime ++ ")"+          liftIO $ do+            signalBarrier b x+      d' = DelayedAction (Just u) s p a'+  return (b, d')  getDiagnostics :: IdeState -> IO [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do@@ -685,23 +688,30 @@                    mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $                    HMap.toList newState            modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings++-- | Define a new Rule without early cutoff define     :: IdeRule k v     => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v +-- | Request a Rule result if available use :: IdeRule k v     => k -> NormalizedFilePath -> Action (Maybe v) use key file = head <$> uses key [file] +-- | Request a Rule result, it not available return the last computed result, if any, which may be stale useWithStale :: IdeRule k v     => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) useWithStale key file = head <$> usesWithStale key [file] +-- | Request a Rule result, it not available return the last computed result which may be stale.+--   Errors out if none available. useWithStale_ :: IdeRule k v     => k -> NormalizedFilePath -> Action (v, PositionMapping) useWithStale_ key file = head <$> usesWithStale_ key [file] +-- | Plural version of 'useWithStale_' usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)] usesWithStale_ key files = do     res <- usesWithStale key files@@ -818,7 +828,7 @@ type instance RuleResult (Q k) = A (RuleResult k)  --- | Return up2date results. Stale results will be ignored.+-- | Plural version of 'use' uses :: IdeRule k v     => k -> [NormalizedFilePath] -> Action [Maybe v] uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)@@ -830,7 +840,7 @@     values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)     zipWithM lastValue files values -+-- | Define a new Rule with early cutoff defineEarlyCutoff     :: IdeRule k v     => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))

@@ -23,6 +23,7 @@     dontWriteHieFiles, #if !MIN_GHC_API_VERSION(8,8,0)     ml_hie_file,+    addBootSuffixLocnOut, #endif     hPutStringBuffer,     includePathsGlobal,@@ -30,6 +31,7 @@     addIncludePathsQuote,     getModuleHash,     getPackageName,+    setUpTypedHoles,     pattern DerivD,     pattern ForD,     pattern InstD,@@ -42,17 +44,20 @@     pattern IEThingWith,     pattern VarPat,     pattern PatSynBind,+    pattern ValBinds,+    pattern HsValBinds,     GHC.ModLocation,     Module.addBootSuffix,     pattern ModLocation,     getConArgs,-     HasSrcSpan,     getLoc,-     upNameCache,+    disableWarningsAsErrors,      module GHC,+    initializePlugins,+    applyPluginsParsedResultAction, #if MIN_GHC_API_VERSION(8,6,0)  #if MIN_GHC_API_VERSION(8,8,0)@@ -92,6 +97,8 @@       ModLocation,       HasSrcSpan,       PatSynBind,+      ValBinds,+      HsValBinds,       lookupName,       getLoc #if MIN_GHC_API_VERSION(8,6,0)@@ -100,12 +107,15 @@     ) import qualified HeaderInfo as Hdr import Avail+import Data.List (foldl') import ErrUtils (ErrorMessages) import FastString (FastString)  #if MIN_GHC_API_VERSION(8,6,0) import Development.IDE.GHC.HieAst (mkHieFile) import Development.IDE.GHC.HieBin+import qualified DynamicLoading+import Plugins (Plugin(parsedResultAction), withPlugins)  #if MIN_GHC_API_VERSION(8,8,0) import HieUtils@@ -119,9 +129,11 @@ #endif  #if !MIN_GHC_API_VERSION(8,8,0)+import qualified EnumSet  #if MIN_GHC_API_VERSION(8,6,0) import GhcPlugins (srcErrorMessages)+import Data.List (isSuffixOf) #else import System.IO.Error import IfaceEnv@@ -153,7 +165,9 @@  #if !MIN_GHC_API_VERSION(8,8,0) ml_hie_file :: GHC.ModLocation -> FilePath-ml_hie_file ml = ml_hi_file ml -<.> ".hie"+ml_hie_file ml+  | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot"+  | otherwise  = ml_hi_file ml -<.> ".hie" #endif  #endif@@ -284,6 +298,22 @@     GHC.PatSynBind x #endif +pattern ValBinds :: LHsBinds p -> [LSig p] -> HsValBindsLR p p+pattern ValBinds b s <-+#if MIN_GHC_API_VERSION(8,6,0)+    GHC.ValBinds _ b s+#else+    GHC.ValBindsIn b s+#endif++pattern HsValBinds :: HsValBindsLR p p -> HsLocalBindsLR p p+pattern HsValBinds b <-+#if MIN_GHC_API_VERSION(8,6,0)+    GHC.HsValBinds _ b+#else+    GHC.HsValBinds b+#endif+ setHieDir :: FilePath -> DynFlags -> DynFlags setHieDir _f d = #if MIN_GHC_API_VERSION(8,8,0)@@ -300,6 +330,31 @@     d #endif +setUpTypedHoles ::DynFlags -> DynFlags+#if MIN_GHC_API_VERSION(8,6,0)+setUpTypedHoles df+  = flip gopt_unset Opt_AbstractRefHoleFits    -- too spammy+#if MIN_GHC_API_VERSION(8,8,0)+  $ flip gopt_unset Opt_ShowDocsOfHoleFits     -- not used+#endif+  $ flip gopt_unset Opt_ShowMatchesOfHoleFits  -- nice but broken (forgets module qualifiers)+  $ flip gopt_unset Opt_ShowProvOfHoleFits     -- not used+  $ flip gopt_unset Opt_ShowTypeAppOfHoleFits  -- not used+  $ flip gopt_unset Opt_ShowTypeAppVarsOfHoleFits -- not used+  $ flip gopt_unset Opt_ShowTypeOfHoleFits     -- massively simplifies parsing+  $ flip gopt_set   Opt_SortBySubsumHoleFits   -- very nice and fast enough in most cases+  $ flip gopt_unset Opt_SortValidHoleFits+  $ flip gopt_unset Opt_UnclutterValidHoleFits+  $ df+  { refLevelHoleFits = Just 1   -- becomes slow at higher levels+  , maxRefHoleFits   = Just 10  -- quantity does not impact speed+  , maxValidHoleFits = Nothing  -- quantity does not impact speed+  }+#else+setUpTypedHoles = id+#endif++ nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] nameListFromAvails as =   map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)@@ -380,6 +435,14 @@ getHeaderImports a b c d =     catch (Right <$> Hdr.getImports a b c d)           (return . Left . srcErrorMessages)++-- | Add the @-boot@ suffix to all output file paths associated with the+-- module, not including the input file itself+addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation+addBootSuffixLocnOut locn+  = locn { ml_hi_file  = Module.addBootSuffix (ml_hi_file locn)+         , ml_obj_file = Module.addBootSuffix (ml_obj_file locn)+         } #endif  getModuleHash :: ModIface -> Fingerprint@@ -398,3 +461,37 @@  getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))++disableWarningsAsErrors :: DynFlags -> DynFlags+disableWarningsAsErrors df =+    flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..]++#if !MIN_GHC_API_VERSION(8,8,0)+wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_unset_fatal dfs f+    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }+#endif++#if MIN_GHC_API_VERSION(8,6,0)+initializePlugins :: HscEnv -> DynFlags -> IO DynFlags+initializePlugins env dflags = do+    DynamicLoading.initializePlugins env dflags++applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource+applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do+  -- Apply parsedResultAction of plugins+  let applyPluginAction p opts = parsedResultAction p opts ms+  fmap hpm_module $ +    runHsc env $ withPlugins dflags applyPluginAction +      (HsParsedModule parsed [] hpm_annotations)++#else+initializePlugins :: HscEnv -> DynFlags -> IO DynFlags+initializePlugins _env dflags = do+    return dflags++applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource+applyPluginsParsedResultAction _env _dflags _ms _hpm_annotations parsed =+    return parsed+#endif+

@@ -13,6 +13,7 @@   -- * utilities working with spans   , srcSpanToLocation   , srcSpanToRange+  , realSrcSpanToRange   , srcSpanToFilename   , zeroSpan   , realSpan@@ -25,6 +26,7 @@  import                     Development.IDE.Types.Diagnostics as D import qualified           Data.Text as T+import Data.Maybe import Development.IDE.Types.Location import Development.IDE.GHC.Orphans() import qualified FastString as FS@@ -41,9 +43,9 @@   diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic-diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)+diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,)     Diagnostic-    { _range    = srcSpanToRange loc+    { _range    = fromMaybe noRange $ srcSpanToRange loc     , _severity = Just sev     , _source   = Just diagSource -- not shown in the IDE, but useful for ghcide developers     , _message  = msg@@ -64,9 +66,9 @@ diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList  -- | Convert a GHC SrcSpan to a DAML compiler Range-srcSpanToRange :: SrcSpan -> Range-srcSpanToRange (UnhelpfulSpan _)  = noRange-srcSpanToRange (RealSrcSpan real) = realSrcSpanToRange real+srcSpanToRange :: SrcSpan -> Maybe Range+srcSpanToRange (UnhelpfulSpan _)  = Nothing+srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real  realSrcSpanToRange :: RealSrcSpan -> Range realSrcSpanToRange real =@@ -75,18 +77,21 @@  -- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones) -- FIXME This may not be an _absolute_ file name, needs fixing.-srcSpanToFilename :: SrcSpan -> FilePath-srcSpanToFilename (UnhelpfulSpan fs) = FS.unpackFS fs-srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real+srcSpanToFilename :: SrcSpan -> Maybe FilePath+srcSpanToFilename (UnhelpfulSpan _) = Nothing+srcSpanToFilename (RealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real -srcSpanToLocation :: SrcSpan -> Location-srcSpanToLocation src =+srcSpanToLocation :: SrcSpan -> Maybe Location+srcSpanToLocation src = do+  fs <- srcSpanToFilename src+  rng <- srcSpanToRange src   -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code-  Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src)+  pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng  isInsideSrcSpan :: Position -> SrcSpan -> Bool-p `isInsideSrcSpan` r = sp <= p && p <= ep-  where Range sp ep = srcSpanToRange r+p `isInsideSrcSpan` r = case srcSpanToRange r of+  Just (Range sp ep) -> sp <= p && p <= ep+  _ -> False  -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing).

@@ -75,3 +75,8 @@ deriving instance Show SourceModified instance NFData SourceModified where     rnf = rwhnf++instance Show ModuleName where+    show = moduleNameString+instance Hashable ModuleName where+    hashWithSalt salt = hashWithSalt salt . show

@@ -6,6 +6,8 @@     -- * HcsEnv and environment     HscEnvEq,     hscEnv, newHscEnvEq,+    hscEnvWithImportPaths,+    envImportPaths,     modifyDynFlags,     evalGhcEnv,     runGhcEnv,@@ -28,7 +30,8 @@     hDuplicateTo',     setHieDir,     dontWriteHieFiles,-    ) where+    disableWarningsAsErrors,+    newHscEnvEqPreserveImportPaths) where  import Control.Concurrent import Data.List.Extra@@ -169,36 +172,58 @@  -- | An 'HscEnv' with equality. Two values are considered equal --   if they are created with the same call to 'newHscEnvEq'.-data HscEnvEq-    = HscEnvEq !Unique !HscEnv-               [(InstalledUnitId, DynFlags)] -- In memory components for this HscEnv+data HscEnvEq = HscEnvEq+    { envUnique :: !Unique+    , hscEnv :: !HscEnv+    , deps   :: [(InstalledUnitId, DynFlags)]+               -- ^ In memory components for this HscEnv                -- This is only used at the moment for the import dirs in                -- the DynFlags---- | Unwrap an 'HsEnvEq'.-hscEnv :: HscEnvEq -> HscEnv-hscEnv = either error id . hscEnv'+    , envImportPaths :: Maybe [String]+        -- ^ If Just, import dirs originally configured in this env+        --   If Nothing, the env import dirs are unaltered+    } -hscEnv' :: HscEnvEq -> Either String HscEnv-hscEnv' (HscEnvEq _ x _) = Right x-deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]-deps (HscEnvEq _ _ u) = u+-- | Wrap an 'HscEnv' into an 'HscEnvEq'.+newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq+newHscEnvEq cradlePath hscEnv0 deps = do+    envUnique <- newUnique+    let envImportPaths = Just $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)+        relativeToCradle = (takeDirectory cradlePath </>)+        hscEnv = removeImportPaths hscEnv0+    return HscEnvEq{..}  -- | Wrap an 'HscEnv' into an 'HscEnvEq'.-newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq-newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids+newHscEnvEqPreserveImportPaths+    :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq+newHscEnvEqPreserveImportPaths hscEnv deps = do+    let envImportPaths = Nothing+    envUnique <- newUnique+    return HscEnvEq{..} +-- | Unwrap the 'HscEnv' with the original import paths.+--   Used only for locating imports+hscEnvWithImportPaths :: HscEnvEq -> HscEnv+hscEnvWithImportPaths HscEnvEq{..}+    | Just imps <- envImportPaths+    = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = imps}}+    | otherwise+    = hscEnv++removeImportPaths :: HscEnv -> HscEnv+removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}}+ instance Show HscEnvEq where-  show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)+  show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique)  instance Eq HscEnvEq where-  HscEnvEq a _ _ == HscEnvEq b _ _ = a == b+  a == b = envUnique a == envUnique b  instance NFData HscEnvEq where-  rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()+  rnf (HscEnvEq a b c d) = rnf (hashUnique a) `seq` b `seq` c `seq` rnf d  instance Hashable HscEnvEq where-  hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a+  hashWithSalt s = hashWithSalt s . envUnique  -- Fake instance needed to persuade Shake to accept this type as a key. -- No harm done as ghcide never persists these keys currently

@@ -21,6 +21,7 @@   , reachableModules   , processDependencyInformation   , transitiveDeps+  , reverseDependencies    , BootIdMap   , insertBootId@@ -142,6 +143,8 @@     , depModuleDeps :: !(FilePathIdMap FilePathIdSet)     -- ^ For a non-error node, this contains the set of module immediate dependencies     -- 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@@ -222,6 +225,7 @@   DependencyInformation     { depErrorNodes = IntMap.fromList errorNodes     , depModuleDeps = moduleDeps+    , depReverseModuleDeps = reverseModuleDeps     , depModuleNames = IntMap.fromList $ coerce moduleNames     , depPkgDeps = pkgDependencies rawDepInfo     , depPathIdMap = rawPathIdMap@@ -232,16 +236,21 @@         moduleNames :: [(FilePathId, ModuleName)]         moduleNames =           [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]-        successEdges :: [(FilePathId, FilePathId, [FilePathId])]+        successEdges :: [(FilePathId, [FilePathId])]         successEdges =             map-              (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports))+              (bimap FilePathId (map snd))               successNodes         moduleDeps =           IntMap.fromList $-          map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))+          map (\(FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))             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 + -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows: -- 1. Mark each node that is part of an import cycle as an error node. -- 2. Mark each node that has a parse error as an error node.@@ -306,6 +315,18 @@ partitionSCC (AcyclicSCC x:rest) = first (x:)   $ partitionSCC rest partitionSCC []                  = ([], []) +-- | Transitive reverse dependencies of a file+reverseDependencies :: NormalizedFilePath -> DependencyInformation -> [NormalizedFilePath]+reverseDependencies file DependencyInformation{..} =+  let FilePathId cur_id = pathToId depPathIdMap file+  in map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty))+  where+    go :: Int -> IntSet -> IntSet+    go k i =+      let outwards = fromMaybe IntSet.empty (IntMap.lookup k depReverseModuleDeps  )+          res = IntSet.union i outwards+          new = IntSet.difference i outwards+      in IntSet.foldr go res new  transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies transitiveDeps DependencyInformation{..} file = do

@@ -66,7 +66,7 @@ locateModuleFile :: MonadIO m              => [[FilePath]]              -> [String]-             -> (NormalizedFilePath -> m Bool)+             -> (ModuleName -> NormalizedFilePath -> m Bool)              -> Bool              -> ModuleName              -> m (Maybe NormalizedFilePath)@@ -74,7 +74,7 @@   let candidates import_dirs =         [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)            | prefix <- import_dirs , ext <- exts]-  findM doesExist (concatMap candidates import_dirss)+  findM (doesExist modName) (concatMap candidates import_dirss)   where     maybeBoot ext       | isSource = ext ++ "-boot"@@ -92,12 +92,12 @@ locateModule     :: MonadIO m     => DynFlags-    -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in-    -> [String]-    -> (NormalizedFilePath -> m Bool)-    -> Located ModuleName-    -> Maybe FastString-    -> Bool+    -> [(M.InstalledUnitId, DynFlags)] -- ^ Import directories+    -> [String]                        -- ^ File extensions+    -> (ModuleName -> NormalizedFilePath -> m Bool)  -- ^ does file exist predicate+    -> Located ModuleName              -- ^ Moudle name+    -> Maybe FastString                -- ^ Package name+    -> Bool                            -- ^ Is boot module     -> m (Either [FileDiagnostic] Import) locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do   case mbPkgName of

@@ -46,7 +46,7 @@     -> (InitializeRequest -> Either T.Text config)     -> (DidChangeConfigurationNotification -> Either T.Text config)     -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities-        -> WithProgressFunc -> WithIndefiniteProgressFunc -> IO IdeState)+        -> WithProgressFunc -> WithIndefiniteProgressFunc -> IO (Maybe config) -> Maybe FilePath -> IO IdeState)     -> IO () runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do     -- Move stdout to another file descriptor and duplicate stderr@@ -71,6 +71,8 @@     -- 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.     clientMsgBarrier <- newBarrier+    -- Forcefully exit+    let exit = signalBarrier clientMsgBarrier ()      -- The set of requests ids that we have received but not finished processing     pendingRequests <- newTVarIO Set.empty@@ -107,7 +109,8 @@             setHandlersOutline <>             userHandlers <>             setHandlersNotifications <> -- absolutely critical, join them with user notifications-            cancelHandler cancelRequest+            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@@ -115,7 +118,7 @@     let initializeCallbacks = LSP.InitializeCallbacks             { LSP.onInitialConfiguration = onInitialConfig             , LSP.onConfigurationChange = onConfigChange-            , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan+            , LSP.onStartup = handleInit exit clearReqId waitForCancel clientMsgChan             }      void $ waitAnyCancel =<< traverse async@@ -133,10 +136,12 @@         handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do              ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities-                               withProgress withIndefiniteProgress+                               withProgress withIndefiniteProgress config rootPath              _ <- flip forkFinally (const exitClientMsg) $ 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} act -> do                         catch (act lspFuncs ide _params) $ \(e :: SomeException) ->@@ -144,12 +149,12 @@                                 "Unexpected exception on notification, please report!\n" ++                                 "Message: " ++ show x ++ "\n" ++                                 "Exception: " ++ show e-                    Response x@RequestMessage{_id, _params} wrap act ->+                    Response x@RequestMessage{_id, _params} wrap act -> void $ async $                         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, _params} wrap wrapNewReq act ->+                    ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act -> void $ async $                         checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $                             \(res, newReq) -> do                                 case res of@@ -217,6 +222,9 @@             whenJust (LSP.cancelNotificationHandler x) ($ msg)     } +exitHandler :: IO () -> PartialHandlers c+exitHandler exit = PartialHandlers $ \_ x -> return x+    {LSP.exitNotificationHandler = Just $ const exit}  -- | 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)

@@ -15,16 +15,19 @@  import           Development.IDE.Core.IdeConfiguration import           Development.IDE.Core.Service+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           Data.Foldable                    as F import           Data.Maybe+import qualified Data.HashMap.Strict              as M import qualified Data.HashSet                     as S import qualified Data.Text                        as Text -import           Development.IDE.Core.FileStore   (setSomethingModified, setFileModified)+import           Development.IDE.Core.FileStore   (setSomethingModified, setFileModified, typecheckParents) import           Development.IDE.Core.FileExists  (modifyFileExists) import           Development.IDE.Core.OfInterest @@ -38,25 +41,34 @@         \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do             updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List [])             whenUriFile _uri $ \file -> do-                modifyFilesOfInterest ide (S.insert file)-                setFileModified ide file+                -- 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 -> setFileModified ide file+            whenUriFile _uri $ \file -> do+              modifyFilesOfInterest ide (M.insert file Modified)+              setFileModified ide False file             logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri      ,LSP.didSaveTextDocumentNotificationHandler = withNotification (LSP.didSaveTextDocumentNotificationHandler x) $         \_ ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do-            whenUriFile _uri $ \file -> setFileModified ide file+            whenUriFile _uri $ \file -> do+                modifyFilesOfInterest ide (M.insert file OnDisk)+                setFileModified ide True file             logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri      ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $         \_ ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do             whenUriFile _uri $ \file -> do-                modifyFilesOfInterest ide (S.delete file)+                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

@@ -22,7 +22,7 @@ import           Development.IDE.Core.Rules import           Development.IDE.Core.Shake import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Error      ( srcSpanToRange )+import           Development.IDE.GHC.Error      ( realSrcSpanToRange ) import           Development.IDE.LSP.Server import           Development.IDE.Types.Location import           Outputable                     ( Outputable@@ -46,12 +46,14 @@         Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }           -> let                declSymbols  = mapMaybe documentSymbolForDecl hsmodDecls-               moduleSymbol = hsmodName <&> \(L l m) ->-                 (defDocumentSymbol l :: DocumentSymbol)-                   { _name  = pprText m-                   , _kind  = SkFile-                   , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0-                   }+               moduleSymbol = hsmodName >>= \case+                 (L (RealSrcSpan l) m) -> Just $+                   (defDocumentSymbol l :: DocumentSymbol)+                     { _name  = pprText m+                     , _kind  = SkFile+                     , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0+                     }+                 _ -> Nothing                importSymbols = maybe [] pure $                   documentSymbolForImportSummary                     (mapMaybe documentSymbolForImport hsmodImports)@@ -68,7 +70,7 @@     Nothing -> pure $ Right $ DSDocumentSymbols (List [])  documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol-documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))+documentSymbolForDecl (L (RealSrcSpan l) (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name   = showRdrName n                   <> (case pprText fdTyVars of@@ -78,7 +80,7 @@     , _detail = Just $ pprText fdInfo     , _kind   = SkClass     }-documentSymbolForDecl (L l (TyClD ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))+documentSymbolForDecl (L (RealSrcSpan l) (TyClD ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name     = showRdrName name                     <> (case pprText tcdTyVars of@@ -92,13 +94,13 @@         [ (defDocumentSymbol l :: DocumentSymbol)             { _name           = showRdrName n             , _kind           = SkMethod-            , _selectionRange = srcSpanToRange l'+            , _selectionRange = realSrcSpanToRange l'             }-        | L l  (ClassOpSig False names _) <- tcdSigs-        , L l' n                            <- names+        | L (RealSrcSpan l)  (ClassOpSig False names _) <- tcdSigs+        , L (RealSrcSpan l') n                            <- names         ]     }-documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))+documentSymbolForDecl (L (RealSrcSpan l) (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name     = showRdrName name     , _kind     = SkStruct@@ -107,11 +109,11 @@         [ (defDocumentSymbol l :: DocumentSymbol)             { _name           = showRdrName n             , _kind           = SkConstructor-            , _selectionRange = srcSpanToRange l'+            , _selectionRange = realSrcSpanToRange l'             , _children       = conArgRecordFields (getConArgs x)             }-        | L l  x <- dd_cons-        , L l' n <- getConNames x+        | L (RealSrcSpan l ) x <- dd_cons+        , L (RealSrcSpan l') n <- getConNames x         ]     }   where@@ -122,48 +124,48 @@           , _kind = SkField           }       | L _ cdf <- lcdfs-      , L l n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf+      , L (RealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf       ]     conArgRecordFields _ = Nothing-documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just+documentSymbolForDecl (L (RealSrcSpan l) (TyClD SynDecl { tcdLName = L (RealSrcSpan l') n })) = Just   (defDocumentSymbol l :: DocumentSymbol) { _name           = showRdrName n                                           , _kind           = SkTypeParameter-                                          , _selectionRange = srcSpanToRange l'+                                          , _selectionRange = realSrcSpanToRange l'                                           }-documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))+documentSymbolForDecl (L (RealSrcSpan l) (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))   = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty                                                  , _kind = SkInterface                                                  }-documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))+documentSymbolForDecl (L (RealSrcSpan l) (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords                 (map pprText feqn_pats)     , _kind = SkInterface     }-documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))+documentSymbolForDecl (L (RealSrcSpan l) (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords                 (map pprText feqn_pats)     , _kind = SkInterface     }-documentSymbolForDecl (L l (DerivD DerivDecl { deriv_type })) =+documentSymbolForDecl (L (RealSrcSpan l) (DerivD DerivDecl { deriv_type })) =   gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) ->     (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs)                                               name                                             , _kind = SkInterface                                             }-documentSymbolForDecl (L l (ValD FunBind{fun_id = L _ name})) = Just+documentSymbolForDecl (L (RealSrcSpan l) (ValD FunBind{fun_id = L _ name})) = Just     (defDocumentSymbol l :: DocumentSymbol)       { _name   = showRdrName name       , _kind   = SkFunction       }-documentSymbolForDecl (L l (ValD PatBind{pat_lhs})) = Just+documentSymbolForDecl (L (RealSrcSpan l) (ValD PatBind{pat_lhs})) = Just     (defDocumentSymbol l :: DocumentSymbol)       { _name   = pprText pat_lhs       , _kind   = SkFunction       } -documentSymbolForDecl (L l (ForD x)) = Just+documentSymbolForDecl (L (RealSrcSpan l) (ForD x)) = Just   (defDocumentSymbol l :: DocumentSymbol)     { _name   = case x of                   ForeignImport{} -> name@@ -203,7 +205,7 @@           }  documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol-documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just+documentSymbolForImport (L (RealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just   (defDocumentSymbol l :: DocumentSymbol)     { _name   = "import " <> pprText ideclName     , _kind   = SkModule@@ -213,18 +215,16 @@     , _detail = if ideclQualified then Just "qualified" else Nothing #endif     }-#if MIN_GHC_API_VERSION(8,6,0)-documentSymbolForImport (L _ XImportDecl {}) = Nothing-#endif+documentSymbolForImport _ = Nothing -defDocumentSymbol :: SrcSpan -> DocumentSymbol+defDocumentSymbol :: RealSrcSpan -> DocumentSymbol defDocumentSymbol l = DocumentSymbol { .. } where   _detail         = Nothing   _deprecated     = Nothing   _name           = ""   _kind           = SkUnknown 0-  _range          = srcSpanToRange l-  _selectionRange = srcSpanToRange l+  _range          = realSrcSpanToRange l+  _selectionRange = realSrcSpanToRange l   _children       = Nothing  showRdrName :: RdrName -> Text

@@ -14,7 +14,11 @@     , codeAction     , codeLens     , rulePackageExports-    , executeAddSignatureCommand+    , commandHandler++    -- * For testing+    , blockCommandId+    , typeSignatureCommandId     ) where  import Control.Monad (join, guard)@@ -30,6 +34,7 @@ import Development.IDE.Plugin.CodeAction.PositionIndexed import Development.IDE.Plugin.CodeAction.RuleTypes import Development.IDE.Plugin.CodeAction.Rules+import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options import Development.Shake (Rules)@@ -46,10 +51,8 @@ import qualified Data.Text as T import Data.Tuple.Extra ((&&&)) import HscTypes-import SrcLoc (sortLocated) import Parser-import Text.Regex.TDFA ((=~), (=~~))-import Text.Regex.TDFA.Text()+import Text.Regex.TDFA (mrAfter, (=~), (=~~)) import Outputable (ppr, showSDocUnsafe) import DynFlags (xFlags, FlagSpec(..)) import GHC.LanguageExtensions.Type (Extension)@@ -58,6 +61,9 @@ import Data.Functor import Control.Applicative ((<|>)) import Safe (atMay)+import Bag (isEmptyBag)+import qualified Data.HashSet as Set+import Control.Concurrent.Extra (threadDelay, readVar)  plugin :: Plugin c plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens@@ -65,6 +71,13 @@ rules :: Rules () rules = rulePackageExports +-- | a command that blocks forever. Used for testing+blockCommandId :: T.Text+blockCommandId = "ghcide.command.block"++typeSignatureCommandId :: T.Text+typeSignatureCommandId = "typesignature.add"+ -- | Generate code actions. codeAction     :: LSP.LspFuncs c@@ -83,10 +96,12 @@             <*> use GhcSession `traverse` mbFile     -- This is quite expensive 0.6-0.7s on GHC     pkgExports <- runAction "CodeAction:PackageExports" state $ (useNoFile_ . PackageExports) `traverse` env+    localExports <- readVar (exportsMap $ shakeExtras state)+    let exportsMap = localExports <> fromMaybe mempty pkgExports     let dflags = hsc_dflags . hscEnv <$> env     pure $ Right         [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing-        | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x+        | x <- xs, (title, tedit) <- suggestAction dflags exportsMap ideOptions ( join parsedModule ) text x         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing         ] @@ -113,17 +128,23 @@       Nothing -> pure []  -- | Execute the "typesignature.add" command.-executeAddSignatureCommand+commandHandler     :: LSP.LspFuncs c     -> IdeState     -> ExecuteCommandParams     -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))-executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}+commandHandler lsp _ideState ExecuteCommandParams{..}     -- _command is prefixed with a process ID, because certain clients     -- have a global command registry, and all commands must be     -- unique. And there can be more than one ghcide instance running     -- at a time against the same client.-    | T.isSuffixOf "typesignature.add" _command+    | T.isSuffixOf blockCommandId _command+    = do+        LSP.sendFunc lsp $ NotCustomServer $+            NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null+        threadDelay maxBound+        return (Right Null, Nothing)+    | T.isSuffixOf typeSignatureCommandId _command     , Just (List [edit]) <- _arguments     , Success wedit <- fromJSON edit     = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))@@ -132,21 +153,21 @@  suggestAction   :: Maybe DynFlags-  -> PackageExportsMap+  -> ExportsMap   -> IdeOptions   -> Maybe ParsedModule   -> Maybe T.Text   -> Diagnostic   -> [(T.Text, [TextEdit])] suggestAction dflags packageExports ideOptions parsedModule text diag = concat-    [ suggestAddExtension diag+   -- Order these suggestions by priority+    [ suggestAddExtension diag             -- Highest priority+    , suggestSignature True diag     , suggestExtendImport dflags text diag-    , suggestFillHole diag     , suggestFillTypeWildcard diag     , suggestFixConstructorImport text diag     , suggestModuleTypo diag     , suggestReplaceIdentifier text diag-    , suggestSignature True diag     , suggestConstraint text diag     , removeRedundantConstraints text diag     , suggestAddTypeAnnotationToSatisfyContraints text diag@@ -154,16 +175,18 @@     [  suggestNewDefinition ideOptions pm text diag     ++ suggestRemoveRedundantImport pm text diag     ++ suggestNewImport packageExports pm diag-    ++ suggestDeleteTopBinding pm diag+    ++ suggestDeleteUnusedBinding pm text diag     ++ suggestExportUnusedTopBinding text pm diag-    | Just pm <- [parsedModule]]+    | Just pm <- [parsedModule]+    ] +++    suggestFillHole diag                   -- Lowest priority   suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} --     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant-    | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"-    , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports+    | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"+    , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == Just _range ) hsmodImports     , Just c <- contents     , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)     , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)@@ -178,33 +201,121 @@         = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]     | otherwise = [] -suggestDeleteTopBinding :: ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]-suggestDeleteTopBinding ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} Diagnostic{_range=_range,..}--- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’-    | Just [name] <- matchRegex _message ".*Defined but not used: ‘([^ ]+)’"-    , let allTopLevel = filter (isTopLevel . fst)-                        . map (\(L l b) -> (srcSpanToRange l, b))-                        . sortLocated-                        $ hsmodDecls-          sameName = filter (matchesBindingName (T.unpack name) . snd) allTopLevel-    , not (null sameName)-            = [("Delete ‘" <> name <> "’", flip TextEdit "" . toNextBinding allTopLevel . fst <$> sameName )]+suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestDeleteUnusedBinding+  ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}}+  contents+  Diagnostic{_range=_range,..}+-- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’+    | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"+    , Just indexedContent <- indexedByPosition . T.unpack <$> contents+      = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name)+        in ([("Delete ‘" <> name <> "’", edits) | not (null edits)])     | otherwise = []     where-      isTopLevel l = (_character . _start) l == 0+      relatedRanges indexedContent name =+        concatMap (findRelatedSpans indexedContent name) hsmodDecls+      toRange = realSrcSpanToRange+      extendForSpaces = extendToIncludePreviousNewlineIfPossible -      forwardLines lines r = r {_end = (_end r) {_line = (_line . _end $ r) + lines, _character = 0}}+      findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range]+      findRelatedSpans+        indexedContent+        name+        (L (RealSrcSpan l) (ValD (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) =+        case lname of+          (L nLoc _name) | isTheBinding nLoc ->+            let findSig (L (RealSrcSpan l) (SigD sig)) = findRelatedSigSpan indexedContent name l sig+                findSig _ = []+            in+              [extendForSpaces indexedContent $ toRange l]+              ++ concatMap findSig hsmodDecls+          _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches+      findRelatedSpans _ _ _ = [] -      toNextBinding bindings r@Range { _end = Position {_line = l} }-        | Just (Range { _start = Position {_line = l'}}, _) <- find ((> l) . _line . _start . fst) bindings-        = forwardLines (l' - l) r-      toNextBinding _ r  = r+      extractNameAndMatchesFromFunBind+        :: HsBind GhcPs+        -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)])+      extractNameAndMatchesFromFunBind+        FunBind+          { fun_id=lname+          , fun_matches=MG {mg_alts=L _ matches}+          } = Just (lname, matches)+      extractNameAndMatchesFromFunBind _ = Nothing -      matchesBindingName :: String -> HsDecl GhcPs -> Bool-      matchesBindingName b (ValD FunBind {fun_id=L _ x}) = showSDocUnsafe (ppr x) == b-      matchesBindingName b (SigD (TypeSig (L _ x:_) _)) = showSDocUnsafe (ppr x) == b-      matchesBindingName _ _ = False+      findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range]+      findRelatedSigSpan indexedContent name l sig =+        let maybeSpan = findRelatedSigSpan1 name sig+        in case maybeSpan of+          Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int+          Just (RealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused+          _ -> [] +      -- Second of the tuple means there is only one match+      findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool)+      findRelatedSigSpan1 name (TypeSig lnames _) =+        let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames+        in case maybeIdx of+            Nothing -> Nothing+            Just _ | length lnames == 1 -> Just (getLoc $ head lnames, True)+            Just idx ->+              let targetLname = getLoc $ lnames !! idx+                  startLoc = srcSpanStart targetLname+                  endLoc = srcSpanEnd targetLname+                  startLoc' = if idx == 0+                              then startLoc+                              else srcSpanEnd . getLoc $ lnames !! (idx - 1)+                  endLoc' = if idx == 0 && idx < length lnames - 1+                            then srcSpanStart . getLoc $ lnames !! (idx + 1)+                            else endLoc+              in Just (mkSrcSpan startLoc' endLoc', False)+      findRelatedSigSpan1 _ _ = Nothing++      -- for where clause+      findRelatedSpanForMatch+        :: PositionIndexedString+        -> String+        -> LMatch GhcPs (LHsExpr GhcPs)+        -> [Range]+      findRelatedSpanForMatch+        indexedContent+        name+        (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do+        case grhssLocalBinds of+          (L _ (HsValBinds (ValBinds bag lsigs))) ->+            if isEmptyBag bag+            then []+            else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag+          _ -> []+#if MIN_GHC_API_VERSION(8,6,0)+      findRelatedSpanForMatch _ _ _ = []+#endif++      findRelatedSpanForHsBind+        :: PositionIndexedString+        -> String+        -> [LSig GhcPs]+        -> LHsBind GhcPs+        -> [Range]+      findRelatedSpanForHsBind+        indexedContent+        name+        lsigs+        (L (RealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) =+        if isTheBinding (getLoc lname)+        then+          let findSig (L (RealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig+              findSig _ = []+          in [extendForSpaces indexedContent $ toRange l] ++ concatMap findSig lsigs+        else concatMap (findRelatedSpanForMatch indexedContent name) matches+      findRelatedSpanForHsBind _ _ _ _ = []++      isTheBinding :: SrcSpan -> Bool+      isTheBinding span = srcSpanToRange span == Just _range++      isSameName :: IdP GhcPs -> String -> Bool+      isSameName x name = showSDocUnsafe (ppr x) == name+ data ExportsAs = ExportName | ExportPattern | ExportAll   deriving (Eq) @@ -214,17 +325,17 @@ -- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’ -- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’   | Just source <- srcOpt-  , Just [name] <- matchRegex _message ".*Defined but not used: ‘([^ ]+)’"-                   <|> matchRegex _message ".*Defined but not used: type constructor or class ‘([^ ]+)’"-                   <|> matchRegex _message ".*Defined but not used: data constructor ‘([^ ]+)’"+  , Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"+                   <|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’"+                   <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’"   , Just (exportType, _) <- find (matchWithDiagnostic _range . snd)                             . mapMaybe-                                (\(L l b) -> if isTopLevel $ srcSpanToRange l+                                (\(L l b) -> if maybe False isTopLevel $ srcSpanToRange l                                                 then exportsAs b else Nothing)                             $ hsmodDecls-  , Just pos <- _end . getLocatedRange <$> hsmodExports+  , Just pos <- fmap _end . getLocatedRange =<< hsmodExports   , Just needComma <- needsComma source <$> hsmodExports-  , let exportName = (if needComma then "," else "") <> printExport exportType name +  , let exportName = (if needComma then "," else "") <> printExport exportType name         insertPos = pos {_character = pred $ _character pos}   = [("Export ‘" <> name <> "’", [TextEdit (Range insertPos insertPos) exportName])]   | otherwise = []@@ -232,18 +343,21 @@     -- we get the last export and the closing bracket and check for comma in that range     needsComma :: T.Text -> Located [LIE GhcPs] -> Bool     needsComma _ (L _ []) = False-    needsComma source x@(L _ exports) =-      let closeParan = _end $ getLocatedRange x-          lastExport = _end . getLocatedRange $ last exports-      in not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source+    needsComma source (L (RealSrcSpan l) exports) =+      let closeParan = _end $ realSrcSpanToRange l+          lastExport = fmap _end . getLocatedRange $ last exports+      in case lastExport of+        Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source+        _ -> False+    needsComma _ _ = False -    getLocatedRange :: Located a -> Range+    getLocatedRange :: Located a -> Maybe Range     getLocatedRange = srcSpanToRange . getLoc      matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool     matchWithDiagnostic Range{_start=l,_end=r} x =-      let loc = _start . getLocatedRange $ x-       in loc >= l && loc <= r+      let loc = fmap _start . getLocatedRange $ x+       in loc >= Just l && loc <= Just r      printExport :: ExportsAs -> T.Text -> T.Text     printExport ExportName x = x@@ -291,11 +405,11 @@ --       In the expression: seq "test" seq "test" (traceShow "test") --       In an equation for ‘f’: --          f = seq "test" seq "test" (traceShow "test")-    | Just [ty, lit] <- matchRegex _message (pat False False True)-                        <|> matchRegex _message (pat False False False)+    | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True)+                        <|> matchRegexUnifySpaces _message (pat False False False)             = codeEdit ty lit (makeAnnotatedLit ty lit)     | Just source <- sourceOpt-    , Just [ty, lit] <- matchRegex _message (pat True True False)+    , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False)             = let lit' = makeAnnotatedLit ty lit;                   tir = textInRange _range source               in codeEdit ty lit (T.replace lit lit' tir)@@ -337,9 +451,9 @@ suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range} --     * Variable not in scope: --         suggestAcion :: Maybe T.Text -> Range -> Range-    | Just [name, typ] <- matchRegex message "Variable not in scope: ([^ ]+) :: ([^*•]+)"+    | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)"     = newDefinitionAction ideOptions parsedModule _range name typ-    | Just [name, typ] <- matchRegex message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"+    | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"     , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ     = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]     | otherwise = []@@ -349,8 +463,8 @@ newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])] newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ     | Range _ lastLineP : _ <--      [ srcSpanToRange l-      | (L l _) <- hsmodDecls+      [ realSrcSpanToRange sp+      | (L l@(RealSrcSpan sp) _) <- hsmodDecls       , _start `isInsideSrcSpan` l]     , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}     = [ ("Define " <> sig@@ -422,49 +536,87 @@  suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])] suggestFillHole Diagnostic{_range=_range,..}---  ...Development/IDE/LSP/CodeAction.hs:103:9: warning:---   * Found hole: _ :: Int -> String---   * In the expression: _---     In the expression: _ a---     In an equation for ‘foo’: foo a = _ a---   * Relevant bindings include---       a :: Int---         (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)---       foo :: Int -> String---         (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)---     Valid hole fits include---       foo :: Int -> String---         (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)---       show :: forall a. Show a => a -> String---         with show @Int---         (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37---          (and originally defined in ‘GHC.Show’))---       mempty :: forall a. Monoid a => a---         with mempty @(Int -> String)---         (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37---          (and originally defined in ‘GHC.Base’)) (lsp-ui)+    | Just holeName <- extractHoleName _message+    , (holeFits, refFits) <- processHoleSuggestions (T.lines _message)+    = map (proposeHoleFit holeName False) holeFits+    ++ map (proposeHoleFit holeName True) refFits+    | otherwise = []+    where+      extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"+      proposeHoleFit holeName parenthise name =+          ( "replace " <> holeName <> " with " <> name+          , [TextEdit _range $ if parenthise then parens name else name])+      parens x = "(" <> x <> ")" -    | topOfHoleFitsMarker `T.isInfixOf` _message = let-      findSuggestedHoleFits :: T.Text -> [T.Text]-      findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines-      proposeHoleFit name = ("replace hole `" <> holeName <>  "` with " <> name, [TextEdit _range name])-      holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message-      dropPreceding       = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))-      selectLinesWithFits = filter ("::" `T.isInfixOf`)-      extractFitNames     = map (T.strip . head . T.splitOn " :: ")-      in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message+processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])+processHoleSuggestions mm = (holeSuggestions, refSuggestions)+{-+    • Found hole: _ :: LSP.Handlers -    | otherwise = []+      Valid hole fits include def+      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+                                                                                                        LSP.Handlers)+        T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers)+                (_ :: LSP.Handlers)+                (_ :: T.Text)+        T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers)+                 (_ :: LSP.Handlers)+                 (_ :: T.Text)+-}+  where+    t = id @T.Text+    holeSuggestions = do+      -- get the text indented under Valid hole fits+      validHolesSection <-+        getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm+      -- the Valid hole fits line can contain a hole fit+      holeFitLine <-+        mapHead+            (mrAfter . (=~ t " *Valid (hole fits|substitutions) include"))+            validHolesSection+      let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine+      guard (not $ T.null holeFit)+      return holeFit+    refSuggestions = do -- @[]+      -- get the text indented under Valid refinement hole fits+      refinementSection <-+        getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm+      -- get the text for each hole fit+      holeFitLines <- getIndentedGroups (tail refinementSection)+      let holeFit = T.strip $ T.unwords holeFitLines+      guard $ not $ holeFit =~ t "Some refinement hole fits suppressed"+      return holeFit +    mapHead f (a:aa) = f a : aa+    mapHead _ [] = []++-- > getIndentedGroups [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1,", "  l1", "  l2"], [" H2", "  l3"]]+getIndentedGroups :: [T.Text] -> [[T.Text]]+getIndentedGroups [] = []+getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll+-- |+-- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1", "  l1", "  l2"], [" H2", "  l3"]]+getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]]+getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of+    (l:ll) -> case span (\l' -> indentation l < indentation l') ll of+        (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest+    _ -> []++indentation :: T.Text -> Int+indentation = T.length . T.takeWhile isSpace+ suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}     | Just [binding, mod, srcspan] <--      matchRegex _message+      matchRegexUnifySpaces _message       "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"     , Just c <- contents     , POk _ (L _ name) <- runParser dflags (T.unpack binding) parseIdentifier     = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of-            [s] -> let x = srcSpanToRange s+            [s] -> let x = realSrcSpanToRange s                    in x{_end = (_end x){_character = succ (_character (_end x))}}             _ -> error "bug in srcspan parser"           importLine = textInRange range c@@ -481,7 +633,7 @@     -- or     -- import Data.Aeson.Types( Result(..) ) (lsp-ui)   | Just [constructor, typ] <--    matchRegex _message+    matchRegexUnifySpaces _message     "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"   = let fixedImport = typ <> "(" <> constructor <> ")"     in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]@@ -525,7 +677,7 @@       findMissingConstraint :: T.Text -> Maybe T.Text       findMissingConstraint t =         let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from a use of"-         in matchRegex t regex <&> last+         in matchRegexUnifySpaces t regex <&> last  normalizeConstraints :: T.Text -> T.Text -> T.Text normalizeConstraints existingConstraints constraint =@@ -543,7 +695,7 @@ -- • In the expression: x == y --   In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y --   In the instance declaration for ‘Eq (Wrap a)’-  | Just [instanceDeclaration] <- matchRegex _message "In the instance declaration for ‘([^`]*)’"+  | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’"   = let instanceLine = contents           & T.splitOn ("instance " <> instanceDeclaration)           & head & T.lines & length@@ -562,7 +714,7 @@ --   In an equation for ‘==’: --       (Pair x x') == (Pair y y') = x == y && x' == y'   | Just [instanceLineStr, constraintFirstCharStr]-    <- matchRegex _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)"+    <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)"   = let existingConstraints = findExistingConstraints _message         newConstraints = normalizeConstraints existingConstraints missingConstraint         instanceLine = readPositionNumber instanceLineStr@@ -586,7 +738,7 @@         <> "` to the context of the instance declaration"  findTypeSignatureName :: T.Text -> Maybe T.Text-findTypeSignatureName t = matchRegex t "([^ ]+) :: " <&> head+findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head  findTypeSignatureLine :: T.Text -> T.Text -> Int findTypeSignatureLine contents typeSignatureName =@@ -632,7 +784,7 @@       findExistingConstraints :: T.Text -> Maybe T.Text       findExistingConstraints message =         if message =~ ("from the context:" :: String)-           then fmap (T.strip . head) $ matchRegex message "\\. ([^=]+)"+           then fmap (T.strip . head) $ matchRegexUnifySpaces message "\\. ([^=]+)"            else Nothing        buildNewConstraints :: T.Text -> Maybe T.Text -> T.Text@@ -687,7 +839,7 @@         & T.lines         & head         & T.strip-        & (`matchRegex` "Redundant constraints?: (.+)")+        & (`matchRegexUnifySpaces` "Redundant constraints?: (.+)")         <&> (head >>> parseConstraints)        -- If the type signature is not formatted as expected (arbitrary number of spaces,@@ -724,7 +876,7 @@  ------------------------------------------------------------------------------------------------- -suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]+suggestNewImport :: ExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])] suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}   | msg <- unifySpaces _message   , Just name <- extractNotInScopeName msg@@ -736,29 +888,34 @@           RealSrcLoc s -> Just $ srcLocLine s           _ -> Nothing   , insertPos <- Position insertLine 0-  , extendImportSuggestions <- matchRegex msg+  , extendImportSuggestions <- matchRegexUnifySpaces msg     "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"   = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])-    | imp <- constructNewImportSuggestions packageExportsMap name extendImportSuggestions+    | imp <- sort $ constructNewImportSuggestions packageExportsMap name extendImportSuggestions     ] suggestNewImport _ _ _ = []  constructNewImportSuggestions-  :: PackageExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text]+  :: ExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text] constructNewImportSuggestions exportsMap thingMissing notTheseModules = nubOrd-  [ renderNewImport identInfo m-  | (identInfo, m) <- fromMaybe [] $ Map.lookup name exportsMap+  [ suggestion+  | (identInfo, m) <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap)   , canUseIdent thingMissing identInfo   , m `notElem` fromMaybe [] notTheseModules+  , suggestion <- renderNewImport identInfo m   ]  where   renderNewImport identInfo m-    | Just q <- qual = "import qualified " <> m <> " as " <> q-    | otherwise      = "import " <> m <> " (" <> importWhat identInfo <> ")"+    | Just q <- qual+    , asQ <- if q == m then "" else " as " <> q+    = ["import qualified " <> m <> asQ]+    | otherwise+    = ["import " <> m <> " (" <> importWhat identInfo <> ")"+      ,"import " <> m ]    (qual, name) = case T.splitOn "." (notInScope thingMissing) of     [n]      -> (Nothing, n)-    segments -> (Just (T.concat $ init segments), last segments)+    segments -> (Just (T.intercalate "." $ init segments), last segments)   importWhat IdentInfo {parent, rendered}     | Just p <- parent = p <> "(" <> rendered <> ")"     | otherwise        = rendered@@ -780,30 +937,23 @@  extractNotInScopeName :: T.Text -> Maybe NotInScope extractNotInScopeName x-  | Just [name] <- matchRegex x "Data constructor not in scope: ([^ ]+)"+  | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)"   = Just $ NotInScopeDataConstructor name-  | Just [name] <- matchRegex x "Not in scope: data constructor [^‘]*‘([^’]*)’"+  | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’"   = Just $ NotInScopeDataConstructor name-  | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"+  | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"   = Just $ NotInScopeTypeConstructorOrClass name-  | Just [name] <- matchRegex x "ot in scope: \\(([^‘ ]+)\\)"+  | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)"   = Just $ NotInScopeThing name-  | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"+  | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)"   = Just $ NotInScopeThing name-  | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"+  | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’"   = Just $ NotInScopeThing name   | otherwise   = Nothing  ------------------------------------------------------------------------------------------------- -topOfHoleFitsMarker :: T.Text-topOfHoleFitsMarker =-#if MIN_GHC_API_VERSION(8,6,0)-  "Valid hole fits include"-#else-  "Valid substitutions include"-#endif  mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit mkRenameEdit contents range name =@@ -876,7 +1026,7 @@ -- | Returns the ranges for a binding in an import declaration rangesForBinding :: ImportDecl GhcPs -> String -> [Range] rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =-    concatMap (map srcSpanToRange . rangesForBinding' b') lies+    concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies   where     b' = wrapOperatorInParens (unqualify b) @@ -913,16 +1063,25 @@         $  "importLine does not have the expected structure: "         <> T.unpack importLine +-- | 'matchRegex' combined with 'unifySpaces'+matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]+matchRegexUnifySpaces message = matchRegex (unifySpaces message)+ -- | Returns Just (the submatches) for the first capture, or Nothing. matchRegex :: T.Text -> T.Text -> Maybe [T.Text]-matchRegex message regex = case unifySpaces message =~~ regex of+matchRegex message regex = case message =~~ regex of     Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings     Nothing -> Nothing  setHandlersCodeLens :: PartialHandlers c setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{-    LSP.codeLensHandler = withResponse RspCodeLens codeLens,-    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand+    LSP.codeLensHandler =+        withResponse RspCodeLens codeLens,+    LSP.executeCommandHandler =+        withResponseAndRequest+            RspExecuteCommand+            ReqApplyWorkspaceEdit+            commandHandler     }  filterNewlines :: T.Text -> T.Text

@@ -5,6 +5,7 @@   , indexedByPosition   , indexedByPositionStartingFrom   , extendAllToIncludeCommaIfPossible+  , extendToIncludePreviousNewlineIfPossible   , mergeRanges   ) where@@ -106,7 +107,25 @@     -- a, |b|, c ===> a, |b, |c     [ range { _end = end' }     | (_, ',') : rest <- [after']-    , let (end', _) : _ = dropWhile (isSpace . snd) rest+    , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest     ]   | otherwise   = [range]++extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range+extendToIncludePreviousNewlineIfPossible indexedString range+  | Just (before, _, _) <- unconsRange range indexedString+  , maybeFirstSpacePos <- lastSpacePos $ reverse before+  = case maybeFirstSpacePos of+      Nothing -> range+      Just pos -> range { _start = pos }+  | otherwise = range+  where+    lastSpacePos :: PositionIndexedString -> Maybe Position+    lastSpacePos [] = Nothing+    lastSpacePos ((pos, c):xs) =+      if not $ isSpace c+      then Nothing -- didn't find any space+      else case xs of+              (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys)+              _ -> Just pos

@@ -1,57 +1,20 @@ {-# LANGUAGE TypeFamilies #-} module Development.IDE.Plugin.CodeAction.RuleTypes-    (PackageExports(..), PackageExportsMap+    (PackageExports(..)     ,IdentInfo(..)-    ,mkIdentInfos     ) where -import Avail (AvailInfo(..)) import Data.Hashable (Hashable) import Control.DeepSeq (NFData) import Data.Binary (Binary)-import Data.Text (pack, Text) import Development.IDE.GHC.Util+import Development.IDE.Types.Exports import Development.Shake (RuleResult)-import Data.HashMap.Strict (HashMap) import Data.Typeable (Typeable) import GHC.Generics (Generic)-import Name-import FieldLabel (flSelector) -type Identifier = Text-type ModuleName = Text--data IdentInfo = IdentInfo-    { name :: !Identifier-    , rendered :: Text-    , parent :: !(Maybe Text)-    , isDatacon :: !Bool-    }-    deriving (Eq, Generic, Show)--instance NFData IdentInfo--mkIdentInfos :: AvailInfo -> [IdentInfo]-mkIdentInfos (Avail n) =-    [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]-mkIdentInfos (AvailTC parent (n:nn) flds)-    -- Following the GHC convention that parent == n if parent is exported-    | n == parent-    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True-        | n <- nn ++ map flSelector flds-      ] ++-      [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]-    where-        parentP = pack $ prettyPrint parent--mkIdentInfos (AvailTC _ nn flds)-    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True-        | n <- nn ++ map flSelector flds-      ]- -- Rule type for caching Package Exports-type instance RuleResult PackageExports = PackageExportsMap-type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]+type instance RuleResult PackageExports = ExportsMap  newtype PackageExports = PackageExports HscEnvEq     deriving (Eq, Show, Typeable, Generic)

@@ -3,26 +3,17 @@   ) where -import           Data.HashMap.Strict            ( fromListWith )-import           Data.Text                      ( Text-                                                , pack-                                                ) import           Data.Traversable               ( forM ) import           Development.IDE.Core.Rules import           Development.IDE.GHC.Util import           Development.IDE.Plugin.CodeAction.RuleTypes+import           Development.IDE.Types.Exports import           Development.Shake import           GHC                            ( DynFlags(pkgState) )-import           HscTypes                       ( IfaceExport-                                                , hsc_dflags-                                                , mi_exports-                                                )+import           HscTypes                       ( hsc_dflags) import           LoadIface import           Maybes-import           Module                         ( Module(..)-                                                , ModuleName-                                                , moduleNameString-                                                )+import           Module                         ( Module(..) ) import           Packages                       ( explicitPackages                                                 , exposedModules                                                 , packageConfigId@@ -43,19 +34,12 @@         , (mn, _)  <- exposedModules pkg         ] -  results <- forM targets $ \(pkg, mn) -> do+  modIfaces <- forM targets $ \(pkg, mn) -> do     modIface <- liftIO $ initIfaceLoad env $ loadInterface       ""       (Module (packageConfigId pkg) mn)       (ImportByUser False)-    case modIface of-      Failed    _err -> return mempty-      Succeeded mi   -> do-        let avails = mi_exports mi-        return $ concatMap (unpackAvail mn) avails-  return $ fromListWith (++) $ concat results--unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]-unpackAvail mod =-  map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))-    . mkIdentInfos+    return $ case modIface of+      Failed    _err -> Nothing+      Succeeded mi   -> Just mi+  return $ createExportsMap (catMaybes modIfaces)

@@ -2,7 +2,11 @@ {-# LANGUAGE TypeFamilies #-} #include "ghc-api-version.h" -module Development.IDE.Plugin.Completions(plugin) where+module Development.IDE.Plugin.Completions+    (+      plugin+    , getCompletionsLSP+    ) where  import Control.Applicative import Language.Haskell.LSP.Messages

@@ -15,6 +15,7 @@ import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map  as Map import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Maybe as UnsafeMaybe (fromJust) import qualified Data.Text as T import qualified Text.Fuzzy as Fuzzy @@ -233,7 +234,7 @@       dflags = hsc_dflags packageState       curMod = ms_mod $ pm_mod_summary parsedMod       curModName = moduleName curMod-      Just (_,limports,_,_) = tm_renamed_source tm+      (_,limports,_,_) = UnsafeMaybe.fromJust $ tm_renamed_source tm -- safe because we always save the typechecked source        iDeclToModName :: ImportDecl name -> ModuleName       iDeclToModName = unLoc . ideclName

@@ -0,0 +1,64 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+-- | A plugin that adds custom messages for use in tests+module Development.IDE.Plugin.Test (TestRequest(..), plugin) where++import Control.Monad.STM+import Data.Aeson+import Data.Aeson.Types+import Development.IDE.Core.Service+import Development.IDE.Core.Shake+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Util (HscEnvEq(hscEnv))+import Development.IDE.LSP.Server+import Development.IDE.Plugin+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 System.Time.Extra+import Development.IDE.Core.RuleTypes++data TestRequest+    = BlockSeconds Seconds           -- ^ :: Null+    | GetInterfaceFilesDir FilePath  -- ^ :: String+    | GetShakeSessionQueueCount      -- ^ :: Number+    deriving Generic+    deriving anyclass (FromJSON, ToJSON)++plugin :: Plugin c+plugin = Plugin {+    pluginRules = return (),+    pluginHandler = PartialHandlers $ \WithMessage{..} x -> return x {+        customRequestHandler = withResponse RspCustomServer requestHandler'+    }+}+  where+      requestHandler' lsp ide req+        | Just customReq <- parseMaybe parseJSON req+        = requestHandler lsp ide customReq+        | otherwise+        = return $ Left+        $ ResponseError InvalidRequest "Cannot parse request" Nothing++requestHandler :: LspFuncs c+                -> 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+    return (Right Null)+requestHandler _ s (GetInterfaceFilesDir fp) = 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+    n <- atomically $ countQueue $ actionQueue $ shakeExtras s+    return $ Right (toJSON n)+

@@ -171,7 +171,7 @@   -> [SpanInfo]   -> MaybeT m [Location] querySpanInfoAt getSpan _ideOptions pos =-    lift . fmap (map srcSpanToLocation) . mapMaybeM getSpan . spansAtPoint pos+    lift . fmap (mapMaybe srcSpanToLocation) . mapMaybeM getSpan . spansAtPoint pos  -- | Given a 'Name' attempt to find the location where it is defined. nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe SrcSpan)

@@ -112,7 +112,7 @@ haddockToMarkdown (H.DocAppend d1 d2)   = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2 haddockToMarkdown (H.DocString s)-  = s+  = escapeBackticks s haddockToMarkdown (H.DocParagraph p)   = "\n\n" ++ haddockToMarkdown p haddockToMarkdown (H.DocIdentifier i)@@ -120,7 +120,7 @@ haddockToMarkdown (H.DocIdentifierUnchecked i)   = "`" ++ i ++ "`" haddockToMarkdown (H.DocModule i)-  = "`" ++ i ++ "`"+  = "`" ++ escapeBackticks i ++ "`" haddockToMarkdown (H.DocWarning w)   = haddockToMarkdown w haddockToMarkdown (H.DocEmphasis d)@@ -128,11 +128,7 @@ haddockToMarkdown (H.DocBold d)   = "**" ++ haddockToMarkdown d ++ "**" haddockToMarkdown (H.DocMonospaced d)-  = "`" ++ escapeBackticks (haddockToMarkdown d) ++ "`"-  where-    escapeBackticks "" = ""-    escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss-    escapeBackticks (s  :ss) = s:escapeBackticks ss+  = "`" ++ removeUnescapedBackticks (haddockToMarkdown d) ++ "`" haddockToMarkdown (H.DocCodeBlock d)   = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n" haddockToMarkdown (H.DocExamples es)@@ -149,7 +145,7 @@ haddockToMarkdown (H.DocPic (H.Picture url (Just label)))   = "![" ++ label ++ "](" ++ url ++ ")" haddockToMarkdown (H.DocAName aname)-  = "[" ++ aname ++ "]:"+  = "[" ++ escapeBackticks aname ++ "]:" haddockToMarkdown (H.DocHeader (H.Header level title))   = replicate level '#' ++ " " ++ haddockToMarkdown title @@ -173,6 +169,18 @@ -- things I don't really know how to handle haddockToMarkdown (H.DocProperty _)   = ""  -- don't really know what to do++escapeBackticks :: String -> String+escapeBackticks "" = ""+escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss+escapeBackticks (s  :ss) = s:escapeBackticks ss++removeUnescapedBackticks :: String -> String+removeUnescapedBackticks = \case+  '\\' : '`' : ss -> '\\' : '`' : removeUnescapedBackticks ss+  '`' : ss -> removeUnescapedBackticks ss+  "" -> ""+  s : ss -> s : removeUnescapedBackticks ss  splitForList :: String -> String splitForList s

@@ -31,6 +31,7 @@ import           GhcMonad import           Packages import           Name+import           Language.Haskell.LSP.Types (getUri, filePathToUri)  getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n]@@ -55,24 +56,25 @@ #endif     mkSpanDocText name =       pure (SpanDocText (getDocumentation sources name)) <*> getUris name-+        -- Get the uris to the documentation and source html pages if they exist     getUris name = do       df <- getSessionDynFlags-      (docFp, srcFp) <-+      (docFu, srcFu) <-         case nameModule_maybe name of           Just mod -> liftIO $ do-            doc <- fmap (fmap T.pack) $ lookupDocHtmlForModule df mod-            src <- fmap (fmap T.pack) $ lookupSrcHtmlForModule df mod+            doc <- toFileUriText $ lookupDocHtmlForModule df mod+            src <- toFileUriText $ lookupSrcHtmlForModule df mod             return (doc, src)           Nothing -> pure (Nothing, Nothing)-      let docUri = docFp >>= \fp -> pure $ "file://" <> fp <> "#" <> selector <> showName name-          srcUri = srcFp >>= \fp -> pure $ "file://" <> fp <> "#" <> showName name+      let docUri = (<> "#" <> selector <> showName name) <$> docFu+          srcUri = (<> "#" <> showName name) <$> srcFu           selector             | isValName name = "v:"             | otherwise = "t:"       return $ SpanDocUris docUri srcUri +    toFileUriText = (fmap . fmap) (getUri . filePathToUri)  getDocumentation  :: HasSrcSpan name

@@ -0,0 +1,88 @@+module Development.IDE.Types.Action+  ( DelayedAction (..),+    DelayedActionInternal,+    ActionQueue,+    newQueue,+    pushQueue,+    popQueue,+    doneQueue,+    peekInProgress,+  abortQueue,countQueue)+where++import           Control.Concurrent.STM+import           Data.Hashable                (Hashable (..))+import           Data.HashSet                 (HashSet)+import qualified Data.HashSet                 as Set+import           Data.Unique                  (Unique)+import           Development.IDE.Types.Logger+import           Development.Shake            (Action)+import           Numeric.Natural++data DelayedAction a = DelayedAction+  { uniqueID       :: Maybe Unique,+    -- | Name we use for debugging+    actionName     :: String,+    -- | Priority with which to log the action+    actionPriority :: Priority,+    -- | The payload+    getAction      :: Action a+  }+  deriving (Functor)++type DelayedActionInternal = DelayedAction ()++instance Eq (DelayedAction a) where+  a == b = uniqueID a == uniqueID b++instance Hashable (DelayedAction a) where+  hashWithSalt s = hashWithSalt s . uniqueID++instance Show (DelayedAction a) where+  show d = "DelayedAction: " ++ actionName d++------------------------------------------------------------------------------++data ActionQueue = ActionQueue+  { newActions :: TQueue DelayedActionInternal,+    inProgress :: TVar (HashSet DelayedActionInternal)+  }++newQueue :: IO ActionQueue+newQueue = atomically $ do+  newActions <- newTQueue+  inProgress <- newTVar mempty+  return ActionQueue {..}++pushQueue :: DelayedActionInternal -> ActionQueue -> STM ()+pushQueue act ActionQueue {..} = writeTQueue newActions act++-- | You must call 'doneQueue' to signal completion+popQueue :: ActionQueue -> STM DelayedActionInternal+popQueue ActionQueue {..} = do+  x <- readTQueue newActions+  modifyTVar inProgress (Set.insert x)+  return x++-- | Completely remove an action from the queue+abortQueue :: DelayedActionInternal -> ActionQueue -> STM ()+abortQueue x ActionQueue {..} = do+  qq <- flushTQueue newActions+  mapM_ (writeTQueue newActions) (filter (/= x) qq)+  modifyTVar inProgress (Set.delete x)++-- | Mark an action as complete when called after 'popQueue'.+--   Has no effect otherwise+doneQueue :: DelayedActionInternal -> ActionQueue -> STM ()+doneQueue x ActionQueue {..} = do+  modifyTVar inProgress (Set.delete x)++countQueue :: ActionQueue -> STM Natural+countQueue ActionQueue{..} = do+    backlog <- flushTQueue newActions+    mapM_ (writeTQueue newActions) backlog+    m <- Set.size <$> readTVar inProgress+    return $ fromIntegral $ length backlog + m++peekInProgress :: ActionQueue -> STM [DelayedActionInternal]+peekInProgress ActionQueue {..} = Set.toList <$> readTVar inProgress

@@ -0,0 +1,75 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+module Development.IDE.Types.Exports+(+    IdentInfo(..),+    ExportsMap(..),+    createExportsMap,+) where++import Avail (AvailInfo(..))+import Control.DeepSeq (NFData)+import Data.Text (pack, Text)+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Util+import Data.HashMap.Strict (HashMap)+import GHC.Generics (Generic)+import Name+import FieldLabel (flSelector)+import qualified Data.HashMap.Strict as Map+import GhcPlugins (IfaceExport)+import Data.HashSet (HashSet)+import qualified Data.HashSet as Set+import Data.Bifunctor (Bifunctor(second))+import Data.Hashable (Hashable)++newtype ExportsMap = ExportsMap+    {getExportsMap :: HashMap IdentifierText (HashSet (IdentInfo,ModuleNameText))}+    deriving newtype (Monoid, NFData, Show)++instance Semigroup ExportsMap where+    ExportsMap a <> ExportsMap b = ExportsMap $ Map.unionWith (<>) a b++type IdentifierText = Text+type ModuleNameText = Text++data IdentInfo = IdentInfo+    { name :: !Text+    , rendered :: Text+    , parent :: !(Maybe Text)+    , isDatacon :: !Bool+    }+    deriving (Eq, Generic, Show)+    deriving anyclass Hashable++instance NFData IdentInfo++mkIdentInfos :: AvailInfo -> [IdentInfo]+mkIdentInfos (Avail n) =+    [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]+mkIdentInfos (AvailTC parent (n:nn) flds)+    -- Following the GHC convention that parent == n if parent is exported+    | n == parent+    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True+        | n <- nn ++ map flSelector flds+      ] +++      [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]+    where+        parentP = pack $ prettyPrint parent++mkIdentInfos (AvailTC _ nn flds)+    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True+        | n <- nn ++ map flSelector flds+      ]++createExportsMap :: [ModIface] -> ExportsMap+createExportsMap = ExportsMap . Map.fromListWith (<>) . concatMap doOne+  where+    doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mi_exports mi)+      where+        mn = moduleName $ mi_module mi++unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]+unpackAvail mod =+  map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))+    . mkIdentInfos

@@ -75,25 +75,25 @@ showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)  -- | Parser for the GHC output format-readSrcSpan :: ReadS SrcSpan+readSrcSpan :: ReadS RealSrcSpan readSrcSpan = readP_to_S (singleLineSrcSpanP <|> multiLineSrcSpanP)   where-    singleLineSrcSpanP, multiLineSrcSpanP :: ReadP SrcSpan+    singleLineSrcSpanP, multiLineSrcSpanP :: ReadP RealSrcSpan     singleLineSrcSpanP = do       fp <- filePathP       l  <- readS_to_P reads <* char ':'       c0 <- readS_to_P reads       c1 <- (char '-' *> readS_to_P reads) <|> pure c0-      let from = mkSrcLoc fp l c0-          to   = mkSrcLoc fp l c1-      return $ mkSrcSpan from to+      let from = mkRealSrcLoc fp l c0+          to   = mkRealSrcLoc fp l c1+      return $ mkRealSrcSpan from to      multiLineSrcSpanP = do       fp <- filePathP       s <- parensP (srcLocP fp)       void $ char '-'       e <- parensP (srcLocP fp)-      return $ mkSrcSpan s e+      return $ mkRealSrcSpan s e      parensP :: ReadP a -> ReadP a     parensP = between (char '(') (char ')')@@ -101,12 +101,12 @@     filePathP :: ReadP FastString     filePathP = fromString <$> (readFilePath <* char ':') <|> pure "" -    srcLocP :: FastString -> ReadP SrcLoc+    srcLocP :: FastString -> ReadP RealSrcLoc     srcLocP fp = do       l <- readS_to_P reads       void $ char ','       c <- readS_to_P reads-      return $ mkSrcLoc fp l c+      return $ mkRealSrcLoc fp l c      readFilePath :: ReadP FilePath     readFilePath = some ReadP.get

@@ -2,7 +2,12 @@ -- SPDX-License-Identifier: Apache-2.0  {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-} +{- HLINT ignore "Avoid restricted extensions" -}+ -- | Options module Development.IDE.Types.Options   ( IdeOptions(..)@@ -15,6 +20,11 @@   , defaultIdeOptions   , IdeResult   , IdeGhcSession(..)+  , LspConfig(..)+  , defaultLspConfig+  , CheckProject(..)+  , CheckParents(..)+  , OptHaddockParse(..)   ) where  import Development.Shake@@ -25,6 +35,8 @@ import qualified Data.Text as T import Development.IDE.Types.Diagnostics import Control.DeepSeq (NFData(..))+import Data.Aeson+import GHC.Generics  data IdeGhcSession = IdeGhcSession   { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])@@ -73,8 +85,46 @@     --   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 :: CheckProject+    -- ^ Whether to typecheck the entire project on load+  , optCheckParents :: CheckParents+    -- ^ When to typecheck reverse dependencies of a file+  , optHaddockParse :: OptHaddockParse+    -- ^ Whether to return result of parsing module with Opt_Haddock.+    --   Otherwise, return the result of parsing without Opt_Haddock, so+    --   that the parsed module contains the result of Opt_KeepRawTokenStream,+    --   which might be necessary for hlint.+  , optCustomDynFlags :: DynFlags -> DynFlags+    -- ^ If given, it will be called right after setting up a new cradle,+    --   allowing to customize the Ghc options used   } +data OptHaddockParse = HaddockParse | NoHaddockParse+  deriving (Eq,Ord,Show,Enum)++newtype CheckProject = CheckProject { shouldCheckProject :: Bool }+  deriving stock (Eq, Ord, Show)+  deriving newtype (FromJSON,ToJSON)+data CheckParents+    -- Note that ordering of constructors is meaningful and must be monotonically+    -- increasing in the scenarios where parents are checked+    = NeverCheck+    | CheckOnClose+    | CheckOnSaveAndClose+    | AlwaysCheck+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++data LspConfig+  = LspConfig+  { checkParents :: CheckParents+  , checkProject :: CheckProject+  } deriving stock (Eq, Ord, Show, Generic)+    deriving anyclass (FromJSON, ToJSON)++defaultLspConfig :: LspConfig+defaultLspConfig = LspConfig CheckOnSaveAndClose (CheckProject True)+ data IdePreprocessedSource = IdePreprocessedSource   { preprocWarnings :: [(GHC.SrcSpan, String)]     -- ^ Warnings emitted by the preprocessor.@@ -107,6 +157,10 @@     ,optKeywords = haskellKeywords     ,optDefer = IdeDefer True     ,optTesting = IdeTesting False+    ,optCheckProject = checkProject defaultLspConfig+    ,optCheckParents = checkParents defaultLspConfig+    ,optHaddockParse = HaddockParse+    ,optCustomDynFlags = id     }  

@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- HLINT ignore -}-module Testing ( module Testing ) where+module GotoHover ( module GotoHover) where import Data.Text (Text, pack) import Foo (Bar, foo) 

@@ -22,7 +22,7 @@ import Data.Maybe import Data.Rope.UTF16 (Rope) import qualified Data.Rope.UTF16 as Rope-import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)+import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent, PositionResult(..), positionResultToMaybe) import Development.IDE.Core.Shake (Q(..)) import Development.IDE.GHC.Util import qualified Data.Text as T@@ -54,6 +54,9 @@ import Test.Tasty.Ingredients.Rerun import Test.Tasty.HUnit import Test.Tasty.QuickCheck+import System.Time.Extra+import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId)+import Development.IDE.Plugin.Test (TestRequest(BlockSeconds,GetInterfaceFilesDir))  main :: IO () main = do@@ -74,7 +77,8 @@     , codeLensesTests     , outlineTests     , findDefinitionAndHoverTests-    , pluginTests+    , pluginSimpleTests+    , pluginParsedResultTests     , preprocessorTests     , thTests     , safeTests@@ -87,6 +91,9 @@     , nonLspCommandLine     , benchmarkTests     , ifaceTests+    , bootTests+    , rootUriTests+    , asyncTests     ]  initializeResponseTests :: TestTree@@ -124,7 +131,7 @@     , chk "NO doc link"               _documentLinkProvider  Nothing     , chk "NO color"                         _colorProvider (Just $ ColorOptionsStatic False)     , chk "NO folding range"          _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)-    , che "   execute command"      _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])+    , che "   execute command"      _executeCommandProvider (Just $ ExecuteCommandOptions $ List [typeSignatureCommandId, blockCommandId])     , chk "   workspace"                         _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))     , chk "NO experimental"                   _experimental  Nothing     ] where@@ -468,6 +475,53 @@             Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))           failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg       Lens.mapMOf_ offenders failure notification+  , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do+      liftIO $ writeFile (sessionDir </> "hie.yaml")+        "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}"+      let fooContent = T.unlines+            [ "module Foo where"+            , "foo = ()"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+          , [(DsWarning, (1, 0), "Top-level binding with no type signature:")+            ]+          )+        ]+  , testSessionWait "-Werror in pragma is ignored" $ do+      let fooContent = T.unlines+            [ "{-# OPTIONS_GHC -Wall -Werror #-}"+            , "module Foo() where"+            , "foo :: Int"+            , "foo = 1"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+          , [(DsWarning, (3, 0), "Defined but not used:")+            ]+          )+        ]+  , testCase "typecheck-all-parents-of-interest" $ withoutStackEnv $ runWithExtraFiles "recomp" $ \dir -> do+    let bPath = dir </> "B.hs"+        pPath = dir </> "P.hs"++    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int+    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int++    bdoc <- createDoc bPath "haskell" bSource+    _pdoc <- createDoc pPath "haskell" pSource+    expectDiagnostics [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) -- So that we know P has been loaded+                      ]++    -- Change y from Int to B which introduces a type error in A (imported from P)+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $+                    T.unlines ["module B where", "y :: Bool", "y = undefined"]]+    expectDiagnostics+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])+      ]+    expectNoMoreDiagnostics 2   ]  codeActionTests :: TestTree@@ -499,7 +553,7 @@ watchedFilesTests :: TestTree watchedFilesTests = testGroup "watched files"   [ testSession' "workspace files" $ \sessionDir -> do-      liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"+      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 @@ -512,7 +566,7 @@       liftIO $ length watchedFileRegs @?= 5    , testSession' "non workspace file" $ \sessionDir -> do-      liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"+      liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\", \"A\", \"WatchedFilesMissingModule\"]}}"       _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"       watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification @@ -1006,10 +1060,15 @@     , test False []         "f = quickCheck"              []                "import Test.QuickCheck (quickCheck)"     ]   , testGroup "want suggestion"-    [ test True []          "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"+    [ wantWait  []          "f = foo"                     []                "import Foo (foo)"+    , wantWait  []          "f = Bar"                     []                "import Bar (Bar(Bar))"+    , wantWait  []          "f :: Bar"                    []                "import Bar (Bar)"+    , test True []          "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"     , test True []          "f = (:|)"                    []                "import Data.List.NonEmpty (NonEmpty((:|)))"     , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural (Natural)"+    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural"     , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty (NonEmpty)"+    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty"     , test True []          "f = First"                   []                "import Data.Monoid (First(First))"     , test True []          "f = Endo"                    []                "import Data.Monoid (Endo(Endo))"     , test True []          "f = Version"                 []                "import Data.Version (Version(Version))"@@ -1017,9 +1076,12 @@     , test True []          "f = AssertionFailed"         []                "import Control.Exception (AssertionFailed(AssertionFailed))"     , test True ["Prelude"] "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"     , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative (Alternative)"+    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative"     , test True []          "f = empty"                   []                "import Control.Applicative (Alternative(empty))"+    , test True []          "f = empty"                   []                "import Control.Applicative"     , test True []          "f = (&)"                     []                "import Data.Function ((&))"     , test True []          "f = NE.nonEmpty"             []                "import qualified Data.List.NonEmpty as NE"+    , test True []          "f = Data.List.NonEmpty.nonEmpty" []            "import qualified Data.List.NonEmpty"     , test True []          "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable (Typeable)"     , test True []          "f = pack"                    []                "import Data.Text (pack)"     , test True []          "f :: Text"                   ["f = undefined"] "import Data.Text (Text)"@@ -1028,13 +1090,18 @@     ]   ]   where-    test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do+    test = test' False+    wantWait = test' True True+    test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do       let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other           after  = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other-          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, GotoHover]}}"       liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle       doc <- createDoc "Test.hs" "haskell" before+      void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)       _diags <- waitForDiagnostics+      -- there isn't a good way to wait until the whole project is checked atm+      when waitForCheckProject $ liftIO $ sleep 0.5       let defLine = length imps + 1           range = Range (Position defLine 0) (Position defLine maxBound)       actions <- getCodeActions doc range@@ -1201,6 +1268,91 @@         , ""         , "some = ()"       ])+  , testSession "delete unused binding in where clause" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (h, g) where"+               , ""+               , "h :: Int"+               , "h = 3"+               , ""+               , "g :: Int"+               , "g = 6"+               , "  where"+               , "    h :: Int"+               , "    h = 4"+               , ""+               ])+    (10, 4)+    "Delete ‘h’"+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (h, g) where"+               , ""+               , "h :: Int"+               , "h = 3"+               , ""+               , "g :: Int"+               , "g = 6"+               , "  where"+               , ""+               ])+  , testSession "delete unused binding with multi-oneline signatures front" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (b, c) where"+               , ""+               , "a, b, c :: Int"+               , "a = 3"+               , "b = 4"+               , "c = 5"+               ])+    (4, 0)+    "Delete ‘a’"+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (b, c) where"+               , ""+               , "b, c :: Int"+               , "b = 4"+               , "c = 5"+               ])+  , testSession "delete unused binding with multi-oneline signatures mid" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (a, c) where"+               , ""+               , "a, b, c :: Int"+               , "a = 3"+               , "b = 4"+               , "c = 5"+               ])+    (5, 0)+    "Delete ‘b’"+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (a, c) where"+               , ""+               , "a, c :: Int"+               , "a = 3"+               , "c = 5"+               ])+  , testSession "delete unused binding with multi-oneline signatures end" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (a, b) where"+               , ""+               , "a, b, c :: Int"+               , "a = 3"+               , "b = 4"+               , "c = 5"+               ])+    (6, 0)+    "Delete ‘c’"+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (a, b) where"+               , ""+               , "a, b :: Int"+               , "a = 3"+               , "b = 4"+               ])   ]   where     testFor source pos expectedTitle expectedResult = do@@ -1384,6 +1536,9 @@       , "bar :: Int -> Int -> String"       , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ")  where"       , "  localConvert = (flip replicate) 'x'"+      , ""+      , "foo :: () -> Int -> String"+      , "foo = undefined"      ] @@ -1402,32 +1557,35 @@     liftIO $ expectedCode @=? modifiedCode   in   testGroup "fill typed holes"-  [ check "replace hole `_` with show"+  [ check "replace _ with show"           "_"    "n" "n"           "show" "n" "n" -  , check "replace hole `_` with globalConvert"+  , check "replace _ with globalConvert"           "_"             "n" "n"           "globalConvert" "n" "n"  #if MIN_GHC_API_VERSION(8,6,0)-  , check "replace hole `_convertme` with localConvert"+  , check "replace _convertme with localConvert"           "_convertme"   "n" "n"           "localConvert" "n" "n" #endif -  , check "replace hole `_b` with globalInt"+  , check "replace _b with globalInt"           "_a" "_b"        "_c"           "_a" "globalInt" "_c" -  , check "replace hole `_c` with globalInt"+  , check "replace _c with globalInt"           "_a" "_b"        "_c"           "_a" "_b" "globalInt"  #if MIN_GHC_API_VERSION(8,6,0)-  , check "replace hole `_c` with parameterInt"+  , check "replace _c with parameterInt"           "_a" "_b" "_c"           "_a" "_b"  "parameterInt"+  , check "replace _ with foo _"+          "_" "n" "n"+          "(foo _)" "n" "n" #endif   ] @@ -1672,8 +1830,8 @@         Nothing -- codeaction should not be available     , testSession "not top-level" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" -              , "{-# OPTIONS_GHC -Wunused-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# OPTIONS_GHC -Wunused-binds #-}"               , "module A (foo,bar) where"               , "foo = ()"               , "  where bar = ()"@@ -1708,26 +1866,26 @@         (R 3 0 3 3)         "Export ‘foo’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A ("               , "foo) where"               , "foo = id"])     , testSession "single line explicit exports" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A (foo) where"               , "foo = id"               , "bar = foo"])         (R 3 0 3 3)         "Export ‘bar’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A (foo,bar) where"               , "foo = id"               , "bar = foo"])     , testSession "multi line explicit exports" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A"               , "  ("               , "    foo) where"@@ -1736,7 +1894,7 @@         (R 5 0 5 3)         "Export ‘bar’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A"               , "  ("               , "    foo,bar) where"@@ -1744,7 +1902,7 @@               , "bar = foo"])     , testSession "export list ends in comma" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A"               , "  (foo,"               , "  ) where"@@ -1753,7 +1911,7 @@         (R 4 0 4 3)         "Export ‘bar’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A"               , "  (foo,"               , "  bar) where"@@ -1761,83 +1919,83 @@               , "bar = foo"])     , testSession "unused pattern synonym" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" -              , "{-# LANGUAGE PatternSynonyms #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE PatternSynonyms #-}"               , "module A () where"               , "pattern Foo a <- (a, _)"])         (R 3 0 3 10)         "Export ‘Foo’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" -              , "{-# LANGUAGE PatternSynonyms #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE PatternSynonyms #-}"               , "module A (pattern Foo) where"               , "pattern Foo a <- (a, _)"])     , testSession "unused data type" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A () where"               , "data Foo = Foo"])         (R 2 0 2 7)         "Export ‘Foo’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A (Foo(..)) where"               , "data Foo = Foo"])     , testSession "unused newtype" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A () where"               , "newtype Foo = Foo ()"])         (R 2 0 2 10)         "Export ‘Foo’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A (Foo(..)) where"               , "newtype Foo = Foo ()"])     , testSession "unused type synonym" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A () where"               , "type Foo = ()"])         (R 2 0 2 7)         "Export ‘Foo’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A (Foo) where"               , "type Foo = ()"])     , testSession "unused type family" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" -              , "{-# LANGUAGE TypeFamilies #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeFamilies #-}"               , "module A () where"               , "type family Foo p"])         (R 3 0 3 15)         "Export ‘Foo’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" -              , "{-# LANGUAGE TypeFamilies #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeFamilies #-}"               , "module A (Foo(..)) where"               , "type family Foo p"])     , testSession "unused typeclass" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A () where"               , "class Foo a"])         (R 2 0 2 8)         "Export ‘Foo’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A (Foo(..)) where"               , "class Foo a"])     , testSession "infix" $ template         (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A () where"               , "a `f` b = ()"])         (R 2 0 2 11)         "Export ‘f’"         (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" +              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A (f) where"               , "a `f` b = ()"])     ]@@ -2032,7 +2190,7 @@   lstL43 = Position 47 12  ;  litL   = [ExpectHoverText ["[8391 :: Int, 6268]"]]   outL45 = Position 49  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]   innL48 = Position 52  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]-  cccL17 = Position 17 11  ;  docLink = [ExpectHoverText ["[Documentation](file://"]]+  cccL17 = Position 17 11  ;  docLink = [ExpectHoverText ["[Documentation](file:///"]] #if MIN_GHC_API_VERSION(8,6,0)   imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]   reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]@@ -2067,7 +2225,7 @@   , test  yes    yes    mclL36     mcl           "top-level fn 1st clause"   , test  yes    yes    mclL37     mcl           "top-level fn 2nd clause         #246"   , test  yes    yes    spaceL37   space        "top-level fn on space #315"-  , test  no     broken docL41     doc           "documentation                     #7"+  , test  no     yes    docL41     doc           "documentation                     #7"   , test  no     yes    eitL40     kindE         "kind of Either                  #273"   , test  no     yes    intL40     kindI         "kind of Int                     #273"   , test  no     broken tvrL40     kindV         "kind of (* -> *) type variable  #273"@@ -2093,30 +2251,43 @@     void (openTestDataDoc (dir </> fp))     expectNoMoreDiagnostics 0.5 -+pluginSimpleTests :: TestTree+pluginSimpleTests = +  testSessionWait "simple plugin" $ do+    let content =+          T.unlines+            [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"+            , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}"+            , "module Testing where"+            , "import Data.Proxy"+            , "import GHC.TypeLits"+            -- This function fails without plugins being initialized.+            , "f :: forall n. KnownNat n => Proxy n -> Integer"+            , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))"+            , "foo :: Int -> Int -> Int"+            , "foo a b = a + c"+            ]+    _ <- createDoc "Testing.hs" "haskell" content+    expectDiagnostics+      [ ( "Testing.hs",+          [(DsError, (8, 14), "Variable not in scope: c")]+          )+      ] -pluginTests :: TestTree-pluginTests = (`xfail8101` "known broken (#556)")-            $ testSessionWait "plugins" $ do-  let content =-        T.unlines-          [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"-          , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}"-          , "module Testing where"-          , "import Data.Proxy"-          , "import GHC.TypeLits"-          -- This function fails without plugins being initialized.-          , "f :: forall n. KnownNat n => Proxy n -> Integer"-          , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))"-          , "foo :: Int -> Int -> Int"-          , "foo a b = a + c"-          ]-  _ <- createDoc "Testing.hs" "haskell" content-  expectDiagnostics-    [ ( "Testing.hs",-        [(DsError, (8, 14), "Variable not in scope: c")]-      )-    ]+pluginParsedResultTests :: TestTree +pluginParsedResultTests = +  (`xfail84` "record-dot-preprocessor unsupported on 8.4") $ testSessionWait "parsedResultAction plugin" $ do +    let content = +          T.unlines +            [ "{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}"+            , "{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}"+            , "module Testing (Company(..), display) where"+            , "data Company = Company {name :: String}"+            , "display :: Company -> String"+            , "display c = c.name"+            ]+    _ <- createDoc "Testing.hs" "haskell" content +    expectNoMoreDiagnostics 1  cppTests :: TestTree cppTests =@@ -2260,6 +2431,7 @@ -- | test that TH is reevaluated on typecheck thReloadingTest :: TestTree thReloadingTest = testCase "reloading-th-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \dir -> do+     let aPath = dir </> "THA.hs"         bPath = dir </> "THB.hs"         cPath = dir </> "THC.hs"@@ -2302,6 +2474,7 @@ completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, Bool, Bool)] -> TestTree completionTest name src pos expected = testSessionWait name $ do     docId <- createDoc "A.hs" "haskell" (T.unlines src)+    _ <- waitForDiagnostics     compls <- getCompletions docId pos     let compls' = [ (_label, _kind) | CompletionItem{..} <- compls]     liftIO $ do@@ -2576,11 +2749,11 @@ xfail :: TestTree -> String -> TestTree xfail = flip expectFailBecause -xfail8101 :: TestTree -> String -> TestTree-#if MIN_GHC_API_VERSION(8,10,0)-xfail8101 = flip expectFailBecause+xfail84 :: TestTree -> String -> TestTree+#if MIN_GHC_API_VERSION(8,6,0)+xfail84 t _ = t #else-xfail8101 t _ = t+xfail84 = flip expectFailBecause #endif  expectFailCabal :: String -> TestTree -> TestTree@@ -2666,6 +2839,7 @@ cradleTests :: TestTree cradleTests = testGroup "cradle"     [testGroup "dependencies" [sessionDepsArePickedUp]+    ,testGroup "ignore-fatal" [ignoreFatalWarning]     ,testGroup "loading" [loadCradleOnlyonce]     ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2]     ]@@ -2755,6 +2929,13 @@         restore var Nothing = unsetEnv var         restore var (Just val) = setEnv var val True +ignoreFatalWarning :: TestTree+ignoreFatalWarning = testCase "ignore-fatal-warning" $ withoutStackEnv $ runWithExtraFiles "ignore-fatal" $ \dir -> do+    let srcPath = dir </> "IgnoreFatal.hs"+    src <- liftIO $ readFileUtf8 srcPath+    _ <- createDoc srcPath "haskell" src+    expectNoMoreDiagnostics 5+ simpleMultiTest :: TestTree simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do     let aPath = dir </> "a/A.hs"@@ -2777,11 +2958,11 @@         bPath = dir </> "b/B.hs"     bSource <- liftIO $ readFileUtf8 bPath     bdoc <- createDoc bPath "haskell" bSource-    expectNoMoreDiagnostics 5+    expectNoMoreDiagnostics 10     aSource <- liftIO $ readFileUtf8 aPath     (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource     -- Need to have some delay here or the test fails-    expectNoMoreDiagnostics 6+    expectNoMoreDiagnostics 10     locs <- getDefinitions bdoc (Position 2 7)     let fooL = mkL adoc 2 0 2 3     checkDefs locs (pure [fooL])@@ -2796,6 +2977,22 @@     , ifaceTHTest     ] +bootTests :: TestTree+bootTests = testCase "boot-def-test" $ withoutStackEnv $ runWithExtraFiles "boot" $ \dir -> do+  let cPath = dir </> "C.hs"+  cSource <- liftIO $ readFileUtf8 cPath++  -- Dirty the cache+  liftIO $ runInDir dir $ do+    cDoc <- createDoc cPath "haskell" cSource+    _ <- getHover cDoc $ Position 4 3+    closeDoc cDoc++  cdoc <- createDoc cPath "haskell" cSource+  locs <- getDefinitions cdoc (Position 7 4)+  let floc = mkR 7 0 7 1+  checkDefs locs (pure [floc])+ -- | test that TH reevaluates across interfaces ifaceTHTest :: TestTree ifaceTHTest = testCase "iface-th-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \dir -> do@@ -2821,28 +3018,42 @@  ifaceErrorTest :: TestTree ifaceErrorTest = testCase "iface-error-test-1" $ withoutStackEnv $ runWithExtraFiles "recomp" $ \dir -> do-    let aPath = dir </> "A.hs"-        bPath = dir </> "B.hs"+    let bPath = dir </> "B.hs"         pPath = dir </> "P.hs" -    aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int     bSource <- liftIO $ readFileUtf8 bPath -- y :: Int     pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int      bdoc <- createDoc bPath "haskell" bSource-    pdoc <- createDoc pPath "haskell" pSource     expectDiagnostics [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) -- So what we know P has been loaded                       ]      -- 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)      -- Check that the error propogates to A-    adoc <- createDoc aPath "haskell" aSource     expectDiagnostics       [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])]-    closeDoc adoc -- Close A ++    -- Check that we wrote the interfaces for B when we saved+    lid <- sendRequest (CustomClientMethod "hidir") $ GetInterfaceFilesDir bPath+    res <- skipManyTill (message :: Session WorkDoneProgressCreateRequest) $+           skipManyTill (message :: Session WorkDoneProgressBeginNotification) $+             responseForId lid+    liftIO $ case res of+      ResponseMessage{_result=Right hidir} -> do+        hi_exists <- doesFileExist $ hidir </> "B.hi"+        assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists+#if MIN_GHC_API_VERSION(8,6,0)+        hie_exists <- doesFileExist $ hidir </> "B.hie"+        assertBool ("Couldn't find B.hie in " ++ hidir) hie_exists+#endif+      _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res++    pdoc <- createDoc pPath "haskell" pSource     changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]     -- Now in P we have     -- bar = x :: Int@@ -2887,6 +3098,7 @@       ,("P.hs", [(DsWarning,(4,0), "Top-level binding")])       ,("P.hs", [(DsWarning,(6,0), "Top-level binding")])       ]+     expectNoMoreDiagnostics 2  ifaceErrorTest3 :: TestTree@@ -2980,9 +3192,51 @@         , Bench.name e /= "edit" -- the edit experiment does not ever fail     ] +-- | checks if we use InitializeParams.rootUri for loading session+rootUriTests :: TestTree+rootUriTests = testCase "use rootUri" . withoutStackEnv . runTest "dirA" "dirB" $ \dir -> do+  let bPath = dir </> "dirB/Foo.hs"+  liftIO $ copyTestDataFiles dir "rootUri"+  bSource <- liftIO $ readFileUtf8 bPath+  _ <- createDoc "Foo.hs" "haskell" bSource+  expectNoMoreDiagnostics 0.5+  where+    -- similar to run' except we can configure where to start ghcide and session+    runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()+    runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 (s dir)++-- | Test if ghcide asynchronously handles Commands and user Requests+asyncTests :: TestTree+asyncTests = testGroup "async"+    [+      testSession "command" $ do+            -- Execute a command that will block forever+            let req = ExecuteCommandParams blockCommandId Nothing Nothing+            void $ sendRequest WorkspaceExecuteCommand 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 #-}"+              , "foo = id"+              ]+            void waitForDiagnostics+            actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))+            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]+    , testSession "request" $ do+            -- Execute a custom request that will block for 1000 seconds+            void $ sendRequest (CustomClientMethod "test") $ 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 #-}"+              , "foo = id"+              ]+            void waitForDiagnostics+            actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0))+            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]+    ]+ ---------------------------------------------------------------------- -- Utils-+----------------------------------------------------------------------  testSession :: String -> Session () -> TestTree testSession name = testCase name . run@@ -3022,7 +3276,7 @@ mkRange a b c d = Range (Position a b) (Position c d)  run :: Session a -> IO a-run s = withTempDir $ \dir -> runInDir dir s+run s = run' (const s)  runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a runWithExtraFiles prefix s = withTempDir $ \dir -> do@@ -3041,27 +3295,39 @@ run' s = withTempDir $ \dir -> runInDir dir (s dir)  runInDir :: FilePath -> Session a -> IO a-runInDir dir s = do+runInDir dir = runInDir' dir "." "."++-- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root.+runInDir' :: FilePath -> FilePath -> FilePath -> Session a -> IO a+runInDir' dir startExeIn startSessionIn s = do   ghcideExe <- locateGhcideExecutable+  let startDir = dir </> startExeIn+  let projDir = dir </> startSessionIn +  createDirectoryIfMissing True startDir+  createDirectoryIfMissing True projDir   -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56   -- since the package import test creates "Data/List.hs", which otherwise has no physical home-  createDirectoryIfMissing True $ dir ++ "/Data"-+  createDirectoryIfMissing True $ projDir ++ "/Data" -  let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]+  let cmd = unwords [ghcideExe, "--lsp", "--test", "--verbose", "--cwd", startDir]   -- HIE calls getXgdDirectory which assumes that HOME is set.   -- Only sets HOME if it wasn't already set.   setEnv "HOME" "/homeless-shelter" False   let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }-  runSessionWithConfig conf cmd lspTestCaps dir s+  logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"+  runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s   where+    checkEnv :: String -> IO (Maybe Bool)+    checkEnv s = fmap convertVal <$> getEnv s+    convertVal "0" = False+    convertVal _ = True+     conf = defaultConfig-      -- If you uncomment this you can see all logging-      -- which can be quite useful for debugging.-    --   { logStdErr = True, logColor = False }-      -- If you really want to, you can also see all messages-    --   { logMessages = True, logColor = False }+      -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging+    --   { logStdErr = True }+    --   uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages+    --   { logMessages = True }  openTestDataDoc :: FilePath -> Session TextDocumentIdentifier openTestDataDoc path = do@@ -3123,94 +3389,94 @@                 toCurrent                     (Range (Position 0 1) (Position 0 3))                     "ab"-                    (Position 0 0) @?= Just (Position 0 0)+                    (Position 0 0) @?= PositionExact (Position 0 0)               , testCase "after, same line, same length" $                 toCurrent                     (Range (Position 0 1) (Position 0 3))                     "ab"-                    (Position 0 3) @?= Just (Position 0 3)+                    (Position 0 3) @?= PositionExact (Position 0 3)               , testCase "after, same line, increased length" $                 toCurrent                     (Range (Position 0 1) (Position 0 3))                     "abc"-                    (Position 0 3) @?= Just (Position 0 4)+                    (Position 0 3) @?= PositionExact (Position 0 4)               , testCase "after, same line, decreased length" $                 toCurrent                     (Range (Position 0 1) (Position 0 3))                     "a"-                    (Position 0 3) @?= Just (Position 0 2)+                    (Position 0 3) @?= PositionExact (Position 0 2)               , testCase "after, next line, no newline" $                 toCurrent                     (Range (Position 0 1) (Position 0 3))                     "abc"-                    (Position 1 3) @?= Just (Position 1 3)+                    (Position 1 3) @?= PositionExact (Position 1 3)               , testCase "after, next line, newline" $                 toCurrent                     (Range (Position 0 1) (Position 0 3))                     "abc\ndef"-                    (Position 1 0) @?= Just (Position 2 0)+                    (Position 1 0) @?= PositionExact (Position 2 0)               , testCase "after, same line, newline" $                 toCurrent                     (Range (Position 0 1) (Position 0 3))                     "abc\nd"-                    (Position 0 4) @?= Just (Position 1 2)+                    (Position 0 4) @?= PositionExact (Position 1 2)               , testCase "after, same line, newline + newline at end" $                 toCurrent                     (Range (Position 0 1) (Position 0 3))                     "abc\nd\n"-                    (Position 0 4) @?= Just (Position 2 1)+                    (Position 0 4) @?= PositionExact (Position 2 1)               , testCase "after, same line, newline + newline at end" $                 toCurrent                     (Range (Position 0 1) (Position 0 1))                     "abc"-                    (Position 0 1) @?= Just (Position 0 4)+                    (Position 0 1) @?= PositionExact (Position 0 4)               ]         , testGroup "fromCurrent"               [ testCase "before" $                 fromCurrent                     (Range (Position 0 1) (Position 0 3))                     "ab"-                    (Position 0 0) @?= Just (Position 0 0)+                    (Position 0 0) @?= PositionExact (Position 0 0)               , testCase "after, same line, same length" $                 fromCurrent                     (Range (Position 0 1) (Position 0 3))                     "ab"-                    (Position 0 3) @?= Just (Position 0 3)+                    (Position 0 3) @?= PositionExact (Position 0 3)               , testCase "after, same line, increased length" $                 fromCurrent                     (Range (Position 0 1) (Position 0 3))                     "abc"-                    (Position 0 4) @?= Just (Position 0 3)+                    (Position 0 4) @?= PositionExact (Position 0 3)               , testCase "after, same line, decreased length" $                 fromCurrent                     (Range (Position 0 1) (Position 0 3))                     "a"-                    (Position 0 2) @?= Just (Position 0 3)+                    (Position 0 2) @?= PositionExact (Position 0 3)               , testCase "after, next line, no newline" $                 fromCurrent                     (Range (Position 0 1) (Position 0 3))                     "abc"-                    (Position 1 3) @?= Just (Position 1 3)+                    (Position 1 3) @?= PositionExact (Position 1 3)               , testCase "after, next line, newline" $                 fromCurrent                     (Range (Position 0 1) (Position 0 3))                     "abc\ndef"-                    (Position 2 0) @?= Just (Position 1 0)+                    (Position 2 0) @?= PositionExact (Position 1 0)               , testCase "after, same line, newline" $                 fromCurrent                     (Range (Position 0 1) (Position 0 3))                     "abc\nd"-                    (Position 1 2) @?= Just (Position 0 4)+                    (Position 1 2) @?= PositionExact (Position 0 4)               , testCase "after, same line, newline + newline at end" $                 fromCurrent                     (Range (Position 0 1) (Position 0 3))                     "abc\nd\n"-                    (Position 2 1) @?= Just (Position 0 4)+                    (Position 2 1) @?= PositionExact (Position 0 4)               , testCase "after, same line, newline + newline at end" $                 fromCurrent                     (Range (Position 0 1) (Position 0 1))                     "abc"-                    (Position 0 4) @?= Just (Position 0 1)+                    (Position 0 4) @?= PositionExact (Position 0 1)               ]         , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"               [ testProperty "fromCurrent r t <=< toCurrent r t" $ do@@ -3226,9 +3492,9 @@                         pure (range, replacement, oldPos)                 forAll                     (suchThatMap gen-                        (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $+                        (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $                     \(range, replacement, oldPos, newPos) ->-                    fromCurrent range replacement newPos === Just oldPos+                    fromCurrent range replacement newPos === PositionExact oldPos               , testProperty "toCurrent r t <=< fromCurrent r t" $ do                 let gen = do                         rope <- genRope@@ -3239,9 +3505,9 @@                         pure (range, replacement, newPos)                 forAll                     (suchThatMap gen-                        (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $+                        (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $                     \(range, replacement, newPos, oldPos) ->-                    toCurrent range replacement oldPos === Just newPos+                    toCurrent range replacement oldPos === PositionExact newPos               ]         ] 

@@ -70,9 +70,9 @@             "Got unexpected diagnostics for " <> show fileUri <>             " got " <> show actual     handleCustomMethodResponse =-        -- the CustomClientMethod triggers a log message about ignoring it+        -- the CustomClientMethod triggers a RspCustomServer         -- handle that and then exit-        void (LspTest.message :: Session LogMessageNotification)+        void (LspTest.message :: Session CustomResponse)     ignoreOthers = void anyMessage >> handleMessages  expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()