ghcide 1.3.0.0 → 1.4.0.1

raw patch · 53 files changed

+1410/−871 lines, 53 filesdep +ghc-api-compatdep ~ghc-checkdep ~hie-compatdep ~hiedbPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-api-compat

Dependency ranges changed: ghc-check, hie-compat, hiedb, hls-graph

API changes (from Hackage documentation)

Files

• bench/lib/Experiments.hs +1/−1
• exe/Main.hs +1/−1
• ghcide.cabal +7/−6
• session-loader/Development/IDE/Session.hs +29/−36
• src/Control/Concurrent/Strict.hs +4/−4
• src/Development/IDE.hs +3/−3
• src/Development/IDE/Core/Actions.hs +2/−2
• src/Development/IDE/Core/Compile.hs +44/−7
• src/Development/IDE/Core/Debouncer.hs +4/−4
• src/Development/IDE/Core/FileExists.hs +14/−17
• src/Development/IDE/Core/FileStore.hs +124/−71
• src/Development/IDE/Core/IdeConfiguration.hs +1/−1
• src/Development/IDE/Core/OfInterest.hs +37/−21
• src/Development/IDE/Core/Preprocessor.hs +3/−3
• src/Development/IDE/Core/RuleTypes.hs +8/−9
• src/Development/IDE/Core/Rules.hs +30/−12
• src/Development/IDE/Core/Service.hs +1/−1
• src/Development/IDE/Core/Shake.hs +57/−18
• src/Development/IDE/Core/Tracing.hs +12/−7
• src/Development/IDE/Core/UseStale.hs +15/−11
• src/Development/IDE/GHC/CPP.hs +3/−4
• src/Development/IDE/GHC/Compat.hs +325/−44
• src/Development/IDE/GHC/Error.hs +12/−9
• src/Development/IDE/GHC/ExactPrint.hs +42/−38
• src/Development/IDE/GHC/Orphans.hs +18/−6
• src/Development/IDE/GHC/Util.hs +13/−11
• src/Development/IDE/GHC/Warnings.hs +6/−4
• src/Development/IDE/Import/FindImports.hs +4/−4
• src/Development/IDE/LSP/LanguageServer.hs +1/−2
• src/Development/IDE/LSP/Notifications.hs +20/−43
• src/Development/IDE/LSP/Outline.hs +31/−20
• src/Development/IDE/Main.hs +30/−18
• src/Development/IDE/Plugin.hs +6/−4
• src/Development/IDE/Plugin/CodeAction.hs +66/−73
• src/Development/IDE/Plugin/CodeAction/Args.hs +185/−212
• src/Development/IDE/Plugin/Completions.hs +6/−2
• src/Development/IDE/Plugin/Completions/Logic.hs +8/−4
• src/Development/IDE/Plugin/HLS.hs +11/−6
• src/Development/IDE/Plugin/HLS/GhcIde.hs +4/−1
• src/Development/IDE/Plugin/Test.hs +6/−4
• src/Development/IDE/Plugin/TypeLenses.hs +1/−2
• src/Development/IDE/Spans/AtPoint.hs +30/−9
• src/Development/IDE/Spans/Common.hs +4/−2
• src/Development/IDE/Spans/Documentation.hs +10/−12
• src/Development/IDE/Spans/LocalBindings.hs +13/−8
• src/Development/IDE/Types/Action.hs +1/−1
• src/Development/IDE/Types/HscEnvEq.hs +6/−11
• src/Development/IDE/Types/Options.hs +8/−6
• src/Development/IDE/Types/Shake.hs +23/−6
• src/Generics/SYB/GHC.hs +9/−9
• test/exe/Main.hs +102/−52
• test/exe/Progress.hs +2/−2
• test/src/Development/IDE/Test.hs +7/−7

@@ -204,7 +204,7 @@     <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")     <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal")                <*> (some moduleOption <|> pure ["Distribution/Simple.hs"])-               <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0]))+               <*> option versionP (long "example-package-version" <> value (makeVersion [3,4,0,0]))          <|>           UsePackage <$> strOption (long "example-path")                      <*> some moduleOption

@@ -22,11 +22,11 @@                                                     Priority (Info), action) import           Development.IDE.Core.OfInterest   (kick) import           Development.IDE.Core.Rules        (mainRule)+import           Development.IDE.Graph             (ShakeOptions (shakeThreads)) import qualified Development.IDE.Main              as Main import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import qualified Development.IDE.Plugin.Test       as Test import           Development.IDE.Types.Options-import           Development.IDE.Graph                 (ShakeOptions (shakeThreads)) import           Ide.Plugin.Config                 (Config (checkParents, checkProject)) import           Ide.Plugin.ConfigUtils            (pluginsToDefaultConfig,                                                     pluginsToVSCodeExtensionSchema)

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            1.3.0.0+version:            1.4.0.1 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/haskell-language-server/tree/master/ghcide#readme bug-reports:        https://github.com/haskell/haskell-language-server/issues-tested-with:        GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4+tested-with:        GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 || == 8.10.5 || == 9.0.1 extra-source-files: README.md CHANGELOG.md                     test/data/**/*.project                     test/data/**/*.cabal@@ -56,10 +56,10 @@         Glob,         haddock-library >= 1.8 && < 1.11,         hashable,-        hie-compat ^>= 0.1.0.0,+        hie-compat ^>= 0.2.0.0,         hls-plugin-api ^>= 1.1.0.0,         lens,-        hiedb == 0.3.0.1,+        hiedb == 0.3.0.*,         lsp-types == 1.2.*,         lsp == 1.2.*,         mtl,@@ -73,7 +73,7 @@         rope-utf16-splay,         safe,         safe-exceptions,-        hls-graph ^>= 1.3,+        hls-graph ^>= 1.4,         sorted-list,         sqlite-simple,         stm,@@ -95,8 +95,9 @@         ghc-boot-th,         ghc-boot,         ghc >= 8.6,-        ghc-check >=0.5.0.1,+        ghc-check >=0.5.0.4,         ghc-paths,+        ghc-api-compat,         cryptohash-sha1 >=0.11.100 && <0.12,         hie-bios >= 0.7.1 && < 0.8.0,         implicit-hie-cradle >= 0.3.0.2 && < 0.4,

@@ -78,16 +78,15 @@ import           Linker import           Module import           NameCache-import           Packages  import           Control.Concurrent.STM               (atomically) import           Control.Concurrent.STM.TQueue import qualified Data.HashSet                         as Set import           Database.SQLite.Simple-import           GHC.LanguageExtensions               (Extension (EmptyCase)) import           HieDb.Create import           HieDb.Types import           HieDb.Utils+import           Ide.Types                            (dynFlagsModifyGlobal)  -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String@@ -107,8 +106,8 @@   --   or 'Nothing' to respect the cradle setting   , getCacheDirs           :: String -> [String] -> IO CacheDirs   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'-  , getInitialGhcLibDir    :: IO (Maybe LibDir)-  , fakeUid                :: InstalledUnitId+  , getInitialGhcLibDir    :: FilePath -> IO (Maybe LibDir)+  , fakeUid                :: GHC.InstalledUnitId     -- ^ unit id used to tag the internal component built by ghcide     --   To reuse external interface files the unit ids must match,     --   thus make sure to build them with `--this-unit-id` set to the@@ -121,7 +120,7 @@         ,loadCradle = loadWithImplicitCradle         ,getCacheDirs = getCacheDirsDefault         ,getInitialGhcLibDir = getInitialGhcLibDirDefault-        ,fakeUid = toInstalledUnitId (stringToUnitId "main")+        ,fakeUid = GHC.toInstalledUnitId (GHC.stringToUnit "main")         }  -- | Find the cradle for a given 'hie.yaml' configuration.@@ -141,31 +140,29 @@                           -- if no 'hie.yaml' location is given.                           -> IO (HieBios.Cradle Void) loadWithImplicitCradle mHieYaml rootDir = do-  crdl       <- case mHieYaml of+  case mHieYaml of     Just yaml -> HieBios.loadCradle yaml-    Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir-  return crdl+    Nothing   -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir -getInitialGhcLibDirDefault :: IO (Maybe LibDir)-getInitialGhcLibDirDefault = do-  dir <- IO.getCurrentDirectory-  hieYaml <- findCradle def dir-  cradle <- loadCradle def hieYaml dir+getInitialGhcLibDirDefault :: FilePath -> IO (Maybe LibDir)+getInitialGhcLibDirDefault rootDir = do+  hieYaml <- findCradle def rootDir+  cradle <- loadCradle def hieYaml rootDir   hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle   libDirRes <- getRuntimeGhcLibDir cradle   case libDirRes of       CradleSuccess libdir -> pure $ Just $ LibDir libdir       CradleFail err -> do-        hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,dir,hieYaml,cradle)+        hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,rootDir,hieYaml,cradle)         pure Nothing       CradleNone -> do         hPutStrLn stderr "Couldn't load cradle (CradleNone)"         pure Nothing  -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir-setInitialDynFlags :: SessionLoadingOptions -> IO (Maybe LibDir)-setInitialDynFlags SessionLoadingOptions{..} = do-  libdir <- getInitialGhcLibDir+setInitialDynFlags :: FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)+setInitialDynFlags rootDir SessionLoadingOptions{..} = do+  libdir <- getInitialGhcLibDir rootDir   dynFlags <- mapM dynFlagsForPrinting libdir   mapM_ setUnsafeGlobalDynFlags dynFlags   pure libdir@@ -236,8 +233,6 @@   -- Version of the mappings above   version <- newVar 0   let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)-  let invalidateShakeCache = do-        void $ modifyVar' version succ   -- This caches the mapping from Mod.hs -> hie.yaml   cradleLoc <- liftIO $ memoIO $ \v -> do       res <- findCradle v@@ -253,10 +248,13 @@   return $ do     extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv                       } <- getShakeExtras+    let invalidateShakeCache = do+            void $ modifyVar' version succ+            recordDirtyKeys extras GhcSessionIO [emptyFilePath]      IdeOptions{ optTesting = IdeTesting optTesting               , optCheckProject = getCheckProject-              , optCustomDynFlags+              , optModifyDynFlags               , optExtensions               } <- getIdeOptions @@ -287,7 +285,7 @@           -- Parse DynFlags for the newly discovered component           hscEnv <- emptyHscEnv ideNc libDir           (df, targets) <- evalGhcEnv hscEnv $-              first optCustomDynFlags <$> setOptions opts (hsc_dflags hscEnv)+              first (dynFlagsModifyGlobal optModifyDynFlags) <$> 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@@ -423,6 +421,7 @@              logWarning logger $ implicitCradleWarning lfp             cradle <- loadCradle hieYaml dir+           lfp <- flip makeRelative cfp <$> getCurrentDirectory             when optTesting $ mRunLspT lspEnv $             sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp)@@ -527,7 +526,11 @@ emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do     env <- runGhc (Just libDir) getSession+#if !MIN_VERSION_ghc(9,0,0)+    -- This causes ghc9 to crash with the error:+    -- Couldn't find a target code interpreter. Try with -fexternal-interpreter     initDynLinker env+#endif     pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } }  data TargetDetails = TargetDetails@@ -753,12 +756,12 @@     -> [InstalledUnitId]     -> DynFlags     -> (DynFlags, [InstalledUnitId])-removeInplacePackages fake_uid us df = (df { packageFlags = ps-                                  , thisInstalledUnitId = fake_uid }, uids)+removeInplacePackages fake_uid us df = (setThisInstalledUnitId fake_uid $+                                       df { packageFlags = ps }, uids)   where     (uids, ps) = partitionEithers (map go (packageFlags df))-    go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us-                                                  then Left (toInstalledUnitId u)+    go p@(ExposePackage _ (UnitIdArg u) _) = if GHC.toInstalledUnitId u `elem` us+                                                  then Left (GHC.toInstalledUnitId u)                                                   else Right p     go p = Right p @@ -794,23 +797,13 @@           setIgnoreInterfacePragmas $           setLinkerOptions $           disableOptimisation $-          allowEmptyCaseButWithWarning $           setUpTypedHoles $           makeDynFlagsAbsolute compRoot dflags'     -- initPackages parses the -package flags and     -- sets up the visibility for each component.     -- Throws if a -package flag cannot be satisfied.-    (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags''+    final_df <- liftIO $ wrapPackageSetupException $ initUnits dflags''     return (final_df, targets)----- | Wingman wants to support destructing of empty cases, but these are a parse--- error by default. So we want to enable 'EmptyCase', but then that leads to--- silent errors without 'Opt_WarnIncompletePatterns'.-allowEmptyCaseButWithWarning :: DynFlags -> DynFlags-allowEmptyCaseButWithWarning =-  flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns-  -- we don't want to generate object code so we compile to bytecode -- (HscInterpreted) which implies LinkInMemory

@@ -4,11 +4,11 @@     ,module Control.Concurrent.Extra     ) where -import Control.Concurrent.Extra hiding (modifyVar, modifyVar_)+import           Control.Concurrent.Extra hiding (modifyVar, modifyVar_) import qualified Control.Concurrent.Extra as Extra-import Control.Exception (evaluate)-import Data.Tuple.Extra (dupe)-import Control.Monad (void)+import           Control.Exception        (evaluate)+import           Control.Monad            (void)+import           Data.Tuple.Extra         (dupe)  -- | Strict modification that returns the new value modifyVar' :: Var a -> (a -> a) -> IO a

@@ -15,7 +15,7 @@ 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.OfInterest       as X (getFilesOfInterestUntracked) import           Development.IDE.Core.RuleTypes        as X import           Development.IDE.Core.Rules            as X (IsHiFileStable (..),                                                              getClientConfigAction,@@ -44,6 +44,8 @@                                                              use_, uses, uses_) import           Development.IDE.GHC.Error             as X import           Development.IDE.GHC.Util              as X+import           Development.IDE.Graph                 as X (Action, RuleResult,+                                                             Rules, action) import           Development.IDE.Plugin                as X import           Development.IDE.Types.Diagnostics     as X import           Development.IDE.Types.HscEnvEq        as X (HscEnvEq (..),@@ -51,5 +53,3 @@                                                              hscEnvWithImportPaths) import           Development.IDE.Types.Location        as X import           Development.IDE.Types.Logger          as X-import           Development.IDE.Graph                     as X (Action, RuleResult,-                                                             Rules, action)

@@ -28,9 +28,9 @@                                                        parseModule,                                                        typecheckModule,                                                        writeHieFile)+import           Development.IDE.Graph import qualified Development.IDE.Spans.AtPoint        as AtPoint import           Development.IDE.Types.Location-import           Development.IDE.Graph import qualified HieDb import           Language.LSP.Types                   (DocumentHighlight (..),                                                        SymbolInformation (..))@@ -116,7 +116,7 @@ refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] refsAtPoint file pos = do     ShakeExtras{hiedb} <- getShakeExtras-    fs <- HM.keys <$> getFilesOfInterest+    fs <- HM.keys <$> getFilesOfInterestUntracked     asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs     AtPoint.referencesAtPoint hiedb file pos (AtPoint.FOIReferences asts) 

@@ -80,7 +80,15 @@ import           StringBuffer                      as SB import           TcIface                           (typecheckIface) import           TcRnMonad                         hiding (newUnique)+#if MIN_VERSION_ghc(9,0,1)+import           GHC.Builtin.Names+import           GHC.Iface.Recomp+import           GHC.Tc.Gen.Splice+import           GHC.Tc.Types.Evidence             (EvBind)+#else+import           PrelNames import           TcSplice+#endif import           TidyPgm  import           Bag@@ -103,7 +111,6 @@ import           HeaderInfo import           Linker                            (unload) import           Maybes                            (orElse)-import           PrelNames import           System.Directory import           System.FilePath import           System.IO.Extra                   (fixIO, newTempFileWithin)@@ -143,10 +150,10 @@     -> IO (Either [FileDiagnostic] [InstalledUnitId]) computePackageDeps env pkg = do     let dflags = hsc_dflags env-    case lookupInstalledPackage dflags pkg of+    case oldLookupInstalledPackage dflags pkg of         Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $             T.pack $ "unknown package: " ++ show pkg]-        Just pkgInfo -> return $ Right $ depends pkgInfo+        Just pkgInfo -> return $ Right $ unitDepends pkgInfo  typecheckModule :: IdeDefer                 -> HscEnv@@ -267,8 +274,11 @@         (guts, details) <- tidyProgram session simplified_guts         (diags, linkable) <- genLinkable session ms guts         pure (linkable, details, diags)-#if MIN_VERSION_ghc(8,10,0)+#if MIN_VERSION_ghc(9,0,1)   let !partial_iface = force (mkPartialIface session details simplified_guts)+  final_iface <- mkFullIface session partial_iface Nothing+#elif MIN_VERSION_ghc(8,10,0)+  let !partial_iface = force (mkPartialIface session details simplified_guts)   final_iface <- mkFullIface session partial_iface #else   (final_iface,_) <- mkIface session Nothing details simplified_guts@@ -335,7 +345,11 @@                           target = defaultObjectTarget $ targetPlatform $ hsc_dflags session #endif                           session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}}+#if MIN_VERSION_ghc(9,0,1)+                      (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts+#else                       (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts+#endif #if MIN_VERSION_ghc(8,10,0)                                 (ms_location summary') #else@@ -463,7 +477,15 @@     -- don't export an interface which allows for additional information to be added to hie files.     let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm))         real_binds = tcg_binds $ tmrTypechecked tcm+#if MIN_VERSION_ghc(9,0,1)+        ts = tmrTypechecked tcm :: TcGblEnv+        top_ev_binds = tcg_ev_binds ts :: Bag EvBind+        insts = tcg_insts ts :: [ClsInst]+        tcs = tcg_tcs ts :: [TyCon]+    Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs+#else     Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm)+#endif   where     dflags = hsc_dflags hscEnv @@ -650,7 +672,7 @@      -- Make modules available for others that import them,     -- by putting them in the finder cache.-    let ims  = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss+    let ims  = map (installedModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss         ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims     -- set the target and module graph in the session         graph = mkModuleGraph mss@@ -708,7 +730,7 @@          mod = fmap unLoc mb_mod `orElse` mAIN_NAME -        (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps+        (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps          -- GHC.Prim doesn't exist physically, so don't go looking for it.         ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc@@ -777,7 +799,11 @@        => DynFlags -- ^ flags to use        -> FilePath  -- ^ the filename (for source locations)        -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)+#if MIN_VERSION_ghc(9,0,1)+       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule))+#else        -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs))+#endif parseHeader dflags filename contents = do    let loc  = mkRealSrcLoc (mkFastString filename) 1 1    case unP Parser.parseHeader (mkPState dflags contents loc) of@@ -826,10 +852,21 @@       throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr #endif      POk pst rdr_module ->-         let hpm_annotations =+         let hpm_annotations :: ApiAnns+             hpm_annotations =+#if MIN_VERSION_ghc(9,0,1)+               -- Copied from GHC.Driver.Main+               ApiAnns {+                      apiAnnItems = Map.fromListWith (++) $ annotations pst,+                      apiAnnEofPos = eof_pos pst,+                      apiAnnComments = Map.fromList (annotations_comments pst),+                      apiAnnRogueComments = comment_q pst+                   }+#else                (Map.fromListWith (++) $ annotations pst,                  Map.fromList ((noSrcSpan,comment_q pst)                                   :annotations_comments pst))+#endif              (warns, errs) = getMessages pst dflags          in            do

@@ -11,10 +11,10 @@ import           Control.Concurrent.Async import           Control.Concurrent.Strict import           Control.Exception-import           Control.Monad            (join)-import           Data.Foldable            (traverse_)-import           Data.HashMap.Strict      (HashMap)-import qualified Data.HashMap.Strict      as Map+import           Control.Monad             (join)+import           Data.Foldable             (traverse_)+import           Data.HashMap.Strict       (HashMap)+import qualified Data.HashMap.Strict       as Map import           Data.Hashable import           System.Time.Extra 

@@ -17,17 +17,18 @@ import qualified Data.ByteString                       as BS import           Data.HashMap.Strict                   (HashMap) import qualified Data.HashMap.Strict                   as HashMap+import           Data.List                             (partition) import           Data.Maybe import           Development.IDE.Core.FileStore import           Development.IDE.Core.IdeConfiguration import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Shake+import           Development.IDE.Graph import           Development.IDE.Types.Location import           Development.IDE.Types.Options-import           Development.IDE.Graph+import           Ide.Plugin.Config                     (Config) import           Language.LSP.Server                   hiding (getVirtualFile) import           Language.LSP.Types-import           Language.LSP.Types.Capabilities import qualified System.Directory                      as Dir import qualified System.FilePath.Glob                  as Glob @@ -91,22 +92,25 @@ modifyFileExists state changes = do   FileExistsMapVar var <- getIdeGlobalState state   changesMap           <- evaluate $ HashMap.fromList $-    [ (toNormalizedFilePath' f, newState)+    [ (toNormalizedFilePath' f, change)     | FileEvent uri change <- changes     , Just f <- [uriToFilePath uri]-    , Just newState <- [fromChange change]     ]   -- Masked to ensure that the previous values are flushed together with the map update   mask $ \_ -> do     -- update the map-    void $ modifyVar' var $ HashMap.union changesMap+    void $ modifyVar' var $ HashMap.union (HashMap.mapMaybe fromChange changesMap)     -- See Note [Invalidating file existence results]     -- flush previous values-    mapM_ (deleteValue (shakeExtras state) GetFileExists) (HashMap.keys changesMap)+    let (fileModifChanges, fileExistChanges) =+            partition ((== FcChanged) . snd) (HashMap.toList changesMap)+    mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges+    recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges+    recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges  fromChange :: FileChangeType -> Maybe Bool fromChange FcCreated = Just True-fromChange FcDeleted = Just True+fromChange FcDeleted = Just False fromChange FcChanged = Nothing  -------------------------------------------------------------------------------------@@ -153,18 +157,11 @@ -- | Installs the 'getFileExists' rules. --   Provides a fast implementation if client supports dynamic watched files. --   Creates a global state as a side effect in that case.-fileExistsRules :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules ()+fileExistsRules :: Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules () fileExistsRules lspEnv vfs = do   supportsWatchedFiles <- case lspEnv of-    Just lspEnv' -> liftIO $ runLspT lspEnv' $ do-      ClientCapabilities {_workspace} <- getClientCapabilities-      case () of-        _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace-          , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles-          , Just True <- _dynamicRegistration-          -> pure True-        _ -> pure False-    Nothing -> pure False+    Nothing      -> pure False+    Just lspEnv' -> liftIO $  runLspT lspEnv' isWatchSupported   -- Create the global always, although it should only be used if we have fast rules.   -- But there's a chance someone will send unexpected notifications anyway,   -- e.g. https://github.com/haskell/ghcide/issues/599

@@ -14,13 +14,14 @@     VFSHandle,     makeVFSHandle,     makeLSPVFSHandle,-    isFileOfInterestRule,     resetFileStore,     resetInterfaceStore,     getModificationTimeImpl,     addIdeGlobal,     getFileContentsImpl,-    getModTime+    getModTime,+    isWatchSupported,+    registerFileWatches     ) where  import           Control.Concurrent.STM                       (atomically)@@ -38,8 +39,7 @@ import qualified Data.Text                                    as T import           Data.Time import           Data.Time.Clock.POSIX-import           Development.IDE.Core.OfInterest              (OfInterestVar (..),-                                                               getFilesOfInterest)+import           Development.IDE.Core.OfInterest              (OfInterestVar (..)) import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Shake import           Development.IDE.GHC.Orphans                  ()@@ -48,27 +48,41 @@ import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location import           Development.IDE.Types.Options+import           Development.IDE.Types.Shake                  (SomeShakeValue) import           HieDb.Create                                 (deleteMissingRealFiles)-import           Ide.Plugin.Config                            (CheckParents (..))+import           Ide.Plugin.Config                            (CheckParents (..),+                                                               Config) import           System.IO.Error  #ifdef mingw32_HOST_OS import qualified System.Directory                             as Dir #else-import           System.Posix.Files                           ( getFileStatus, modificationTimeHiRes)+import           System.Posix.Files                           (getFileStatus,+                                                               modificationTimeHiRes) #endif  import qualified Development.IDE.Types.Logger                 as L  import qualified Data.Binary                                  as B import qualified Data.ByteString.Lazy                         as LBS+import qualified Data.HashSet                                 as HSet+import           Data.IORef.Extra                             (atomicModifyIORef_)+import           Data.List                                    (foldl')+import qualified Data.Text                                    as Text+import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile) import           Language.LSP.Server                          hiding                                                               (getVirtualFile) import qualified Language.LSP.Server                          as LSP-import           Language.LSP.Types                           (FileChangeType (FcChanged),+import           Language.LSP.Types                           (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),+                                                               FileChangeType (FcChanged),                                                                FileEvent (FileEvent),+                                                               FileSystemWatcher (..),+                                                               WatchKind (..),+                                                               _watchers,                                                                toNormalizedFilePath,                                                                uriToFilePath)+import qualified Language.LSP.Types                           as LSP+import qualified Language.LSP.Types.Capabilities              as LSP import           Language.LSP.VFS import           System.FilePath @@ -93,60 +107,57 @@     , setVirtualFileContents = Nothing    } --isFileOfInterestRule :: Rules ()-isFileOfInterestRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do-    filesOfInterest <- getFilesOfInterest-    let foi = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest-        fp  = summarize foi-        res = (Just fp, Just foi)-    return res-    where-    summarize NotFOI                   = BS.singleton 0-    summarize (IsFOI OnDisk)           = BS.singleton 1-    summarize (IsFOI (Modified False)) = BS.singleton 2-    summarize (IsFOI (Modified True))  = BS.singleton 3+addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules ()+addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do+  isAlreadyWatched <- isWatched f+  isWp <- isWorkspaceFile f+  if isAlreadyWatched then pure (Just True) else+    if not isWp then pure (Just False) else do+        ShakeExtras{lspEnv} <- getShakeExtras+        case lspEnv of+            Just env -> fmap Just $ liftIO $ LSP.runLspT env $+                registerFileWatches [fromNormalizedFilePath f]+            Nothing -> pure $ Just False  -getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()-getModificationTimeRule vfs isWatched = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->-    getModificationTimeImpl vfs isWatched missingFileDiags file+getModificationTimeRule :: VFSHandle -> Rules ()+getModificationTimeRule vfs = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->+    getModificationTimeImpl vfs missingFileDiags file  getModificationTimeImpl :: VFSHandle-    -> (NormalizedFilePath -> Action Bool)     -> Bool     -> NormalizedFilePath     -> Action         (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))-getModificationTimeImpl vfs isWatched missingFileDiags file = do-        let file' = fromNormalizedFilePath file-        let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))-        mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file-        case mbVirtual of-            Just (virtualFileVersion -> ver) -> do-                alwaysRerun-                pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))-            Nothing -> do-                isWF <- isWatched file-                if isWF-                    then -- the file is watched so we can rely on FileWatched notifications,-                         -- but also need a dependency on IsFileOfInterest to reinstall-                         -- alwaysRerun when the file becomes VFS-                        void (use_ IsFileOfInterest file)-                    else if isInterface file-                        then -- interface files are tracked specially using the closed world assumption-                            pure ()-                        else -- in all other cases we will need to freshly check the file system-                            alwaysRerun+getModificationTimeImpl vfs missingFileDiags file = do+    let file' = fromNormalizedFilePath file+    let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))+    mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file+    case mbVirtual of+        Just (virtualFileVersion -> ver) -> do+            alwaysRerun+            pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))+        Nothing -> do+            isWF <- use_ AddWatchedFile file+            if isWF+                then -- the file is watched so we can rely on FileWatched notifications,+                        -- but also need a dependency on IsFileOfInterest to reinstall+                        -- alwaysRerun when the file becomes VFS+                    void (use_ IsFileOfInterest file)+                else if isInterface file+                    then -- interface files are tracked specially using the closed world assumption+                        pure ()+                    else -- in all other cases we will need to freshly check the file system+                        alwaysRerun -                liftIO $ fmap wrap (getModTime file')-                    `catch` \(e :: IOException) -> do-                        let err | isDoesNotExistError e = "File does not exist: " ++ file'-                                | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e-                            diag = ideErrorText file (T.pack err)-                        if isDoesNotExistError e && not missingFileDiags-                            then return (Nothing, ([], Nothing))-                            else return (Nothing, ([diag], Nothing))+            liftIO $ fmap wrap (getModTime file')+                `catch` \(e :: IOException) -> do+                    let err | isDoesNotExistError e = "File does not exist: " ++ file'+                            | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e+                        diag = ideErrorText file (T.pack err)+                    if isDoesNotExistError e && not missingFileDiags+                        then return (Nothing, ([], Nothing))+                        else return (Nothing, ([diag], Nothing))  -- | Interface files cannot be watched, since they live outside the workspace. --   But interface files are private, in that only HLS writes them.@@ -157,26 +168,25 @@ -- | Reset the GetModificationTime state of interface files resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> IO () resetInterfaceStore state f = do-    deleteValue state (GetModificationTime_ True) f-    deleteValue state (GetModificationTime_ False) f+    deleteValue state GetModificationTime f  -- | Reset the GetModificationTime state of watched files resetFileStore :: IdeState -> [FileEvent] -> IO ()-resetFileStore ideState changes = mask $ \_ ->-    forM_ changes $ \(FileEvent uri c) ->+resetFileStore ideState changes = mask $ \_ -> do+    -- we record FOIs document versions in all the stored values+    -- so NEVER reset FOIs to avoid losing their versions+    OfInterestVar foisVar <- getIdeGlobalExtras (shakeExtras ideState)+    fois <- readVar foisVar+    forM_ changes $ \(FileEvent uri c) -> do         case c of             FcChanged               | Just f <- uriToFilePath uri-              -> do-                  -- we record FOIs document versions in all the stored values-                  -- so NEVER reset FOIs to avoid losing their versions-                  OfInterestVar foisVar <- getIdeGlobalExtras (shakeExtras ideState)-                  fois <- readVar foisVar-                  unless (HM.member (toNormalizedFilePath f) fois) $ do-                    deleteValue (shakeExtras ideState) (GetModificationTime_ True) (toNormalizedFilePath' f)-                    deleteValue (shakeExtras ideState) (GetModificationTime_ False) (toNormalizedFilePath' f)+              , nfp <- toNormalizedFilePath f+              , not $ HM.member nfp fois+              -> deleteValue (shakeExtras ideState) GetModificationTime nfp             _ -> pure () + -- 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.@@ -240,9 +250,9 @@ fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () fileStoreRules vfs isWatched = do     addIdeGlobal vfs-    getModificationTimeRule vfs isWatched+    getModificationTimeRule vfs     getFileContentsRule vfs-    isFileOfInterestRule+    addWatchedFileRule isWatched  -- | Note that some buffer for a specific file has been modified but not -- with what changes.@@ -260,7 +270,8 @@     VFSHandle{..} <- getIdeGlobalState state     when (isJust setVirtualFileContents) $         fail "setFileModified can't be called on this type of VFSHandle"-    shakeRestart state []+    recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]+    restartShakeSession (shakeExtras state) []     when checkParents $       typecheckParents state nfp @@ -280,14 +291,56 @@           `catch` \(e :: SomeException) -> log (show e)         () <$ uses GetModIface rs --- | Note that some buffer somewhere has been modified, but don't say what.+-- | Note that some keys have been modified and restart the session --   Only valid if the virtual file system was initialised by LSP, as that --   independently tracks which files are modified.-setSomethingModified :: IdeState -> IO ()-setSomethingModified state = do+setSomethingModified :: IdeState -> [SomeShakeValue] -> IO ()+setSomethingModified state keys = do     VFSHandle{..} <- getIdeGlobalState state     when (isJust setVirtualFileContents) $         fail "setSomethingModified can't be called on this type of VFSHandle"     -- Update database to remove any files that might have been renamed/deleted     atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles-    void $ shakeRestart state []+    atomicModifyIORef_ (dirtyKeys $ shakeExtras state) $ \x ->+        foldl' (flip HSet.insert) x keys+    void $ restartShakeSession (shakeExtras state) []++registerFileWatches :: [String] -> LSP.LspT Config IO Bool+registerFileWatches globs = do+      watchSupported <- isWatchSupported+      if watchSupported+      then do+        let+          regParams    = LSP.RegistrationParams (List [LSP.SomeRegistration registration])+          -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).+          -- We could also use something like a random UUID, as some other servers do, but this works for+          -- our purposes.+          registration = LSP.Registration "globalFileWatches"+                                           LSP.SWorkspaceDidChangeWatchedFiles+                                           regOptions+          regOptions =+            DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }+          -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind+          watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}+          -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is+          -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,+          -- followed by a file with an extension 'hs'.+          watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }+          -- We use multiple watchers instead of one using '{}' because lsp-test doesn't+          -- support that: https://github.com/bubba/lsp-test/issues/77+          watchers = [ watcher (Text.pack glob) | glob <- globs ]++        void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response+        return True+      else return False++isWatchSupported :: LSP.LspT Config IO Bool+isWatchSupported = do+      clientCapabilities <- LSP.getClientCapabilities+      pure $ case () of+            _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities+              , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace+              , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles+              , Just True <- _dynamicRegistration+                -> True+              | otherwise -> False

@@ -20,8 +20,8 @@ import           Data.Hashable                  (Hashed, hashed, unhashed) import           Data.Text                      (Text, isPrefixOf) import           Development.IDE.Core.Shake-import           Development.IDE.Types.Location import           Development.IDE.Graph+import           Development.IDE.Types.Location import           Language.LSP.Types import           System.FilePath                (isRelative) 

@@ -5,10 +5,13 @@ {-# LANGUAGE TypeFamilies      #-}  -- | Utilities and state for the files of interest - those which are currently---   open in the editor. The useful function is 'getFilesOfInterest'.+--   open in the editor. The rule is 'IsFileOfInterest' module Development.IDE.Core.OfInterest(     ofInterestRules,-    getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,+    getFilesOfInterestUntracked,+    addFileOfInterest,+    deleteFileOfInterest,+    setFilesOfInterest,     kick, FileOfInterestStatus(..),     OfInterestVar(..)     ) where@@ -16,7 +19,6 @@ import           Control.Concurrent.Strict import           Control.Monad import           Control.Monad.IO.Class-import           Data.Binary import           Data.HashMap.Strict                          (HashMap) import qualified Data.HashMap.Strict                          as HashMap import qualified Data.Text                                    as T@@ -24,7 +26,7 @@  import           Control.Monad.Trans.Class import           Control.Monad.Trans.Maybe-import qualified Data.ByteString.Lazy                         as LBS+import qualified Data.ByteString                              as BS import           Data.List.Extra                              (nubOrd) import           Data.Maybe                                   (catMaybes) import           Development.IDE.Core.ProgressReporting@@ -43,15 +45,19 @@ ofInterestRules :: Rules () ofInterestRules = do     addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)-    defineEarlyCutOffNoFile $ \GetFilesOfInterest -> do+    defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do         alwaysRerun         filesOfInterest <- getFilesOfInterestUntracked-        let !cutoff = LBS.toStrict $ encode $ HashMap.toList filesOfInterest-        pure (cutoff, filesOfInterest)+        let foi = maybe NotFOI IsFOI $ f `HashMap.lookup` filesOfInterest+            fp  = summarize foi+            res = (Just fp, Just foi)+        return res+    where+    summarize NotFOI                   = BS.singleton 0+    summarize (IsFOI OnDisk)           = BS.singleton 1+    summarize (IsFOI (Modified False)) = BS.singleton 2+    summarize (IsFOI (Modified True))  = BS.singleton 3 --- | Get the files that are open in the IDE.-getFilesOfInterest :: Action (HashMap NormalizedFilePath FileOfInterestStatus)-getFilesOfInterest = useNoFile_ GetFilesOfInterest  ------------------------------------------------------------ -- Exposed API@@ -59,29 +65,39 @@ -- | Set the files-of-interest - not usually necessary or advisable. --   The LSP client will keep this information up to date. setFilesOfInterest :: IdeState -> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()-setFilesOfInterest state files = modifyFilesOfInterest state (const files)+setFilesOfInterest state files = do+    OfInterestVar var <- getIdeGlobalState state+    writeVar var files  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-  -> (HashMap NormalizedFilePath FileOfInterestStatus -> HashMap NormalizedFilePath FileOfInterestStatus)-  -> IO ()-modifyFilesOfInterest state f = do+addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()+addFileOfInterest state f v = do     OfInterestVar var <- getIdeGlobalState state-    files <- modifyVar' var f-    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashMap.toList files)+    (prev, files) <- modifyVar var $ \dict -> do+        let (prev, new) = HashMap.alterF (, Just v) f dict+        pure (new, (prev, dict))+    when (prev /= Just v) $+        recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]+    logDebug (ideLogger state) $+        "Set files of interest to: " <> T.pack (show files) +deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()+deleteFileOfInterest state f = do+    OfInterestVar var <- getIdeGlobalState state+    files <- modifyVar' var $ HashMap.delete f+    recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]+    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)++ -- | Typecheck all the files of interest. --   Could be improved kick :: Action () kick = do-    files <- HashMap.keys <$> getFilesOfInterest+    files <- HashMap.keys <$> getFilesOfInterestUntracked     ShakeExtras{progress} <- getShakeExtras     liftIO $ progressUpdate progress KickStarted 

@@ -58,7 +58,7 @@         else do             cppLogs <- liftIO $ newIORef []             contents <- ExceptT-                        $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename+                        $ (Right <$> (runCpp dflags {log_action = logActionCompat $ logAction cppLogs} filename                                        $ if isOnDisk then Nothing else Just contents))                             `catch`                             ( \(e :: GhcException) -> do@@ -78,7 +78,7 @@         (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents         return (contents, opts, dflags)   where-    logAction :: IORef [CPPLog] -> LogAction+    logAction :: IORef [CPPLog] -> LogActionCompat     logAction cppLogs dflags _reason severity srcSpan _style msg = do       let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg       modifyIORef cppLogs (log :)@@ -107,7 +107,7 @@     -- 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 (RealSrcSpan span) msg : logs) =+    go acc (CPPLog sev (OldRealSrcSpan span) msg : logs) =       let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg]        in go (diag : acc) logs     go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =

@@ -40,7 +40,6 @@ import qualified Data.Binary                                  as B import           Data.ByteString                              (ByteString) import qualified Data.ByteString.Lazy                         as LBS-import           Data.HashMap.Strict                          (HashMap) import           Data.Text                                    (Text) import           Data.Time import           Development.IDE.Import.FindImports           (ArtifactsLocation)@@ -267,7 +266,9 @@  type instance RuleResult GetFileExists = Bool +type instance RuleResult AddWatchedFile = Bool + -- The Shake key type for getModificationTime queries newtype GetModificationTime = GetModificationTime_     { missingFileDiagnostics :: Bool@@ -354,8 +355,6 @@ -- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult -type instance RuleResult GetFilesOfInterest = HashMap NormalizedFilePath FileOfInterestStatus- data GetParsedModule = GetParsedModule     deriving (Eq, Show, Typeable, Generic) instance Hashable GetParsedModule@@ -493,6 +492,12 @@  type instance RuleResult GetClientSettings = Hashed (Maybe Value) +data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic)+instance Hashable AddWatchedFile+instance NFData   AddWatchedFile+instance Binary   AddWatchedFile++ -- A local rule type to get caching. We want to use newCache, but it has -- thread killed exception issues, so we lift it to a full rule. -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547@@ -512,12 +517,6 @@ instance Hashable GhcSessionIO instance NFData   GhcSessionIO instance Binary   GhcSessionIO--data GetFilesOfInterest = GetFilesOfInterest-    deriving (Eq, Show, Typeable, Generic)-instance Hashable GetFilesOfInterest-instance NFData   GetFilesOfInterest-instance Binary   GetFilesOfInterest  makeLensesWith     (lensRules & lensField .~ mappingNamer (pure . (++ "L")))

@@ -111,7 +111,10 @@                                                                writeHieFile) import           Development.IDE.GHC.Error import           Development.IDE.GHC.ExactPrint-import           Development.IDE.GHC.Util+import           Development.IDE.GHC.Util                     hiding+                                                              (modifyDynFlags)+import           Development.IDE.Graph+import           Development.IDE.Graph.Classes                hiding (get, put) import           Development.IDE.Import.DependencyInformation import           Development.IDE.Import.FindImports import qualified Development.IDE.Spans.AtPoint                as AtPoint@@ -122,8 +125,6 @@ import           Development.IDE.Types.Location import qualified Development.IDE.Types.Logger                 as L import           Development.IDE.Types.Options-import           Development.IDE.Graph-import           Development.IDE.Graph.Classes                    hiding (get, put) import           Fingerprint import           GHC.Generics                                 (Generic) import           GHC.IO.Encoding@@ -140,11 +141,16 @@ import           System.Directory                             (canonicalizePath) import           TcRnMonad                                    (tcg_dependent_files) -import           Ide.Plugin.Properties (HasProperty, KeyNameProxy, Properties, ToHsType, useProperty)-import           Ide.Types (PluginId)-import           Data.Default (def)-import           Ide.PluginUtils (configForPlugin) import           Control.Applicative+import           Data.Default                                 (def)+import           Ide.Plugin.Properties                        (HasProperty,+                                                               KeyNameProxy,+                                                               Properties,+                                                               ToHsType,+                                                               useProperty)+import           Ide.PluginUtils                              (configForPlugin)+import           Ide.Types                                    (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),+                                                               PluginId)  -- | 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@@ -202,18 +208,21 @@ getParsedModuleRule =   -- this rule does not have early cutoff since all its dependencies already have it   define $ \GetParsedModule file -> do-    ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file+    ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file     sess <- use_ GhcSession file     let hsc = hscEnv sess     opt <- getIdeOptions+    modify_dflags <- getModifyDynFlags dynFlagsModifyParser+    let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }      let dflags    = ms_hspp_opts ms         mainParse = getParsedModuleDefinition hsc opt file ms+        reset_ms pm = pm { pm_mod_summary = ms' }      -- Parse again (if necessary) to capture Haddock parse errors     res@(_,pmod) <- if gopt Opt_Haddock dflags         then-            liftIO mainParse+            liftIO $ (fmap.fmap.fmap) reset_ms mainParse         else do             let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) @@ -223,7 +232,7 @@             -- If we can parse Haddocks, might as well use them             --             -- HLINT INTEGRATION: might need to save the other parsed module too-            ((diags,res),(diagsh,resh)) <- liftIO $ concurrently mainParse haddockParse+            ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse              -- Merge haddock and regular diagnostics so we can always report haddock             -- parse errors@@ -275,9 +284,16 @@     opt <- getIdeOptions      let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms+    modify_dflags <- getModifyDynFlags dynFlagsModifyParser+    let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }+        reset_ms pm = pm { pm_mod_summary = ms' } -    liftIO $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms'+    liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms +getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a+getModifyDynFlags f = f . optModifyDynFlags <$> getIdeOptions++ getParsedModuleDefinition     :: HscEnv     -> IdeOptions@@ -775,7 +791,9 @@ getModSummaryRule :: Rules () getModSummaryRule = do     defineEarlyCutoff $ Rule $ \GetModSummary f -> do-        session <- hscEnv <$> use_ GhcSession f+        session' <- hscEnv <$> use_ GhcSession f+        modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal+        let session = session' { hsc_dflags = modify_dflags $ hsc_dflags session' }         (modTime, mFileContent) <- getFileContents f         let fp = fromNormalizedFilePath f         modS <- liftIO $ runExceptT $

@@ -21,9 +21,9 @@ import           Development.IDE.Core.Debouncer import           Development.IDE.Core.FileExists (fileExistsRules) import           Development.IDE.Core.OfInterest+import           Development.IDE.Graph import           Development.IDE.Types.Logger    as Logger import           Development.IDE.Types.Options   (IdeOptions (..))-import           Development.IDE.Graph import           Ide.Plugin.Config import qualified Language.LSP.Server             as LSP import qualified Language.LSP.Types              as LSP

@@ -30,7 +30,6 @@     IdeRule, IdeResult,     GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),     shakeOpen, shakeShut,-    shakeRestart,     shakeEnqueue,     shakeProfile,     newSession,@@ -63,7 +62,7 @@     FileVersion(..),     Priority(..),     updatePositionMapping,-    deleteValue,+    deleteValue, recordDirtyKeys,     OnDiskRule(..),     WithProgressFunc, WithIndefiniteProgressFunc,     ProgressEvent(..),@@ -91,7 +90,8 @@ import           Data.Dynamic import qualified Data.HashMap.Strict                    as HMap import           Data.Hashable-import           Data.List.Extra                        (partition, takeEnd)+import           Data.List.Extra                        (foldl', partition,+                                                         takeEnd) import           Data.Map.Strict                        (Map) import qualified Data.Map.Strict                        as Map import           Data.Maybe@@ -145,7 +145,13 @@ import           UniqSupply  import           Control.Exception.Extra                hiding (bracket_)+import qualified Data.ByteString.Char8                  as BS8 import           Data.Default+import           Data.Foldable                          (toList)+import           Data.HashSet                           (HashSet)+import qualified Data.HashSet                           as HSet+import           Data.IORef.Extra                       (atomicModifyIORef'_,+                                                         atomicModifyIORef_) import           HieDb.Types import           Ide.Plugin.Config import qualified Ide.PluginUtils                        as HLS@@ -187,7 +193,9 @@     ,progress :: ProgressReporting     ,ideTesting :: IdeTesting     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants-    ,restartShakeSession :: [DelayedAction ()] -> IO ()+    ,restartShakeSession+        :: [DelayedAction ()]+        -> IO ()     ,ideNc :: IORef NameCache     -- | A mapping of module name to known target (or candidate targets, if missing)     ,knownTargetsVar :: Var (Hashed KnownTargets)@@ -204,6 +212,8 @@     , vfs :: VFSHandle     , defaultConfig :: Config       -- ^ Default HLS config, only relevant if the client does not provide any Config+    , dirtyKeys :: IORef (HashSet SomeShakeValue)+      -- ^ Set of dirty rule keys since the last Shake run     }  type WithProgressFunc = forall a.@@ -411,13 +421,24 @@  -- | Delete the value stored for a given ide build key deleteValue-  :: (Typeable k, Hashable k, Eq k, Show k)+  :: Shake.ShakeValue k   => ShakeExtras   -> k   -> NormalizedFilePath   -> IO ()-deleteValue ShakeExtras{state} key file = void $ modifyVar' state $ HMap.delete (file, Key key)+deleteValue ShakeExtras{dirtyKeys, state} key file = do+    void $ modifyVar' state $ HMap.delete (file, Key key)+    atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file) +recordDirtyKeys+  :: Shake.ShakeValue k+  => ShakeExtras+  -> k+  -> [NormalizedFilePath]+  -> IO ()+recordDirtyKeys ShakeExtras{dirtyKeys} key file =+    atomicModifyIORef_ dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file)+ -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues ::   forall k v.@@ -496,6 +517,7 @@          let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv +        dirtyKeys <- newIORef mempty         pure ShakeExtras{..}     (shakeDbM, shakeClose) <-         shakeOpenDatabase@@ -564,11 +586,13 @@         (\runner -> do               (stopTime,()) <- duration (cancelShakeSession runner)               res <- shakeDatabaseProfile shakeDb+              backlog <- readIORef $ dirtyKeys shakeExtras               let profile = case res of                       Just fp -> ", profile saved at " <> fp                       _       -> ""-              let msg = T.pack $ "Restarting build session (aborting the previous one took "-                              ++ showDuration stopTime ++ profile ++ ")"+              let msg = T.pack $ "Restarting build session " ++ keysMsg ++ abortMsg+                  keysMsg = "for keys " ++ show (HSet.toList backlog) ++ " "+                  abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")"               logDebug (logger shakeExtras) msg               notifyTestingLogMessage shakeExtras msg         )@@ -609,9 +633,18 @@  -- | 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+    -> ShakeDatabase+    -> [DelayedActionInternal]+    -> IO ShakeSession newSession extras@ShakeExtras{..} shakeDb acts = do+    IdeOptions{optRunSubset} <- getIdeOptionsIO extras     reenqueued <- atomically $ peekInProgress actionQueue+    allPendingKeys <-+        if optRunSubset+          then Just <$> readIORef dirtyKeys+          else return Nothing     let         -- A daemon-like action used to inject additional work         -- Runs actions from the work queue sequentially@@ -631,9 +664,13 @@                 logPriority logger (actionPriority d) msg                 notifyTestingLogMessage extras msg +        -- The inferred type signature doesn't work in ghc >= 9.0.1+        workRun :: (forall b. IO b -> IO b) -> IO (IO ())         workRun restore = withSpan "Shake session" $ \otSpan -> do-          let acts' = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)-          res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts')+          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk)+          let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)+          res <- try @SomeException $+            restore $ shakeRunDatabaseForKeys (HSet.toList <$> allPendingKeys) shakeDb keysActs           let res' = case res of                       Left e  -> "exception: " <> displayException e                       Right _ -> "completed"@@ -829,9 +866,9 @@     :: IdeRule k v     => RuleBody k v     -> Rules ()-defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do+defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode isSuccess $ do     defineEarlyCutoff' True key file old mode $ op key file-defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do+defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode isSuccess $ do     defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file  defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()@@ -854,7 +891,7 @@     -> Action (Maybe BS.ByteString, IdeResult v)     -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics key file old mode action = do-    extras@ShakeExtras{state, progress, logger} <- getShakeExtras+    extras@ShakeExtras{state, progress, logger, dirtyKeys} <- getShakeExtras     options <- getIdeOptions     (if optSkipProgress options key then id else inProgress progress file) $ do         val <- case old of@@ -869,7 +906,7 @@                         return $ Just $ RunResult ChangedNothing old $ A v                     _ -> return Nothing             _ -> return Nothing-        case val of+        res <- case val of             Just res -> return res             Nothing -> do                 (bs, (diags, res)) <- actionCatch@@ -903,10 +940,12 @@                     (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)                     (encodeShakeValue bs) $                     A res+        liftIO $ atomicModifyIORef'_ dirtyKeys (HSet.delete $ toKey key file)+        return res -isSuccess :: RunResult (A v) -> Bool-isSuccess (RunResult _ _ (A Failed{})) = False-isSuccess _                            = True+isSuccess :: A v -> Bool+isSuccess (A Failed{}) = False+isSuccess _            = True  -- | Rule type, input file data QDisk k = QDisk k NormalizedFilePath

@@ -1,5 +1,5 @@+{-# LANGUAGE CPP             #-} {-# LANGUAGE NoApplicativeDo #-}-{-# LANGUAGE CPP #-} module Development.IDE.Core.Tracing     ( otTracedHandler     , otTracedAction@@ -32,12 +32,13 @@ import           Development.IDE.Core.RuleTypes (GhcSession (GhcSession),                                                  GhcSessionDeps (GhcSessionDeps),                                                  GhcSessionIO (GhcSessionIO))+import           Development.IDE.Graph          (Action, actionBracket)+import           Development.IDE.Graph.Rule import           Development.IDE.Types.Location (Uri (..)) import           Development.IDE.Types.Logger   (Logger, logDebug, logInfo) import           Development.IDE.Types.Shake    (Key (..), Value,                                                  ValueWithDiagnostics (..),                                                  Values)-import           Development.IDE.Graph              (Action, actionBracket) import           Foreign.Storable               (Storable (sizeOf)) import           HeapSize                       (recursiveSize, runHeapsize) import           Ide.PluginUtils                (installSigUsr1Handler)@@ -77,21 +78,25 @@     :: Show k     => k -- ^ The Action's Key     -> NormalizedFilePath -- ^ Path to the file the action was run for-    -> (a -> Bool) -- ^ Did this action succeed?-    -> Action a -- ^ The action-    -> Action a-otTracedAction key file success act+    -> RunMode+    -> (a -> Bool)+    -> Action (RunResult a) -- ^ The action+    -> Action (RunResult a)+otTracedAction key file mode success act   | userTracingEnabled =     actionBracket         (do             sp <- beginSpan (fromString (show key))             setTag sp "File" (fromString $ fromNormalizedFilePath file)+            setTag sp "Mode" (fromString $ show mode)             return sp         )         endSpan         (\sp -> do             res <- act-            unless (success res) $ setTag sp "error" "1"+            unless (success $ runValue res) $ setTag sp "error" "1"+            setTag sp "changed" $ case res of+              RunResult x _ _ -> fromString $ show x             return res)   | otherwise = act 

@@ -20,19 +20,23 @@   ) where  import           Control.Arrow-import           Control.Category (Category)-import qualified Control.Category as C-import           Control.DeepSeq (NFData)+import           Control.Category                     (Category)+import qualified Control.Category                     as C+import           Control.DeepSeq                      (NFData) import           Data.Aeson-import           Data.Coerce (coerce)-import           Data.Functor ((<&>))-import           Data.Functor.Identity (Identity(Identity))-import           Data.Kind (Type)-import           Data.String (fromString)-import           Development.IDE (NormalizedFilePath, IdeRule, Action, Range, rangeToRealSrcSpan, realSrcSpanToRange)+import           Data.Coerce                          (coerce)+import           Data.Functor                         ((<&>))+import           Data.Functor.Identity                (Identity (Identity))+import           Data.Kind                            (Type)+import           Data.String                          (fromString)+import           Development.IDE                      (Action, IdeRule,+                                                       NormalizedFilePath,+                                                       Range,+                                                       rangeToRealSrcSpan,+                                                       realSrcSpanToRange) import qualified Development.IDE.Core.PositionMapping as P-import qualified Development.IDE.Core.Shake as IDE-import qualified FastString as FS+import qualified Development.IDE.Core.Shake           as IDE+import qualified FastString                           as FS import           SrcLoc  

@@ -24,9 +24,8 @@ module Development.IDE.GHC.CPP(doCpp, addOptP) where -import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat as Compat import           FileCleanup-import           Module import           Packages import           Panic import           SysTools@@ -187,7 +186,7 @@ -- --------------------------------------------------------------------------- -- Macros (cribbed from Cabal) -generatePackageVersionMacros :: [PackageConfig] -> String+generatePackageVersionMacros :: [Compat.PackageConfig] -> String generatePackageVersionMacros pkgs = concat   -- Do not add any C-style comments. See #3389.   [ generateMacros "" pkgname version@@ -220,7 +219,7 @@   candidates <- case ghcVersionFile dflags of     Just path -> return [path]     Nothing -> (map (</> "ghcversion.h")) <$>-               (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])+               (getPackageIncludePath dflags [Compat.toInstalledUnitId Compat.rtsUnit])    found <- filterM doesFileExist candidates   case found of

@@ -1,11 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE ConstraintKinds   #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PatternSynonyms   #-} {-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-}+{-# OPTIONS -Wno-missing-signatures #-} -- TODO: Remove!  -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat(@@ -16,7 +17,6 @@     mkHieFile,     mkHieFile',     enrichHie,-    RefMap,     writeHieFile,     readHieFile,     supportsHieFiles,@@ -25,6 +25,7 @@ #if !MIN_VERSION_ghc(8,8,0)     ml_hie_file,     addBootSuffixLocnOut,+    getRealSrcSpan, #endif     hPutStringBuffer,     addIncludePathsQuote,@@ -52,6 +53,74 @@     linkableTime, #endif +#if MIN_VERSION_ghc(9,0,1)+    -- Reexports from GHC+    UnitId,+    moduleUnitId,+    pkgState,+    thisInstalledUnitId,+    -- Reexports from DynFlags+    thisPackage,+    writeIfaceFile,++    gcatch,+#else+    RefMap,+    Unit,+#endif+    -- Linear+    Scaled,+    scaledThing,++    lookupUnit',+    preloadClosureUs,+    -- Reexports from Package+    InstalledUnitId,+    PackageConfig,+    getPackageConfigMap,+    getPackageIncludePath,+    installedModule,++    pattern DefiniteUnitId,+    packageName,+    packageNameString,+    packageVersion,+    toInstalledUnitId,+    lookupPackage,+    -- lookupPackage',+    explicitPackages,+    exposedModules,+    packageConfigId,+    setThisInstalledUnitId,+    initUnits,+    lookupInstalledPackage,+    oldLookupInstalledPackage,+    unitDepends,++    haddockInterfaces,++    oldUnhelpfulSpan ,+    pattern IsBoot,+    pattern NotBoot,+    pattern OldRealSrcSpan,++    oldRenderWithStyle,+    oldMkUserStyle,+    oldMkErrStyle,+    oldFormatErrDoc,+    oldListVisibleModuleNames,+    oldLookupModuleWithSuggestions,++    nodeInfo',+    getNodeIds,+    stringToUnit,+    rtsUnit,++    LogActionCompat,+    logActionCompat,++    pprSigmaType,+     module GHC,     module DynFlags,     initializePlugins,@@ -62,60 +131,74 @@     ,isQualifiedImport) where  #if MIN_VERSION_ghc(8,10,0)-import LinkerTypes+import           LinkerTypes #endif -import StringBuffer+import           DynFlags               hiding (ExposePackage) import qualified DynFlags-import DynFlags hiding (ExposePackage)-import Fingerprint (Fingerprint)+import qualified ErrUtils               as Err+import           Fingerprint            (Fingerprint) import qualified Module-import Packages-import Data.IORef-import HscTypes-import NameCache-import qualified Data.ByteString as BS-import MkIface-import TcRnTypes-import Compat.HieAst (mkHieFile,enrichHie)-import Compat.HieBin-import Compat.HieTypes-import Compat.HieUtils+import qualified Outputable             as Out+import           StringBuffer+#if MIN_VERSION_ghc(9,0,1)+import           Control.Exception.Safe as Safe (Exception, MonadCatch, catch)+import qualified Data.Set               as S+import           GHC.Core.TyCo.Ppr      (pprSigmaType)+import           GHC.Core.TyCo.Rep      (Scaled, scaledThing)+import           GHC.Iface.Load+import           GHC.Types.Unique.Set   (emptyUniqSet)+import qualified SrcLoc+#else+import           Module                 (InstalledUnitId,+                                         UnitId (DefiniteUnitId),+                                         toInstalledUnitId)+import           TcType                 (pprSigmaType)+#endif+import           Compat.HieAst          (enrichHie, mkHieFile)+import           Compat.HieBin+import           Compat.HieTypes+import           Compat.HieUtils+import qualified Data.ByteString        as BS+import           Data.IORef+import           HscTypes+import           MkIface+import           NameCache+import           Packages+import           TcRnTypes  #if MIN_VERSION_ghc(8,10,0)-import GHC.Hs.Extension+import           GHC.Hs.Extension #else-import HsExtension+import           HsExtension #endif +import           Avail+import           GHC                    hiding (HasSrcSpan, ModLocation, getLoc,+                                         lookupName) import qualified GHC import qualified TyCoRep-import GHC hiding (-      ModLocation,-      HasSrcSpan,-      lookupName,-      getLoc-    )-import Avail #if MIN_VERSION_ghc(8,8,0)-import Data.List (foldl')+import           Data.List              (foldl') #else-import Data.List (foldl', isSuffixOf)+import           Data.List              (foldl', isSuffixOf) #endif -import DynamicLoading-import Plugins (Plugin(parsedResultAction), withPlugins)-import Data.Map.Strict (Map)+import qualified Data.Map               as M+import           DynamicLoading+import           Plugins                (Plugin (parsedResultAction),+                                         withPlugins)  #if !MIN_VERSION_ghc(8,8,0)-import System.FilePath ((-<.>))+import           SrcLoc                 (RealLocated)+import           System.FilePath        ((-<.>)) #endif  #if !MIN_VERSION_ghc(8,8,0) import qualified EnumSet -import System.IO-import Foreign.ForeignPtr+import           Foreign.ForeignPtr+import           System.IO   hPutStringBuffer :: Handle -> StringBuffer -> IO ()@@ -152,7 +235,9 @@ #endif  -type RefMap a = Map Identifier [(Span, IdentifierDetails a)]+#if !MIN_VERSION_ghc(9,0,1)+type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)]+#endif  mkHieFile' :: ModSummary            -> [AvailInfo]@@ -177,10 +262,11 @@     where f i = i{includePathsQuote = path : includePathsQuote i}  pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation-pattern ModLocation a b c <- #if MIN_VERSION_ghc(8,8,0)+pattern ModLocation a b c <-     GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" #else+pattern ModLocation a b c <-     GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c #endif @@ -225,8 +311,20 @@ nameListFromAvails as =   map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) -#if MIN_VERSION_ghc(8,8,0)+#if MIN_VERSION_ghc(9,0,0)+-- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x)+-- type HasSrcSpan x = () :: Constraint +class HasSrcSpan a where+  getLoc :: a -> SrcSpan++instance HasSrcSpan (GenLocated SrcSpan a) where+  getLoc = GHC.getLoc++-- getLoc :: GenLocated l a -> l+-- getLoc = GHC.getLoc++#elif MIN_VERSION_ghc(8,8,0) type HasSrcSpan = GHC.HasSrcSpan getLoc :: HasSrcSpan a => a -> SrcSpan getLoc = GHC.getLoc@@ -256,9 +354,138 @@ getModuleHash = mi_mod_hash #endif -getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName-getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))+-- type PackageName = Packages.PackageName+#if MIN_VERSION_ghc(9,0,0)+-- NOTE: Since both the new and old version uses UnitId with different meaning,+-- we try to avoid it and instead use InstalledUnitId and Unit, since it is unambiguous.+type UnitId            = Module.Unit+type InstalledUnitId   = Module.UnitId+type PackageConfig     = Packages.UnitInfo+pattern DefiniteUnitId x = Module.RealUnit x+definiteUnitId         = Module.RealUnit+defUnitId              = Module.Definite+installedModule        = Module.Module+-- pattern InstalledModule a b = Module.Module a b+packageName            = Packages.unitPackageName+lookupPackage          = Packages.lookupUnit . unitState+-- lookupPackage'         = undefined+-- lookupPackage' b pm u  = Packages.lookupUnit' b pm undefined u+-- lookupPackage' b pm u  = Packages.lookupUnit' b pm emptyUniqSet u -- TODO: Is this correct?+-- lookupPackage'         = fmap Packages.lookupUnit' . unitState+getPackageConfigMap    = Packages.unitInfoMap . unitState+preloadClosureUs         = Packages.preloadClosure . unitState+-- getPackageConfigMap    = unitState+-- getPackageIncludePath  = undefined+getPackageIncludePath  = Packages.getUnitIncludePath+explicitPackages       = Packages.explicitUnits+pkgState               = GHC.unitState+packageNameString      = Packages.unitPackageNameString+packageVersion         = Packages.unitPackageVersion+-- toInstalledUnitId      = id -- Module.toUnitId -- TODO: This is probably wrong+toInstalledUnitId      = Module.toUnitId+exposedModules         = Packages.unitExposedModules+packageConfigId        = Packages.mkUnit+moduleUnitId           = Module.moduleUnit+lookupInstalledPackage = Packages.lookupUnitId+oldLookupInstalledPackage = Packages.lookupUnitId . unitState+-- initUnits              = Packages.initUnits+-- initPackages           = initPackagesx+haddockInterfaces      = unitHaddockInterfaces +thisInstalledUnitId    = GHC.homeUnitId+thisPackage            = DynFlags.homeUnit+setThisInstalledUnitId uid df = df { homeUnitId = uid}++oldUnhelpfulSpan  = UnhelpfulSpan . SrcLoc.UnhelpfulOther+-- unhelpfulOther = unhelpfulOther . _+pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan+pattern OldRealSrcSpan x <- RealSrcSpan x _ where+    OldRealSrcSpan x = RealSrcSpan x Nothing+{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-}++oldListVisibleModuleNames = Packages.listVisibleModuleNames . unitState+oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions . unitState+-- oldLookupInPackageDB = Packages.lookupInPackageDB . unitState++oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc+oldMkUserStyle _ = Out.mkUserStyle+oldMkErrStyle _ = Out.mkErrStyle++-- TODO: This is still a mess!+oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc+oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext+  where dummySDocContext = initSDocContext dflags Out.defaultUserStyle+-- oldFormatErrDoc = Err.formatErrDoc . undefined+writeIfaceFile = writeIface++type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO ()++-- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test.+logActionCompat :: LogActionCompat -> LogAction+logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify++-- We are using Safe here, which is not equivalent, but probably what we want.+gcatch :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a+gcatch = Safe.catch++#else++type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO ()++logActionCompat :: LogActionCompat -> LogAction+logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (Out.queryQual style)++type Unit = Module.UnitId+-- type PackageConfig = Packages.PackageConfig+definiteUnitId :: Module.DefUnitId -> UnitId+definiteUnitId = Module.DefiniteUnitId+defUnitId :: InstalledUnitId -> Module.DefUnitId+defUnitId = Module.DefUnitId+installedModule :: InstalledUnitId -> ModuleName -> Module.InstalledModule+installedModule = Module.InstalledModule+oldLookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig+oldLookupInstalledPackage = Packages.lookupInstalledPackage+-- packageName = Packages.packageName+-- lookupPackage = Packages.lookupPackage+-- getPackageConfigMap = Packages.getPackageConfigMap+setThisInstalledUnitId :: InstalledUnitId -> DynFlags -> DynFlags+setThisInstalledUnitId uid df = df { thisInstalledUnitId = uid}++lookupUnit' :: Bool -> PackageConfigMap -> p -> UnitId -> Maybe PackageConfig+lookupUnit' b pcm _ = Packages.lookupPackage' b pcm+preloadClosureUs = const ()++oldUnhelpfulSpan  = UnhelpfulSpan+pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan+pattern OldRealSrcSpan x = RealSrcSpan x+{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-}++pattern NotBoot, IsBoot :: IsBootInterface+pattern NotBoot = False+pattern IsBoot = True++initUnits              = fmap fst . Packages.initPackages++unitDepends            = depends++oldListVisibleModuleNames = Packages.listVisibleModuleNames+oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions+-- oldLookupInPackageDB = Packages.lookupInPackageDB++oldRenderWithStyle = Out.renderWithStyle+oldMkUserStyle = Out.mkUserStyle+oldMkErrStyle = Out.mkErrStyle+oldFormatErrDoc = Err.formatErrDoc++-- Linear Haskell+type Scaled a = a+scaledThing :: Scaled a -> a+scaledThing = id+#endif++getPackageName :: DynFlags -> InstalledUnitId -> Maybe PackageName+getPackageName dfs i = packageName <$> lookupPackage dfs (definiteUnitId (defUnitId i))+ disableWarningsAsErrors :: DynFlags -> DynFlags disableWarningsAsErrors df =     flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..]@@ -267,6 +494,9 @@ wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags wopt_unset_fatal dfs f     = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }++getRealSrcSpan :: RealLocated a -> RealSrcSpan+getRealSrcSpan = GHC.getLoc #endif  applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource@@ -303,8 +533,59 @@ isQualifiedImport :: ImportDecl a -> Bool #if MIN_VERSION_ghc(8,10,0) isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False-isQualifiedImport ImportDecl{} = True+isQualifiedImport ImportDecl{}                              = True #else-isQualifiedImport ImportDecl{ideclQualified} = ideclQualified+isQualifiedImport ImportDecl{ideclQualified}                = ideclQualified #endif-isQualifiedImport _ = False+isQualifiedImport _                                         = False++++#if __GLASGOW_HASKELL__ >= 900+getNodeIds :: HieAST a -> M.Map Identifier (IdentifierDetails a)+getNodeIds = M.foldl' combineNodeIds M.empty . getSourcedNodeInfo . sourcedNodeInfo++ad `combineNodeIds` (NodeInfo _ _ bd) = M.unionWith (<>) ad bd++--  Copied from GHC and adjusted to accept TypeIndex instead of Type+-- nodeInfo' :: Ord a => HieAST a -> NodeInfo a+nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex+nodeInfo' = M.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo++combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a+(NodeInfo as ai ad) `combineNodeInfo'` (NodeInfo bs bi bd) =+  NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)+  where+    mergeSorted :: Ord a => [a] -> [a] -> [a]+    mergeSorted la@(a:as) lb@(b:bs) = case compare a b of+                                        LT -> a : mergeSorted as lb+                                        EQ -> a : mergeSorted as bs+                                        GT -> b : mergeSorted la bs+    mergeSorted as [] = as+    mergeSorted [] bs = bs++stringToUnit = Module.stringToUnit+rtsUnit = Module.rtsUnit+#else++getNodeIds = nodeIdentifiers . nodeInfo+-- import qualified FastString as FS++-- nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex+nodeInfo' :: Ord a => HieAST a -> NodeInfo a+nodeInfo' = nodeInfo+-- type Unit = UnitId+-- unitString :: Unit -> String+-- unitString = unitIdString+stringToUnit :: String -> Unit+stringToUnit = Module.stringToUnitId+-- moduleUnit :: Module -> Unit+-- moduleUnit = moduleUnitId+-- unhelpfulSpanFS :: FS.FastString -> FS.FastString+-- unhelpfulSpanFS = id+rtsUnit = Module.rtsUnitId+#endif++#if MIN_VERSION_ghc(9,0,0)+#else+#endif

@@ -33,6 +33,7 @@ import           Data.Maybe import           Data.String                       (fromString) import qualified Data.Text                         as T+import qualified Development.IDE.GHC.Compat        as GHC import           Development.IDE.GHC.Orphans       () import           Development.IDE.Types.Diagnostics as D import           Development.IDE.Types.Location@@ -68,8 +69,8 @@ formatErrorWithQual :: DynFlags -> ErrMsg -> String formatErrorWithQual dflags e =     Out.showSDoc dflags-    $ Out.withPprStyle (Out.mkErrStyle dflags $ errMsgContext e)-    $ ErrUtils.formatErrDoc dflags+    $ Out.withPprStyle (GHC.oldMkErrStyle dflags $ errMsgContext e)+    $ GHC.oldFormatErrDoc dflags     $ ErrUtils.errMsgDoc e  diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]@@ -77,8 +78,9 @@  -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range-srcSpanToRange (UnhelpfulSpan _)  = Nothing-srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real+srcSpanToRange (UnhelpfulSpan _)         = Nothing+srcSpanToRange (GHC.OldRealSrcSpan real) = Just $ realSrcSpanToRange real+-- srcSpanToRange = fmap realSrcSpanToRange . realSpan  realSrcSpanToRange :: RealSrcSpan -> Range realSrcSpanToRange real =@@ -93,7 +95,8 @@ -- FIXME This may not be an _absolute_ file name, needs fixing. srcSpanToFilename :: SrcSpan -> Maybe FilePath srcSpanToFilename (UnhelpfulSpan _)  = Nothing-srcSpanToFilename (RealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real+srcSpanToFilename (GHC.OldRealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real+-- srcSpanToFilename = fmap (FS.unpackFS . srcSpanFile) . realSpan  realSrcSpanToLocation :: RealSrcSpan -> Location realSrcSpanToLocation real = Location file (realSrcSpanToRange real)@@ -107,7 +110,7 @@   pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng  rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan-rangeToSrcSpan = fmap RealSrcSpan . rangeToRealSrcSpan+rangeToSrcSpan = fmap GHC.OldRealSrcSpan . rangeToRealSrcSpan  rangeToRealSrcSpan     :: NormalizedFilePath -> Range -> RealSrcSpan@@ -149,7 +152,7 @@  -- | Produces an "unhelpful" source span with the given string. noSpan :: String -> SrcSpan-noSpan = UnhelpfulSpan . FS.fsLit+noSpan = GHC.oldUnhelpfulSpan  . FS.fsLit   -- | creates a span with zero length in the filename of the argument passed@@ -160,8 +163,8 @@ realSpan :: SrcSpan          -> Maybe RealSrcSpan realSpan = \case-  RealSrcSpan r   -> Just r-  UnhelpfulSpan _ -> Nothing+  GHC.OldRealSrcSpan r -> Just r+  UnhelpfulSpan _      -> Nothing   -- | Catch the errors thrown by GHC (SourceErrors and

@@ -32,42 +32,46 @@     ) where -import BasicTypes (appPrec)-import Control.Applicative (Alternative)-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import Control.Monad.Zip-import qualified Data.DList as DL-import Data.Either.Extra (mapLeft)-import Data.Functor.Classes-import Data.Functor.Contravariant-import qualified Data.Text as T-import Development.IDE.Core.RuleTypes-import Development.IDE.Core.Service (runAction)-import Development.IDE.Core.Shake-import Development.IDE.GHC.Compat hiding (parseExpr)-import Development.IDE.Types.Location-import Development.IDE.Graph (RuleResult, Rules)-import Development.IDE.Graph.Classes-import qualified GHC.Generics as GHC-import Generics.SYB-import Generics.SYB.GHC-import Ide.PluginUtils-import Language.Haskell.GHC.ExactPrint-import Language.Haskell.GHC.ExactPrint.Parsers-import Language.LSP.Types-import Language.LSP.Types.Capabilities (ClientCapabilities)-import Outputable (Outputable, ppr, showSDoc)-import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType)-import Parser (parseIdentifier)-import Data.Traversable (for)-import Data.Foldable (Foldable(fold))-import Data.Bool (bool)-import Data.Monoid (All(All), getAll)-import Control.Arrow+import           BasicTypes                              (appPrec)+import           Control.Applicative                     (Alternative)+import           Control.Arrow+import           Control.Monad+import qualified Control.Monad.Fail                      as Fail+import           Control.Monad.IO.Class                  (MonadIO)+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Except+import           Control.Monad.Zip+import           Data.Bool                               (bool)+import qualified Data.DList                              as DL+import           Data.Either.Extra                       (mapLeft)+import           Data.Foldable                           (Foldable (fold))+import           Data.Functor.Classes+import           Data.Functor.Contravariant+import           Data.Monoid                             (All (All), getAll)+import qualified Data.Text                               as T+import           Data.Traversable                        (for)+import           Development.IDE.Core.RuleTypes+import           Development.IDE.Core.Service            (runAction)+import           Development.IDE.Core.Shake+import           Development.IDE.GHC.Compat              hiding (parseExpr)+import           Development.IDE.Graph                   (RuleResult, Rules)+import           Development.IDE.Graph.Classes+import           Development.IDE.Types.Location+import qualified GHC.Generics                            as GHC+import           Generics.SYB+import           Generics.SYB.GHC+import           Ide.PluginUtils+import           Language.Haskell.GHC.ExactPrint+import           Language.Haskell.GHC.ExactPrint.Parsers+import           Language.LSP.Types+import           Language.LSP.Types.Capabilities         (ClientCapabilities)+import           Outputable                              (Outputable, ppr,+                                                          showSDoc)+import           Parser                                  (parseIdentifier)+import           Retrie.ExactPrint                       hiding (parseDecl,+                                                          parseExpr,+                                                          parsePattern,+                                                          parseType)   ------------------------------------------------------------------------------@@ -199,7 +203,7 @@ needsParensSpace HsLet{}         = (All False, All True) needsParensSpace HsDo{}          = (All False, All False) needsParensSpace ExplicitList{}  = (All False, All False)-needsParensSpace RecordCon{}     = (All False, All False)+needsParensSpace RecordCon{}     = (All False, All True) needsParensSpace RecordUpd{}     = mempty needsParensSpace _               = mempty @@ -230,7 +234,7 @@             ( mkT $                 \case                     (L src _ :: Located ast) | src == dst -> val'-                    l -> l+                    l                                     -> l             )             a 

@@ -35,15 +35,23 @@ instance NFData Linkable where rnf = rwhnf instance Show PackageFlag where show = prettyPrint instance Show InteractiveImport where show = prettyPrint-instance Show ComponentId  where show = prettyPrint instance Show PackageName  where show = prettyPrint++#if !MIN_VERSION_ghc(9,0,1)+instance Show ComponentId  where show = prettyPrint instance Show SourcePackageId  where show = prettyPrint -instance Show InstalledUnitId where+instance Show GhcPlugins.InstalledUnitId where     show = installedUnitIdString -instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS+instance NFData GhcPlugins.InstalledUnitId where rnf = rwhnf . installedUnitIdFS +instance Hashable GhcPlugins.InstalledUnitId where+  hashWithSalt salt = hashWithSalt salt . installedUnitIdString+#else+instance Show InstalledUnitId where show = prettyPrint+#endif+ instance NFData SB.StringBuffer where rnf = rwhnf  instance Show Module where@@ -71,9 +79,6 @@ instance NFData ParsedModule where     rnf = rwhnf -instance Hashable InstalledUnitId where-  hashWithSalt salt = hashWithSalt salt . installedUnitIdString- instance Show HieFile where     show = show . hie_module @@ -149,4 +154,11 @@   show _ = "<Annotated ParsedSource>"  instance NFData (Annotated ParsedSource) where+  rnf = rwhnf++#if MIN_VERSION_ghc(9,0,1)+instance (NFData HsModule) where+#else+instance (NFData (HsModule a)) where+#endif   rnf = rwhnf

@@ -67,12 +67,8 @@ import           Module                         (moduleNameSlashes) import           OccName                        (parenSymOcc) import           Outputable                     (Depth (..), Outputable, SDoc,-                                                 mkUserStyle, neverQualify, ppr,-                                                 renderWithStyle,+                                                 neverQualify, ppr,                                                  showSDocUnsafe)-import           PackageConfig                  (PackageConfig)-import           Packages                       (getPackageConfigMap,-                                                 lookupPackage') import           RdrName                        (nameRdrName, rdrNameOcc) import           SrcLoc                         (mkRealSrcLoc) import           StringBuffer@@ -92,15 +88,17 @@   modifySession $ \h ->     h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } --- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment.-lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig-lookupPackageConfig unitId env =-    lookupPackage' False pkgConfigMap unitId+-- | Given a 'Unit' try and find the associated 'PackageConfig' in the environment.+lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.PackageConfig+lookupPackageConfig unit env =+    -- GHC.lookupPackage' False pkgConfigMap unit+    GHC.lookupUnit' False pkgConfigMap prClsre unit     where         pkgConfigMap =             -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap             -- from PackageState so we have to wrap it in DynFlags first.             getPackageConfigMap $ hsc_dflags env+        prClsre = preloadClosureUs $ hsc_dflags env   -- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.@@ -127,7 +125,7 @@ prettyPrint = unsafePrintSDoc . ppr  unsafePrintSDoc :: SDoc -> String-unsafePrintSDoc sdoc = renderWithStyle dflags sdoc (mkUserStyle dflags neverQualify AllTheWay)+unsafePrintSDoc sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay)   where     dflags = unsafeGlobalDynFlags @@ -260,13 +258,17 @@  -- | This is copied unmodified from GHC since it is not exposed. -- Note the beautiful inline comment!+#if MIN_VERSION_ghc(9,0,0)+dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev+#else dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev+#endif            -> FilePath            -> Maybe (MVar Handle__)            -> Handle__            -> Maybe HandleFinalizer            -> IO Handle-dupHandle_ new_dev filepath other_side _h_@Handle__{..} mb_finalizer = do+dupHandle_ new_dev filepath other_side Handle__{..} mb_finalizer = do    -- XXX wrong!   mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing   mkHandle new_dev filepath haType True{-buffered-} mb_codec

@@ -11,6 +11,8 @@ import           Control.Concurrent.Strict import qualified Data.Text                         as T +import           Development.IDE.GHC.Compat        (LogActionCompat,+                                                    logActionCompat) import           Development.IDE.GHC.Error import           Development.IDE.Types.Diagnostics import           Language.LSP.Types                (type (|?) (..))@@ -28,11 +30,11 @@ withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) withWarnings diagSource action = do   warnings <- newVar []-  let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()-      newAction dynFlags wr _ loc style msg = do-        let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg+  let newAction :: LogActionCompat+      newAction dynFlags wr _ loc prUnqual msg = do+        let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc prUnqual msg         modifyVar_ warnings $ return . (wr_d:)-  res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}}+  res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = logActionCompat newAction}}   warns <- readVar warnings   return (reverse $ concat warns, res) 

@@ -13,7 +13,7 @@   , mkImportDirs   ) where -import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat        as Compat import           Development.IDE.GHC.Error         as ErrUtils import           Development.IDE.GHC.Orphans       () import           Development.IDE.Types.Diagnostics@@ -87,7 +87,7 @@ -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package.-mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])+mkImportDirs :: DynFlags -> (Compat.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i  -- | locate a module in either the file system or the package database. Where we go from *daml to@@ -95,7 +95,7 @@ locateModule     :: MonadIO m     => DynFlags-    -> [(M.InstalledUnitId, DynFlags)] -- ^ Import directories+    -> [(Compat.InstalledUnitId, DynFlags)] -- ^ Import directories     -> [String]                        -- ^ File extensions     -> (ModuleName -> NormalizedFilePath -> m Bool)  -- ^ does file exist predicate     -> Located ModuleName              -- ^ Module name@@ -135,7 +135,7 @@         Just file -> toModLocation file      lookupInPackageDB dfs =-      case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of+      case oldLookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of         LookupFound _m _pkgConfig -> return $ Right PackageImport         reason -> return $ Left $ notFoundErr dfs modName reason 

@@ -122,8 +122,7 @@         handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do             traceWithSpan sp params             let root = LSP.resRootPath env--            dir <- getCurrentDirectory+            dir <- maybe getCurrentDirectory return root             dbLoc <- getHieDbLoc dir              -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference

@@ -11,10 +11,8 @@     , descriptor     ) where -import qualified Language.LSP.Server                   as LSP import           Language.LSP.Types import qualified Language.LSP.Types                    as LSP-import qualified Language.LSP.Types.Capabilities       as LSP  import           Development.IDE.Core.IdeConfiguration import           Development.IDE.Core.Service@@ -24,18 +22,20 @@ import           Development.IDE.Types.Options  import           Control.Monad.Extra-import qualified Data.HashMap.Strict                   as M import qualified Data.HashSet                          as S import qualified Data.Text                             as Text  import           Control.Monad.IO.Class import           Development.IDE.Core.FileExists       (modifyFileExists,                                                         watchedGlobs)-import           Development.IDE.Core.FileStore        (resetFileStore,+import           Development.IDE.Core.FileStore        (registerFileWatches,+                                                        resetFileStore,                                                         setFileModified,                                                         setSomethingModified,                                                         typecheckParents) import           Development.IDE.Core.OfInterest+import           Development.IDE.Core.RuleTypes        (GetClientSettings (..))+import           Development.IDE.Types.Shake           (toKey) import           Ide.Plugin.Config                     (CheckParents (CheckOnClose)) import           Ide.Types @@ -50,7 +50,7 @@       whenUriFile _uri $ \file -> do           -- We don't know if the file actually exists, or if the contents match those on disk           -- For example, vscode restores previously unsaved contents on open-          modifyFilesOfInterest ide (M.insert file Modified{firstOpen=True})+          addFileOfInterest ide file Modified{firstOpen=True}           setFileModified ide False file           logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri @@ -58,21 +58,21 @@       \ide _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do         updatePositionMapping ide identifier changes         whenUriFile _uri $ \file -> do-          modifyFilesOfInterest ide (M.insert file Modified{firstOpen=False})+          addFileOfInterest ide file Modified{firstOpen=False}           setFileModified ide False file         logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri    , mkPluginNotificationHandler LSP.STextDocumentDidSave $       \ide _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do         whenUriFile _uri $ \file -> do-            modifyFilesOfInterest ide (M.insert file OnDisk)+            addFileOfInterest ide file OnDisk             setFileModified ide True file         logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri    , mkPluginNotificationHandler LSP.STextDocumentDidClose $         \ide _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do           whenUriFile _uri $ \file -> do-              modifyFilesOfInterest ide (M.delete file)+              deleteFileOfInterest ide file               -- Refresh all the files that depended on this               checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide)               when (checkParents >= CheckOnClose) $ typecheckParents ide file@@ -86,7 +86,7 @@         logDebug (ideLogger ide) $ "Watched file events: " <> msg         modifyFileExists ide fileEvents         resetFileStore ide fileEvents-        setSomethingModified ide+        setSomethingModified ide []    , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $       \ide _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do@@ -101,45 +101,22 @@         let msg = Text.pack $ show cfg         logDebug (ideLogger ide) $ "Configuration changed: " <> msg         modifyClientSettings ide (const $ Just cfg)-        setSomethingModified ide+        setSomethingModified ide [toKey GetClientSettings emptyFilePath ]    , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do       --------- Initialize Shake session --------------------------------------------------------------------       liftIO $ shakeSessionInit ide        --------- Set up file watchers -------------------------------------------------------------------------      clientCapabilities <- LSP.getClientCapabilities-      let watchSupported = case () of-            _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities-              , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace-              , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles-              , Just True <- _dynamicRegistration-                -> True-              | otherwise -> False-      if watchSupported-      then do-        opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide-        let-          regParams    = RegistrationParams (List [SomeRegistration registration])-          -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).-          -- We could also use something like a random UUID, as some other servers do, but this works for-          -- our purposes.-          registration = Registration "globalFileWatches"-                                      SWorkspaceDidChangeWatchedFiles-                                      regOptions-          regOptions =-            DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }-          -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind-          watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}-          -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is-          -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,-          -- followed by a file with an extension 'hs'.-          watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }-          -- We use multiple watchers instead of one using '{}' because lsp-test doesn't-          -- support that: https://github.com/bubba/lsp-test/issues/77-          watchers = [ watcher (Text.pack glob) | glob <- watchedGlobs opts ]--        void $ LSP.sendRequest SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response-      else liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"+      opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide+        -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is+        -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,+        -- followed by a file with an extension 'hs'.+        -- We use multiple watchers instead of one using '{}' because lsp-test doesn't+        -- support that: https://github.com/bubba/lsp-test/issues/77+      let globs = watchedGlobs opts+      success <- registerFileWatches globs+      unless success $+        liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"   ]     }

@@ -18,7 +18,8 @@ import           Development.IDE.Core.Rules import           Development.IDE.Core.Shake import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Error      (realSrcSpanToRange, rangeToRealSrcSpan)+import           Development.IDE.GHC.Error      (rangeToRealSrcSpan,+                                                 realSrcSpanToRange) import           Development.IDE.Types.Location import           Language.LSP.Server            (LspM) import           Language.LSP.Types@@ -37,7 +38,7 @@           -> let                declSymbols  = mapMaybe documentSymbolForDecl hsmodDecls                moduleSymbol = hsmodName >>= \case-                 (L (RealSrcSpan l) m) -> Just $+                 (L (OldRealSrcSpan l) m) -> Just $                    (defDocumentSymbol l :: DocumentSymbol)                      { _name  = pprText m                      , _kind  = SkFile@@ -60,7 +61,7 @@     Nothing -> pure $ Right $ InL (List [])  documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol-documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))+documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name   = showRdrName n                   <> (case pprText fdTyVars of@@ -70,7 +71,7 @@     , _detail = Just $ pprText fdInfo     , _kind   = SkFunction     }-documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))+documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name     = showRdrName name                     <> (case pprText tcdTyVars of@@ -86,11 +87,11 @@             , _kind           = SkMethod             , _selectionRange = realSrcSpanToRange l'             }-        | L (RealSrcSpan l)  (ClassOpSig _ False names _) <- tcdSigs-        , L (RealSrcSpan l') n                            <- names+        | L (OldRealSrcSpan l)  (ClassOpSig _ False names _) <- tcdSigs+        , L (OldRealSrcSpan l') n                            <- names         ]     }-documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))+documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name     = showRdrName name     , _kind     = SkStruct@@ -100,10 +101,10 @@             { _name           = showRdrName n             , _kind           = SkConstructor             , _selectionRange = realSrcSpanToRange l'-            , _children       = conArgRecordFields (getConArgs x)+            , _children       = conArgRecordFields (con_args x)             }-        | L (RealSrcSpan l ) x <- dd_cons-        , L (RealSrcSpan l') n <- getConNames x+        | L (OldRealSrcSpan l ) x <- dd_cons+        , L (OldRealSrcSpan l') n <- getConNames' x         ]     }   where@@ -114,48 +115,48 @@           , _kind = SkField           }       | L _ cdf <- lcdfs-      , L (RealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf+      , L (OldRealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf       ]     conArgRecordFields _ = Nothing-documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l') n })) = Just+documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (OldRealSrcSpan l') n })) = Just   (defDocumentSymbol l :: DocumentSymbol) { _name           = showRdrName n                                           , _kind           = SkTypeParameter                                           , _selectionRange = realSrcSpanToRange l'                                           }-documentSymbolForDecl (L (RealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))+documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))   = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty                                                  , _kind = SkInterface                                                  }-documentSymbolForDecl (L (RealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))+documentSymbolForDecl (L (OldRealSrcSpan 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 (RealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))+documentSymbolForDecl (L (OldRealSrcSpan 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 (RealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) =+documentSymbolForDecl (L (OldRealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) =   gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) ->     (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs)                                               name                                             , _kind = SkInterface                                             }-documentSymbolForDecl (L (RealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just+documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just     (defDocumentSymbol l :: DocumentSymbol)       { _name   = showRdrName name       , _kind   = SkFunction       }-documentSymbolForDecl (L (RealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just+documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just     (defDocumentSymbol l :: DocumentSymbol)       { _name   = pprText pat_lhs       , _kind   = SkFunction       } -documentSymbolForDecl (L (RealSrcSpan l) (ForD _ x)) = Just+documentSymbolForDecl (L (OldRealSrcSpan l) (ForD _ x)) = Just   (defDocumentSymbol l :: DocumentSymbol)     { _name   = case x of                   ForeignImport{} -> name@@ -189,7 +190,7 @@           }  documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol-documentSymbolForImport (L (RealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just+documentSymbolForImport (L (OldRealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just   (defDocumentSymbol l :: DocumentSymbol)     { _name   = "import " <> pprText ideclName     , _kind   = SkModule@@ -217,3 +218,13 @@  pprText :: Outputable a => a -> Text pprText = pack . showSDocUnsafe . ppr++-- the version of getConNames for ghc9 is restricted to only the renaming phase+getConNames' :: ConDecl GhcPs -> [Located (IdP GhcPs)]+getConNames' ConDeclH98  {con_name  = name}  = [name]+getConNames' ConDeclGADT {con_names = names} = names+#if !MIN_VERSION_ghc(8,10,0)+getConNames' (XConDecl NoExt)                = []+#elif !MIN_VERSION_ghc(9,0,0)+getConNames' (XConDecl x)                    = noExtCon x+#endif

@@ -14,19 +14,20 @@ import           Control.Monad.Extra                   (concatMapM, unless,                                                         when) import           Data.Default                          (Default (def))+import           Data.Foldable                         (traverse_) import qualified Data.HashMap.Strict                   as HashMap import           Data.Hashable                         (hashed) import           Data.List.Extra                       (intercalate, isPrefixOf,                                                         nub, nubOrd, partition)-import           Data.Maybe                            (catMaybes, fromMaybe,-                                                        isJust)+import           Data.Maybe                            (catMaybes, isJust) import qualified Data.Text                             as T import qualified Data.Text.IO                          as T import           Development.IDE                       (Action, Rules,                                                         hDuplicateTo') import           Development.IDE.Core.Debouncer        (Debouncer,                                                         newAsyncDebouncer)-import           Development.IDE.Core.FileStore        (makeVFSHandle)+import           Development.IDE.Core.FileStore        (isWatchSupported,+                                                        makeVFSHandle) import           Development.IDE.Core.IdeConfiguration (IdeConfiguration (..),                                                         registerIdeConfiguration) import           Development.IDE.Core.OfInterest       (FileOfInterestStatus (OnDisk),@@ -46,7 +47,7 @@ import           Development.IDE.Core.Tracing          (measureMemory) import           Development.IDE.Graph                 (action) import           Development.IDE.LSP.LanguageServer    (runLanguageServer)-import           Development.IDE.Plugin                (Plugin (pluginHandlers, pluginRules))+import           Development.IDE.Plugin                (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import           Development.IDE.Plugin.HLS            (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS.GhcIde     as Ghcide import           Development.IDE.Session               (SessionLoadingOptions,@@ -58,9 +59,10 @@                                                         toNormalizedFilePath') import           Development.IDE.Types.Logger          (Logger (Logger)) import           Development.IDE.Types.Options         (IdeGhcSession,-                                                        IdeOptions (optCheckParents, optCheckProject, optReportProgress),+                                                        IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),                                                         clientSupportsProgress,-                                                        defaultIdeOptions)+                                                        defaultIdeOptions,+                                                        optModifyDynFlags) import           Development.IDE.Types.Shake           (Key (Key)) import           GHC.IO.Encoding                       (setLocaleEncoding) import           GHC.IO.Handle                         (hDuplicate)@@ -201,23 +203,30 @@             hPutStrLn stderr "Starting LSP server..."             hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"             runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do+                traverse_ IO.setCurrentDirectory rootPath                 t <- t                 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t -                dir <- IO.getCurrentDirectory+                dir <- maybe IO.getCurrentDirectory return rootPath                  -- We want to set the global DynFlags right now, so that we can use                 -- `unsafeGlobalDynFlags` even before the project is configured-                -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')-                -- before calling this function                 _mlibdir <--                    setInitialDynFlags argsSessionLoadingOptions+                    setInitialDynFlags dir argsSessionLoadingOptions                         `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) -                sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath++                sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir                 config <- LSP.runLspT env LSP.getConfig-                let options = (argsIdeOptions config sessionLoader)+                let def_options = argsIdeOptions config sessionLoader++                -- disable runSubset if the client doesn't support watched files+                runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported++                let options = def_options                             { optReportProgress = clientSupportsProgress caps+                            , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins+                            , optRunSubset = runSubset                             }                     caps = LSP.resClientCapabilities env                 initialise@@ -256,9 +265,11 @@             putStrLn "\nStep 3/4: Initializing the IDE"             vfs <- makeVFSHandle             sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir-            let options = (argsIdeOptions argsDefaultHlsConfig sessionLoader)+            let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader+                options = def_options                         { optCheckParents = pure NeverCheck                         , optCheckProject = pure False+                        , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                         }             ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan             shakeSessionInit ide@@ -295,7 +306,7 @@         Db dir opts cmd -> do             dbLoc <- getHieDbLoc dir             hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc-            mlibdir <- setInitialDynFlags def+            mlibdir <- setInitialDynFlags dir def             case mlibdir of                 Nothing     -> exitWith $ ExitFailure 1                 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd@@ -304,10 +315,11 @@           runWithDb dbLoc $ \hiedb hieChan -> do             vfs <- makeVFSHandle             sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "."-            let options =-                  (argsIdeOptions argsDefaultHlsConfig sessionLoader)-                    { optCheckParents = pure NeverCheck,-                      optCheckProject = pure False+            let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader+                options = def_options+                    { optCheckParents = pure NeverCheck+                    , optCheckProject = pure False+                    , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                     }             ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan             shakeSessionInit ide

@@ -4,18 +4,20 @@ import           Development.IDE.Graph  import           Development.IDE.LSP.Server+import           Ide.Types                  (DynFlagsModifications) import qualified Language.LSP.Server        as LSP  data Plugin c = Plugin-    {pluginRules    :: Rules ()-    ,pluginHandlers :: LSP.Handlers (ServerM c)+    {pluginRules          :: Rules ()+    ,pluginHandlers       :: LSP.Handlers (ServerM c)+    ,pluginModifyDynflags :: DynFlagsModifications     }  instance Default (Plugin c) where-    def = Plugin mempty mempty+    def = Plugin mempty mempty mempty  instance Semigroup (Plugin c) where-    Plugin x1 h1 <> Plugin x2 h2 = Plugin (x1<>x2) (h1 <> h2)+    Plugin x1 h1 d1 <> Plugin x2 h2 d2 = Plugin (x1<>x2) (h1 <> h2) (d1 <> d2)  instance Monoid (Plugin c) where     mempty = def

@@ -7,8 +7,11 @@ -- | Go to the definition of a variable.  module Development.IDE.Plugin.CodeAction-    ( descriptor-+    (+    iePluginDescriptor,+    typeSigsPluginDescriptor,+    bindingsPluginDescriptor,+    fillHolePluginDescriptor     -- * For testing     , matchRegExMultipleImports     ) where@@ -18,7 +21,6 @@ import           Control.Applicative                               ((<|>)) import           Control.Arrow                                     (second,                                                                     (>>>))-import           Control.Concurrent.Extra                          (readVar) import           Control.Monad                                     (guard, join) import           Control.Monad.IO.Class import           Data.Char@@ -39,21 +41,17 @@ import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Rules import           Development.IDE.Core.Service-import           Development.IDE.Core.Shake import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error-import           Development.IDE.GHC.ExactPrint import           Development.IDE.GHC.Util                          (prettyPrint,                                                                     printRdrName,                                                                     unsafePrintSDoc) import           Development.IDE.Plugin.CodeAction.Args import           Development.IDE.Plugin.CodeAction.ExactPrint import           Development.IDE.Plugin.CodeAction.PositionIndexed-import           Development.IDE.Plugin.TypeLenses                 (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs),-                                                                    suggestSignature)+import           Development.IDE.Plugin.TypeLenses                 (suggestSignature) import           Development.IDE.Spans.Common import           Development.IDE.Types.Exports-import           Development.IDE.Types.HscEnvEq import           Development.IDE.Types.Location import           Development.IDE.Types.Options import qualified GHC.LanguageExtensions                            as Lang@@ -79,12 +77,7 @@ import           Text.Regex.TDFA                                   (mrAfter,                                                                     (=~), (=~~)) -descriptor :: PluginId -> PluginDescriptor IdeState-descriptor plId =-  (defaultPluginDescriptor plId)-    { pluginRules = mempty,-      pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction-    }+-------------------------------------------------------------------------------------------------  -- | Generate code actions. codeAction@@ -98,61 +91,54 @@     let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents         mbFile = toNormalizedFilePath' <$> uriToFilePath uri     diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state-    (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har, join -> bindings, join -> gblSigs) <- runAction "CodeAction" state $-      (,,,,,,,) <$> getIdeOptions-            <*> getParsedModule `traverse` mbFile-            <*> use GhcSession `traverse` mbFile-            <*> use GetAnnotatedParsedSource `traverse` mbFile-            <*> use TypeCheck `traverse` mbFile-            <*> use GetHieAst `traverse` mbFile-            <*> use GetBindings `traverse` mbFile-            <*> use GetGlobalBindingTypeSigs `traverse` mbFile-    -- This is quite expensive 0.6-0.7s on GHC-    pkgExports   <- maybe mempty envPackageExports env-    localExports <- readVar (exportsMap $ shakeExtras state)+    (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile     let-      exportsMap = localExports <> pkgExports-      df = ms_hspp_opts . pm_mod_summary <$> parsedModule-      actions =-        [ mkCA title kind isPreferred [x] edit-        | x <- xs, (title, kind, isPreferred, tedit) <- suggestAction $ CodeActionArgs exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x-        , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing-        ]-      actions' = caRemoveRedundantImports parsedModule text diag xs uri-               <> actions+      actions = caRemoveRedundantImports parsedModule text diag xs uri                <> caRemoveInvalidExports parsedModule text diag xs uri-    pure $ Right $ List actions'+    pure $ Right $ List actions -mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)-mkCA title kind isPreferred diags edit =-  InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing+------------------------------------------------------------------------------------------------- -suggestAction :: CodeActionArgs -> GhcideCodeActions-suggestAction caa =-  concat   -- Order these suggestions by priority-    [ wrap $ suggestSignature True-    , wrap suggestExtendImport-    , wrap suggestImportDisambiguation-    , wrap suggestNewOrExtendImportForClassMethod+iePluginDescriptor :: PluginId -> PluginDescriptor IdeState+iePluginDescriptor plId =+  let old =+        mkGhcideCAsPlugin [+           wrap suggestExtendImport+          , wrap suggestImportDisambiguation+          , wrap suggestNewOrExtendImportForClassMethod+          , wrap suggestNewImport+          , wrap suggestModuleTypo+          , wrap suggestFixConstructorImport+          , wrap suggestHideShadow+          , wrap suggestExportUnusedTopBinding+          ]+          plId+   in old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction}++typeSigsPluginDescriptor :: PluginId -> PluginDescriptor IdeState+typeSigsPluginDescriptor =+  mkGhcideCAsPlugin [+      wrap $ suggestSignature True     , wrap suggestFillTypeWildcard-    , wrap suggestFixConstructorImport-    , wrap suggestModuleTypo-    , wrap suggestReplaceIdentifier     , wrap removeRedundantConstraints     , wrap suggestAddTypeAnnotationToSatisfyContraints     , wrap suggestConstraint+    ]++bindingsPluginDescriptor :: PluginId -> PluginDescriptor IdeState+bindingsPluginDescriptor =+  mkGhcideCAsPlugin [+      wrap suggestReplaceIdentifier     , wrap suggestImplicitParameter-    , wrap suggestHideShadow     , wrap suggestNewDefinition-    , wrap suggestNewImport     , wrap suggestDeleteUnusedBinding-    , wrap suggestExportUnusedTopBinding-    , wrap suggestFillHole -- Lowest priority     ]-    where-      wrap :: ToCodeAction a => a -> GhcideCodeActions-      wrap = toCodeAction caa +fillHolePluginDescriptor :: PluginId -> PluginDescriptor IdeState+fillHolePluginDescriptor = mkGhcideCAPlugin $ wrap suggestFillHole++-------------------------------------------------------------------------------------------------+ findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) findSigOfDecl pred decls =   listToMaybe@@ -165,15 +151,15 @@ findSigOfDeclRanged range decls = do   dec <- findDeclContainingLoc (_start range) decls   case dec of-     L _ (SigD _ sig@TypeSig {}) -> Just sig+     L _ (SigD _ sig@TypeSig {})     -> Just sig      L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind-     _ -> Nothing+     _                               -> Nothing  findSigOfBind :: Range -> HsBind p -> Maybe (Sig p) findSigOfBind range bind =     case bind of       FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind))-      _ -> Nothing+      _          -> Nothing   where     findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p)     findSigOfLMatch ls = do@@ -188,7 +174,7 @@           grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs)           case unLoc grhs of             GRHS _ _ bd -> findSigOfExpr (unLoc bd)-            _ -> Nothing+            _           -> Nothing      findSigOfExpr :: HsExpr p -> Maybe (Sig p)     findSigOfExpr = go@@ -255,7 +241,7 @@       | Just tcM <- mTcM,         Just har <- mHar,         [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s],-        isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s'),+        isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (OldRealSrcSpan s'),         mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName,         title <- "Hide " <> identifier <> " from " <> modName =         if modName == "Prelude" && null mDecl@@ -303,7 +289,7 @@ 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] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"-    , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == Just _range ) hsmodImports+    , Just (L _ impDecl) <- find (\(L l _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports     , Just c <- contents     , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings)     , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges)@@ -439,10 +425,10 @@       findRelatedSpans         indexedContent         name-        (L (RealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) =+        (L (OldRealSrcSpan 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+            let findSig (L (OldRealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig                 findSig _ = []             in               extendForSpaces indexedContent (toRange l) :@@ -465,7 +451,7 @@         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+          Just (OldRealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused           _ -> []        -- Second of the tuple means there is only one match@@ -516,10 +502,10 @@         indexedContent         name         lsigs-        (L (RealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) =+        (L (OldRealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) =         if isTheBinding (getLoc lname)         then-          let findSig (L (RealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig+          let findSig (L (OldRealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig               findSig _ = []           in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs         else concatMap (findRelatedSpanForMatch indexedContent name) matches@@ -561,7 +547,7 @@     -- 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 (L (RealSrcSpan l) exports) =+    needsComma source (L (OldRealSrcSpan l) exports) =       let closeParan = _end $ realSrcSpanToRange l           lastExport = fmap _end . getLocatedRange $ last exports       in case lastExport of@@ -689,7 +675,7 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ     | Range _ lastLineP : _ <-       [ realSrcSpanToRange sp-      | (L l@(RealSrcSpan sp) _) <- hsmodDecls+      | (L l@(OldRealSrcSpan sp) _) <- hsmodDecls       , _start `isInsideSrcSpan` l]     , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}     = [ ("Define " <> sig@@ -933,7 +919,14 @@             , mode <-                 [ ToQualified parensed qual                 | ExistingImp imps <- [modTarget]+#if MIN_VERSION_ghc(9,0,0)+                {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -}+                -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation+                -- nubOrd can't be used since SrcSpan is intentionally no Ord+                , L _ qual <- nub $ mapMaybe (ideclAs . unLoc)+#else                 , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc)+#endif                     $ NE.toList imps                 ]                 ++ [ToQualified parensed modName@@ -1001,10 +994,10 @@                     liftParseAST @(HsExpr GhcPs) df $                     prettyPrint $                         HsVar @GhcPs noExtField $-                            L (UnhelpfulSpan "") rdr+                            L (oldUnhelpfulSpan  "") rdr                 else Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df ->                     liftParseAST @RdrName df $-                    prettyPrint $ L (UnhelpfulSpan "") rdr+                    prettyPrint $ L (oldUnhelpfulSpan  "") rdr             ]  findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs)@@ -1280,11 +1273,11 @@ newImportInsertRange (L _ HsModule {..})   |  Just (uncurry Position -> insertPos, col) <- case hsmodImports of       [] -> case getLoc (head hsmodDecls) of-        RealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1+        OldRealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1               in Just ((srcLocLine (realSrcSpanStart s) - 1, col), col)         _            -> Nothing       _ -> case  getLoc (last hsmodImports) of-        RealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1+        OldRealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1             in Just ((srcLocLine $ realSrcSpanEnd s,col), col)         _            -> Nothing     = Just (Range insertPos insertPos, col)

@@ -1,296 +1,269 @@ {-# LANGUAGE FlexibleInstances #-}  module Development.IDE.Plugin.CodeAction.Args-  ( module Development.IDE.Plugin.CodeAction.Args,+  ( CodeActionTitle,+    CodeActionPreferred,+    GhcideCodeActionResult,+    GhcideCodeAction,+    mkGhcideCAPlugin,+    mkGhcideCAsPlugin,+    ToTextEdit (..),+    ToCodeAction (..),+    wrap,+    mkCA,   ) where -import           Control.Lens                                 (alaf)-import           Data.Monoid                                  (Ap (..))+import           Control.Concurrent.Extra+import           Control.Monad.Reader+import           Control.Monad.Trans.Maybe+import           Data.Either                                  (fromRight)+import qualified Data.HashMap.Strict                          as Map+import           Data.IORef.Extra+import           Data.Maybe                                   (fromMaybe) import qualified Data.Text                                    as T-import           Development.IDE                              (Diagnostic,-                                                               HieAstResult,-                                                               TcModuleResult)-import           Development.IDE.GHC.Compat                   (DynFlags,-                                                               ParsedModule,-                                                               ParsedSource)+import           Development.IDE                              hiding+                                                              (pluginHandlers)+import           Development.IDE.Core.Shake+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.ExactPrint import           Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite,                                                                rewriteToEdit)-import           Development.IDE.Plugin.TypeLenses            (GlobalBindingTypeSigsResult)+import           Development.IDE.Plugin.TypeLenses            (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs),+                                                               GlobalBindingTypeSigsResult) import           Development.IDE.Spans.LocalBindings          (Bindings) import           Development.IDE.Types.Exports                (ExportsMap) import           Development.IDE.Types.Options                (IdeOptions)-import           Language.LSP.Types                           (CodeActionKind (CodeActionQuickFix),-                                                               TextEdit)-import           Retrie                                       (Annotated (astA))-import           Retrie.ExactPrint                            (annsA)+import           Ide.Plugin.Config                            (Config)+import           Ide.Types+import qualified Language.LSP.Server                          as LSP+import           Language.LSP.Types  type CodeActionTitle = T.Text  type CodeActionPreferred = Bool --- | A compact representation of 'Language.LSP.Types.CodeAction's-type GhcideCodeActions = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])]+type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])] +type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult++-------------------------------------------------------------------------------------------------++{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-}+runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult+runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do+  let mbFile = toNormalizedFilePath' <$> uriToFilePath uri+      runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key+  caaExportsMap <-+    onceIO $+      runRule GhcSession >>= \case+        Just env -> do+          pkgExports <- envPackageExports env+          localExports <- readVar (exportsMap $ shakeExtras state)+          pure $ localExports <> pkgExports+        _ -> pure mempty+  caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions+  caaParsedModule <- onceIO $ runRule GetParsedModule+  caaContents <-+    onceIO $+      runRule GetFileContents >>= \case+        Just (_, txt) -> pure txt+        _             -> pure Nothing+  caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule+  caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource+  caaTmr <- onceIO $ runRule TypeCheck+  caaHar <- onceIO $ runRule GetHieAst+  caaBindings <- onceIO $ runRule GetBindings+  caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs+  liftIO $+    concat+      <$> sequence+        [ runReaderT codeAction caa+          | caaDiagnostic <- diags,+            let caa = CodeActionArgs {..}+        ]++mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)+mkCA title kind isPreferred diags edit =+  InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing++mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> PluginDescriptor IdeState+mkGhcideCAPlugin codeAction plId =+  (defaultPluginDescriptor plId)+    { pluginHandlers = mkPluginHandler STextDocumentCodeAction $+        \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do+          results <- runGhcideCodeAction state params codeAction+          pure $+            Right $+              List+                [ mkCA title kind isPreferred diags edit+                  | (title, kind, isPreferred, tedit) <- results,+                    let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing+                ]+    }++mkGhcideCAsPlugin :: [GhcideCodeAction] -> PluginId -> PluginDescriptor IdeState+mkGhcideCAsPlugin codeActions = mkGhcideCAPlugin $ mconcat codeActions++-------------------------------------------------------------------------------------------------+ class ToTextEdit a where-  toTextEdit :: CodeActionArgs -> a -> [TextEdit]+  toTextEdit :: CodeActionArgs -> a -> IO [TextEdit]  instance ToTextEdit TextEdit where-  toTextEdit _ = pure+  toTextEdit _ = pure . pure  instance ToTextEdit Rewrite where-  toTextEdit CodeActionArgs {..} rw-    | Just df <- caaDf,-      Just ps <- caaAnnSource,-      Right x <- rewriteToEdit df (annsA ps) rw =-      x-    | otherwise = []+  toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $+    runMaybeT $ do+      df <- MaybeT caaDf+      ps <- MaybeT caaAnnSource+      let r = rewriteToEdit df (annsA ps) rw+      pure $ fromRight [] r  instance ToTextEdit a => ToTextEdit [a] where   toTextEdit caa = foldMap (toTextEdit caa)  instance ToTextEdit a => ToTextEdit (Maybe a) where-  toTextEdit caa = maybe [] (toTextEdit caa)+  toTextEdit caa = maybe (pure []) (toTextEdit caa)  instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where   toTextEdit caa = either (toTextEdit caa) (toTextEdit caa) +-------------------------------------------------------------------------------------------------+ data CodeActionArgs = CodeActionArgs-  { caaExportsMap   :: ExportsMap,-    caaIdeOptions   :: IdeOptions,-    caaParsedModule :: Maybe ParsedModule,-    caaContents     :: Maybe T.Text,-    caaDf           :: Maybe DynFlags,-    caaAnnSource    :: Maybe (Annotated ParsedSource),-    caaTmr          :: Maybe TcModuleResult,-    caaHar          :: Maybe HieAstResult,-    caaBindings     :: Maybe Bindings,-    caaGblSigs      :: Maybe GlobalBindingTypeSigsResult,-    caaDiagnostics  :: Diagnostic+  { caaExportsMap   :: IO ExportsMap,+    caaIdeOptions   :: IO IdeOptions,+    caaParsedModule :: IO (Maybe ParsedModule),+    caaContents     :: IO (Maybe T.Text),+    caaDf           :: IO (Maybe DynFlags),+    caaAnnSource    :: IO (Maybe (Annotated ParsedSource)),+    caaTmr          :: IO (Maybe TcModuleResult),+    caaHar          :: IO (Maybe HieAstResult),+    caaBindings     :: IO (Maybe Bindings),+    caaGblSigs      :: IO (Maybe GlobalBindingTypeSigsResult),+    caaDiagnostic   :: Diagnostic   } -rewrite ::-  Maybe DynFlags ->-  Maybe (Annotated ParsedSource) ->-  [(T.Text, [Rewrite])] ->-  [(T.Text, [TextEdit])]-rewrite (Just df) (Just ps) r-  | Right edit <--      (traverse . traverse)-        (alaf Ap foldMap (rewriteToEdit df (annsA ps)))-        r =-    edit-rewrite _ _ _ = []+-- | There's no concurrency in each provider,+-- so we don't need to be thread-safe here+onceIO :: MonadIO m => IO a -> m (IO a)+onceIO io = do+  var <- liftIO $ newIORef Nothing+  pure $+    readIORef var >>= \case+      Just x -> pure x+      _      -> io >>= \x -> writeIORef' var (Just x) >> pure x  ------------------------------------------------------------------------------------------------- --- | Given 'CodeActionArgs', @a@ can be converted into the representation of code actions.--- This class is designed to package functions that produce code actions in "Development.IDE.Plugin.CodeAction".------ For each field @fld@ of 'CodeActionArgs', we make------ @@--- instance ToCodeAction r => ToCodeAction (fld -> r)--- @@------ where we take the value of @fld@ from 'CodeActionArgs' and then feed it into @(fld -> r)@.--- If @fld@ is @Maybe a@, we make------ @@--- instance ToCodeAction r => ToCodeAction (Maybe a -> r)--- instance ToCodeAction r => ToCodeAction (a -> r)--- @@+wrap :: (ToCodeAction a) => a -> GhcideCodeAction+wrap = toCodeAction+ class ToCodeAction a where-  toCodeAction :: CodeActionArgs -> a -> GhcideCodeActions+  toCodeAction :: a -> GhcideCodeAction +instance ToCodeAction GhcideCodeAction where+  toCodeAction = id++instance Semigroup GhcideCodeAction where+  a <> b = toCodeAction [a, b]++instance Monoid GhcideCodeAction where+  mempty = pure []+ instance ToCodeAction a => ToCodeAction [a] where-  toCodeAction caa = foldMap (toCodeAction caa)+  toCodeAction = fmap concat . mapM toCodeAction  instance ToCodeAction a => ToCodeAction (Maybe a) where-  toCodeAction caa = maybe [] (toCodeAction caa)+  toCodeAction = maybe (pure []) toCodeAction  instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where-  toCodeAction caa (title, te) = [(title, Just CodeActionQuickFix, Nothing, toTextEdit caa te)]+  toCodeAction (title, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te  instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where-  toCodeAction caa (title, kind, te) = [(title, Just kind, Nothing, toTextEdit caa te)]+  toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title,Just kind,Nothing,) <$> toTextEdit caa te  instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where-  toCodeAction caa (title, isPreferred, te) = [(title, Just CodeActionQuickFix, Just isPreferred, toTextEdit caa te)]+  toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te  instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where-  toCodeAction caa (title, kind, isPreferred, te) = [(title, Just kind, Just isPreferred, toTextEdit caa te)]+  toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te  ------------------------------------------------------------------------------------------------- --- | Complement: we can obtain 'ParsedSource' from 'caaAnnSource'-instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where-  toCodeAction caa@CodeActionArgs {caaAnnSource = Just ps} f = toCodeAction caa $ f $ astA ps-  toCodeAction _ _ = []+toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction+toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f --- The following boilerplate code can be generated by 'mkInstances'.--- Now it was commented out with generated code spliced out,--- because fields of 'CodeActionArgs' don't change frequently.------ mkInstances :: Name -> DecsQ--- mkInstances tyConName =---   reify tyConName >>= \case---     (TyConI (DataD _ _ _ _ [RecC dataConName tys] _)) -> concat <$> mapM (genForVar dataConName) tys---     _ -> error "unsupported"---  where---   clsType = conT $ mkName "ToCodeAction"---   methodName = mkName "toCodeAction"---   tempType = varT $ mkName "r"---   commonFun dataConName fieldName =---     funD---       methodName---       [ clause---           [ mkName "caa"---               `asP` recP---                 dataConName---                 [fieldPat fieldName $ varP (mkName "x")]---           , varP (mkName "f")---           ]---           (normalB [|$(varE methodName) caa $ f x|])---           []---       ]---   genForVar dataConName (fieldName, _, ty@(AppT (ConT _maybe) ty'))---     | _maybe == ''Maybe =---       do---         withMaybe <----           instanceD---             (cxt [clsType `appT` tempType])---             (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType))---             [commonFun dataConName fieldName]---         withoutMaybe <----           instanceD---             (cxt [clsType `appT` tempType])---             (clsType `appT` ((arrowT `appT` pure ty') `appT` tempType))---             [ funD---                 methodName---                 [ clause---                     [ mkName "caa"---                         `asP` recP---                           dataConName---                           [fieldPat fieldName $ conP 'Just [varP (mkName "x")]]---                     , varP (mkName "f")---                     ]---                     (normalB [|$(varE methodName) caa $ f x|])---                     []---                 , clause [wildP, wildP] (normalB [|[]|]) []---                 ]---             ]---         pure [withMaybe, withoutMaybe]---   genForVar dataConName (fieldName, _, ty) =---     pure---       <$> instanceD---         (cxt [clsType `appT` tempType])---         (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType))---         [commonFun dataConName fieldName]+toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction+toCodeAction2 get f = ReaderT $ \caa ->+  get caa >>= \case+    Just x -> flip runReaderT caa . toCodeAction . f $ x+    _      -> pure [] +toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction+toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f++instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where+  toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} ->+    x >>= \case+      Just s -> flip runReaderT caa . toCodeAction . f . astA $ s+      _      -> pure []+ instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where-  toCodeAction caa@CodeActionArgs {caaExportsMap = x} f =-    toCodeAction caa $ f x+  toCodeAction = toCodeAction3 caaExportsMap  instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where-  toCodeAction caa@CodeActionArgs {caaIdeOptions = x} f =-    toCodeAction caa $ f x+  toCodeAction = toCodeAction3 caaIdeOptions -instance-  ToCodeAction r =>-  ToCodeAction (Maybe ParsedModule -> r)-  where-  toCodeAction caa@CodeActionArgs {caaParsedModule = x} f =-    toCodeAction caa $ f x+instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where+  toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x +instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where+  toCodeAction = toCodeAction1 caaParsedModule+ instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where-  toCodeAction caa@CodeActionArgs {caaParsedModule = Just x} f =-    toCodeAction caa $ f x-  toCodeAction _ _ = []+  toCodeAction = toCodeAction2 caaParsedModule  instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where-  toCodeAction caa@CodeActionArgs {caaContents = x} f =-    toCodeAction caa $ f x+  toCodeAction = toCodeAction1 caaContents  instance ToCodeAction r => ToCodeAction (T.Text -> r) where-  toCodeAction caa@CodeActionArgs {caaContents = Just x} f =-    toCodeAction caa $ f x-  toCodeAction _ _ = []+  toCodeAction = toCodeAction2 caaContents  instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where-  toCodeAction caa@CodeActionArgs {caaDf = x} f =-    toCodeAction caa $ f x+  toCodeAction = toCodeAction1 caaDf  instance ToCodeAction r => ToCodeAction (DynFlags -> r) where-  toCodeAction caa@CodeActionArgs {caaDf = Just x} f =-    toCodeAction caa $ f x-  toCodeAction _ _ = []+  toCodeAction = toCodeAction2 caaDf -instance-  ToCodeAction r =>-  ToCodeAction (Maybe (Annotated ParsedSource) -> r)-  where-  toCodeAction caa@CodeActionArgs {caaAnnSource = x} f =-    toCodeAction caa $ f x+instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where+  toCodeAction = toCodeAction1 caaAnnSource -instance-  ToCodeAction r =>-  ToCodeAction (Annotated ParsedSource -> r)-  where-  toCodeAction caa@CodeActionArgs {caaAnnSource = Just x} f =-    toCodeAction caa $ f x-  toCodeAction _ _ = []+instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where+  toCodeAction = toCodeAction2 caaAnnSource -instance-  ToCodeAction r =>-  ToCodeAction (Maybe TcModuleResult -> r)-  where-  toCodeAction caa@CodeActionArgs {caaTmr = x} f =-    toCodeAction caa $ f x+instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where+  toCodeAction = toCodeAction1 caaTmr  instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where-  toCodeAction caa@CodeActionArgs {caaTmr = Just x} f =-    toCodeAction caa $ f x-  toCodeAction _ _ = []+  toCodeAction = toCodeAction2 caaTmr -instance-  ToCodeAction r =>-  ToCodeAction (Maybe HieAstResult -> r)-  where-  toCodeAction caa@CodeActionArgs {caaHar = x} f =-    toCodeAction caa $ f x+instance ToCodeAction r => ToCodeAction (Maybe HieAstResult -> r) where+  toCodeAction = toCodeAction1 caaHar  instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where-  toCodeAction caa@CodeActionArgs {caaHar = Just x} f =-    toCodeAction caa $ f x-  toCodeAction _ _ = []+  toCodeAction = toCodeAction2 caaHar  instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where-  toCodeAction caa@CodeActionArgs {caaBindings = x} f =-    toCodeAction caa $ f x+  toCodeAction = toCodeAction1 caaBindings  instance ToCodeAction r => ToCodeAction (Bindings -> r) where-  toCodeAction caa@CodeActionArgs {caaBindings = Just x} f =-    toCodeAction caa $ f x-  toCodeAction _ _ = []--instance-  ToCodeAction r =>-  ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r)-  where-  toCodeAction caa@CodeActionArgs {caaGblSigs = x} f =-    toCodeAction caa $ f x--instance-  ToCodeAction r =>-  ToCodeAction (GlobalBindingTypeSigsResult -> r)-  where-  toCodeAction caa@CodeActionArgs {caaGblSigs = Just x} f =-    toCodeAction caa $ f x-  toCodeAction _ _ = []+  toCodeAction = toCodeAction2 caaBindings -instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where-  toCodeAction caa@CodeActionArgs {caaDiagnostics = x} f =-    toCodeAction caa $ f x+instance ToCodeAction r => ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) where+  toCodeAction = toCodeAction1 caaGblSigs --------------------------------------------------------------------------------------------------+instance ToCodeAction r => ToCodeAction (GlobalBindingTypeSigsResult -> r) where+  toCodeAction = toCodeAction2 caaGblSigs

@@ -25,13 +25,13 @@ import           Development.IDE.GHC.ExactPrint               (Annotated (annsA),                                                                GetAnnotatedParsedSource (GetAnnotatedParsedSource)) import           Development.IDE.GHC.Util                     (prettyPrint)+import           Development.IDE.Graph+import           Development.IDE.Graph.Classes import           Development.IDE.Plugin.CodeAction.ExactPrint import           Development.IDE.Plugin.Completions.Logic import           Development.IDE.Plugin.Completions.Types import           Development.IDE.Types.HscEnvEq               (hscEnv) import           Development.IDE.Types.Location-import           Development.IDE.Graph-import           Development.IDE.Graph.Classes import           GHC.Exts                                     (toList) import           GHC.Generics import           Ide.Plugin.Config                            (Config)@@ -39,7 +39,11 @@ import qualified Language.LSP.Server                          as LSP import           Language.LSP.Types import qualified Language.LSP.VFS                             as VFS+#if MIN_VERSION_ghc(9,0,0)+import           GHC.Tc.Module                                (tcRnImportDecls)+#else import           TcRnDriver                                   (tcRnImportDecls)+#endif  descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId)

@@ -266,7 +266,7 @@             let (args, ret) = splitFunTys t               in if isForAllTy ret                   then getArgs ret-                  else Prelude.filter (not . isDictTy) args+                  else Prelude.filter (not . isDictTy) $ map scaledThing args           | isPiTy t = getArgs $ snd (splitPiTys t) #if MIN_VERSION_ghc(8,10,0)           | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t@@ -309,7 +309,7 @@       packageState = hscEnv env       curModName = moduleName curMod -      importMap = Map.fromList [ (getLoc imp, imp) | imp <- limports ]+      importMap = Map.fromList [ (l, imp) | imp@(L (OldRealSrcSpan l) _) <- limports ]        iDeclToModName :: ImportDecl name -> ModuleName       iDeclToModName = unLoc . ideclName@@ -337,8 +337,12 @@           (, mempty) <$> toCompItem par curMod curModName n Nothing       getComplsForOne (GRE n par False prov) =         flip foldMapM (map is_decl prov) $ \spec -> do-          -- we don't want to extend import if it's already in scope-          let originalImportDecl = if null $ lookupGRE_Name inScopeEnv n then Map.lookup (is_dloc spec) importMap else Nothing+          let originalImportDecl = do+                -- we don't want to extend import if it's already in scope+                guard . null $ lookupGRE_Name inScopeEnv n+                -- or if it doesn't have a real location+                loc <- realSpan $ is_dloc spec+                Map.lookup loc importMap           compItem <- toCompItem par curMod (is_mod spec) n originalImportDecl           let unqual                 | is_qual spec = []

@@ -24,10 +24,11 @@ import qualified Data.Text                    as T import           Development.IDE.Core.Shake import           Development.IDE.Core.Tracing+import           Development.IDE.Graph        (Rules) import           Development.IDE.LSP.Server import           Development.IDE.Plugin+import qualified Development.IDE.Plugin       as P import           Development.IDE.Types.Logger-import           Development.IDE.Graph            (Rules) import           Ide.Plugin.Config import           Ide.PluginUtils              (getClientConfig) import           Ide.Types                    as HLS@@ -48,7 +49,8 @@     mkPlugin rulesPlugins HLS.pluginRules <>     mkPlugin executeCommandPlugins HLS.pluginCommands <>     mkPlugin extensiblePlugins HLS.pluginHandlers <>-    mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers+    mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers <>+    mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags     where          mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config@@ -63,14 +65,17 @@ -- ---------------------------------------------------------------------  rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config-rulesPlugins rs = Plugin rules mempty+rulesPlugins rs = mempty { P.pluginRules = rules }     where         rules = foldMap snd rs +dynFlagsPlugins :: [(PluginId, DynFlagsModifications)] -> Plugin Config+dynFlagsPlugins rs = mempty { P.pluginModifyDynflags = foldMap snd rs }+ -- ---------------------------------------------------------------------  executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config-executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs)+executeCommandPlugins ecs = mempty { P.pluginHandlers = executeCommandHandlers ecs }  executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd@@ -132,7 +137,7 @@ -- ---------------------------------------------------------------------  extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config-extensiblePlugins xs = Plugin mempty handlers+extensiblePlugins xs = mempty { P.pluginHandlers = handlers }   where     IdeHandlers handlers' = foldMap bakePluginId xs     bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers@@ -160,7 +165,7 @@ -- ---------------------------------------------------------------------  extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config-extensibleNotificationPlugins xs = Plugin mempty handlers+extensibleNotificationPlugins xs = mempty { P.pluginHandlers = handlers }   where     IdeNotificationHandlers handlers' = foldMap bakePluginId xs     bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers

@@ -22,7 +22,10 @@ descriptors :: [PluginDescriptor IdeState] descriptors =   [ descriptor "ghcide-hover-and-symbols",-    CodeAction.descriptor "ghcide-code-actions",+    CodeAction.iePluginDescriptor "ghcide-code-actions-imports-exports",+    CodeAction.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures",+    CodeAction.bindingsPluginDescriptor "ghcide-code-actions-bindings",+    CodeAction.fillHolePluginDescriptor "ghcide-code-actions-fill-holes",     Completions.descriptor "ghcide-completions",     TypeLenses.descriptor "ghcide-type-lenses",     Notifications.descriptor "ghcide-core"

@@ -18,6 +18,7 @@ import           Data.Aeson.Types import           Data.Bifunctor import           Data.CaseInsensitive           (CI, original)+import           Data.Default                   (def) import           Data.Maybe                     (isJust) import           Data.String import           Data.Text                      (Text, pack)@@ -25,12 +26,13 @@ import           Development.IDE.Core.Service import           Development.IDE.Core.Shake import           Development.IDE.GHC.Compat+import           Development.IDE.Graph          (Action) import           Development.IDE.LSP.Server import           Development.IDE.Plugin+import qualified Development.IDE.Plugin         as P import           Development.IDE.Types.Action import           Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import           Development.IDE.Types.Location (fromUri)-import           Development.IDE.Graph              (Action) import           GHC.Generics                   (Generic) import           GhcPlugins                     (HscEnv (hsc_dflags)) import           Ide.Types@@ -51,9 +53,9 @@     deriving newtype (FromJSON, ToJSON)  plugin :: Plugin c-plugin = Plugin {-    pluginRules = return (),-    pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler'+plugin = def {+    P.pluginRules = return (),+    P.pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler' }   where       testRequestHandler' ide req

@@ -35,13 +35,13 @@ import           Development.IDE.Core.Shake          (getHiddenDiagnostics, use) import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Util            (printName)+import           Development.IDE.Graph.Classes import           Development.IDE.Spans.Common        (safeTyThingType) import           Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope) import           Development.IDE.Types.Location      (Position (Position, _character, _line),                                                       Range (Range, _end, _start),                                                       toNormalizedFilePath',                                                       uriToFilePath')-import           Development.IDE.Graph.Classes import           GHC.Generics                        (Generic) import           GhcPlugins                          (GlobalRdrEnv,                                                       HscEnv (hsc_dflags), SDoc,@@ -80,7 +80,6 @@ import           TcEnv                               (tcInitTidyEnv) import           TcRnMonad                           (initTcWithGbl) import           TcRnTypes                           (TcGblEnv (..))-import           TcType                              (pprSigmaType) import           Text.Regex.TDFA                     ((=~), (=~~))  typeLensCommandId :: T.Text

@@ -57,10 +57,11 @@ import           Data.List.Extra                      (dropEnd1, nubOrd)  import           HieDb                                hiding (pointCommand)+import           System.Directory                     (doesFileExist)  -- | Gives a Uri for the module, given the .hie file location and the the module info -- The Bool denotes if it is a boot module-type LookupModule m = FilePath -> ModuleName -> UnitId -> Bool -> MaybeT m Uri+type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri  -- | HieFileResult for files of interest, along with the position mappings newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping))@@ -89,7 +90,7 @@     Nothing -> ([],[],[])     Just (HAR _ hf _ _ _,mapping) ->       let posFile = fromMaybe pos $ fromCurrentPosition mapping pos-          names = concat $ pointCommand hf posFile (rights . M.keys . nodeIdentifiers . nodeInfo)+          names = concat $ pointCommand hf posFile (rights . M.keys . getNodeIds)           adjustedLocs = HM.foldr go [] asts           go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs             where@@ -154,7 +155,7 @@   -> MaybeT m [DocumentHighlight] documentHighlight hf rf pos = pure highlights   where-    ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo)+    ns = concat $ pointCommand hf pos (rights . M.keys . getNodeIds)     highlights = do       n <- ns       ref <- fromMaybe [] (M.lookup (Right n) rf)@@ -209,7 +210,7 @@         range = realSrcSpanToRange $ nodeSpan ast          wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"-        info = nodeInfo ast+        info = nodeInfoH kind ast         names = M.assocs $ nodeIdentifiers info         types = nodeType info @@ -251,7 +252,7 @@           ts = concat $ pointCommand ast pos getts           unfold = map (arr A.!)           getts x = nodeType ni  ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni)-            where ni = nodeInfo x+            where ni = nodeInfo' x           getTypes ts = flip concatMap (unfold ts) $ \case             HTyVarTy n -> [n] #if MIN_VERSION_ghc(8,8,0)@@ -261,7 +262,11 @@ #endif             HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs)             HForAllTy _ a -> getTypes [a]+#if MIN_VERSION_ghc(9,0,1)+            HFunTy a b c -> getTypes [a,b,c]+#else             HFunTy a b -> getTypes [a,b]+#endif             HQualTy a b -> getTypes [a,b]             HCastTy a -> getTypes [a]             _ -> []@@ -296,7 +301,7 @@   -> HieASTs a   -> m [Location] locationsAtPoint hiedb lookupModule _ideOptions imports pos ast =-  let ns = concat $ pointCommand ast pos (M.keys . nodeIdentifiers . nodeInfo)+  let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)       zeroPos = Position 0 0       zeroRange = Range zeroPos zeroPos       modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports@@ -306,10 +311,21 @@ nameToLocation :: MonadIO m => HieDb -> LookupModule m -> Name -> m (Maybe [Location]) nameToLocation hiedb lookupModule name = runMaybeT $   case nameSrcSpan name of-    sp@(RealSrcSpan rsp)+    sp@(OldRealSrcSpan rsp)       -- Lookup in the db if we got a location in a boot file-      | not $ "boot" `isSuffixOf` unpackFS (srcSpanFile rsp) -> MaybeT $ pure $ fmap pure $ srcSpanToLocation sp-    sp -> do+      | fs <- unpackFS (srcSpanFile rsp)+      , not $ "boot" `isSuffixOf` fs+      -> do+          itExists <- liftIO $ doesFileExist fs+          if itExists+              then MaybeT $ pure $ fmap pure $ srcSpanToLocation sp+              -- When reusing .hie files from a cloud cache,+              -- the paths may not match the local file system.+              -- Let's fall back to the hiedb in case it contains local paths+              else fallbackToDb sp+    sp -> fallbackToDb sp+  where+    fallbackToDb sp = do       guard (sp /= wiredInSrcSpan)       -- This case usually arises when the definition is in an external package.       -- In this case the interface files contain garbage source spans@@ -368,3 +384,8 @@    sp fs = mkRealSrcSpan (sloc fs) (sloc fs)    line = _line pos    cha = _character pos++-- In ghc9, nodeInfo is monomorphic, so we need a case split here+nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a+nodeInfoH (HieFromDisk _) = nodeInfo'+nodeInfoH HieFresh        = nodeInfo

@@ -30,6 +30,8 @@ import           Outputable                   hiding ((<>)) import           Var +import           Development.IDE.GHC.Compat   (oldMkUserStyle,+                                               oldRenderWithStyle) import           Development.IDE.GHC.Orphans  () import           Development.IDE.GHC.Util import qualified Documentation.Haddock.Parser as H@@ -49,8 +51,8 @@ showNameWithoutUniques = T.pack . prettyprint   where     dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques-    prettyprint x = renderWithStyle dyn (ppr x) style-    style = mkUserStyle dyn neverQualify AllTheWay+    prettyprint x = oldRenderWithStyle dyn (ppr x) style+    style = oldMkUserStyle dyn neverQualify AllTheWay  -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. unqualIEWrapName :: IEWrappedName RdrName -> T.Text

@@ -36,7 +36,6 @@ import           Language.LSP.Types             (filePathToUri, getUri) import           Name import           NameEnv-import           Packages import           SrcLoc                         (RealLocated) import           TcRnTypes @@ -142,9 +141,7 @@   pure       $ docHeaders       $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan)-      $ mapMaybe (\(L l v) -> L <$> realSpan l <*> pure v)-      $ join-      $ M.elems+      $ fold       docs   where     -- Get the name bound by a binding. We only concern ourselves with@@ -157,14 +154,15 @@     sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]     sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)     isBetween target before after = before <= target && target <= after-    ann = snd . pm_annotations+#if MIN_VERSION_ghc(9,0,0)+    ann = apiAnnComments . pm_annotations+#else+    ann = fmap filterReal . snd . pm_annotations+    filterReal :: [Located a] -> [RealLocated a]+    filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l)+#endif     annotationFileName :: ParsedModule -> Maybe FastString-    annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann-    realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]-    realSpans =-        mapMaybe (realSpan . getLoc)-      . join-      . M.elems+    annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann  -- | Shows this part of the documentation docHeaders :: [RealLocated AnnotationComment]@@ -215,7 +213,7 @@       -- The file might use "." or "-" as separator       map (`intercalate` chunks) [".", "-"] -lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath]+lookupHtmls :: DynFlags -> Unit -> Maybe [FilePath] lookupHtmls df ui =   -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path   -- and therefore doesn't expand $topdir on Windows

@@ -12,14 +12,18 @@ import           Control.DeepSeq import           Control.Monad import           Data.Bifunctor-import           Data.IntervalMap.FingerTree (IntervalMap, Interval (..))-import qualified Data.IntervalMap.FingerTree as IM-import qualified Data.List as L-import qualified Data.Map as M-import qualified Data.Set as S-import           Development.IDE.GHC.Compat (RefMap, identType, identInfo, getScopeFromContext, getBindSiteFromContext, Scope(..), Name, Type)+import           Data.IntervalMap.FingerTree    (Interval (..), IntervalMap)+import qualified Data.IntervalMap.FingerTree    as IM+import qualified Data.List                      as L+import qualified Data.Map                       as M+import qualified Data.Set                       as S+import           Development.IDE.GHC.Compat     (Name, RefMap, Scope (..), Type,+                                                 getBindSiteFromContext,+                                                 getScopeFromContext, identInfo,+                                                 identType) import           Development.IDE.GHC.Error import           Development.IDE.Types.Location+import           Name                           (isSystemName) import           NameEnv import           SrcLoc @@ -53,7 +57,7 @@         Just scopes <- pure $ getScopeFromContext info         scope <- scopes >>= \case           LocalScope scope -> pure $ realSrcSpanToInterval scope-          _ -> []+          _                -> []         pure ( scope             , unitNameEnv name (name,ty)             )@@ -115,7 +119,8 @@ -- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyScope bs a b-  = nameEnvElts+  = filter (not . isSystemName . fst)+  $ nameEnvElts   $ foldMap snd   $ IM.intersections (Interval a b)   $ getLocalBindings bs

@@ -15,8 +15,8 @@ import qualified Data.HashSet                 as Set import           Data.Hashable                (Hashable (..)) import           Data.Unique                  (Unique)+import           Development.IDE.Graph        (Action) import           Development.IDE.Types.Logger-import           Development.IDE.Graph            (Action) import           Numeric.Natural  data DelayedAction a = DelayedAction

@@ -24,17 +24,12 @@ import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error     (catchSrcErrors) import           Development.IDE.GHC.Util      (lookupPackageConfig)-import           Development.IDE.Types.Exports (ExportsMap, createExportsMap) import           Development.IDE.Graph.Classes-import           GhcPlugins                    (HscEnv (hsc_dflags),-                                                InstalledPackageInfo (exposedModules),-                                                Module (..),-                                                PackageState (explicitPackages),-                                                listVisibleModuleNames,-                                                packageConfigId)+import           Development.IDE.Types.Exports (ExportsMap, createExportsMap)+import           GhcPlugins                    (HscEnv (hsc_dflags)) import           LoadIface                     (loadInterface) import qualified Maybes-import           Module                        (InstalledUnitId)+-- import           Module                        (InstalledUnitId) import           OpenTelemetry.Eventlog        (withSpan) import           System.Directory              (canonicalizePath) import           System.FilePath@@ -95,8 +90,8 @@             doOne (pkg, mn) = do                 modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface                     ""-                    (Module (packageConfigId pkg) mn)-                    (ImportByUser False)+                    (mkModule (packageConfigId pkg) mn)+                    (ImportByUser NotBoot)                 return $ case modIface of                     Maybes.Failed    _r -> Nothing                     Maybes.Succeeded mi -> Just mi@@ -109,7 +104,7 @@         <$> catchSrcErrors           dflags           "listVisibleModuleNames"-          (evaluate . force . Just $ listVisibleModuleNames dflags)+          (evaluate . force . Just $ oldListVisibleModuleNames dflags)      return HscEnvEq{..} 

@@ -22,12 +22,11 @@ import qualified Data.Text                         as T import           Data.Typeable import           Development.IDE.Core.RuleTypes-import           Development.IDE.Types.Diagnostics+import           Development.IDE.GHC.Compat        as GHC import           Development.IDE.Graph-import           GHC                               hiding (parseModule,-                                                    typecheckModule)-import           GhcPlugins                        as GHC hiding (fst3, (<>))+import           Development.IDE.Types.Diagnostics import           Ide.Plugin.Config+import           Ide.Types                         (DynFlagsModifications) import qualified Language.LSP.Types.Capabilities   as LSP  data IdeOptions = IdeOptions@@ -73,13 +72,15 @@     --   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+  , optModifyDynFlags     :: DynFlagsModifications     -- ^ Will be called right after setting up a new cradle,     --   allowing to customize the Ghc options used   , optShakeOptions       :: ShakeOptions   , optSkipProgress       :: forall a. Typeable a => a -> Bool       -- ^ Predicate to select which rule keys to exclude from progress reporting.   , optProgressStyle      :: ProgressReportingStyle+  , optRunSubset          :: Bool+      -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed   }  optShakeFiles :: IdeOptions -> Maybe FilePath@@ -138,9 +139,10 @@     ,optCheckProject = pure True     ,optCheckParents = pure CheckOnSaveAndClose     ,optHaddockParse = HaddockParse-    ,optCustomDynFlags = id+    ,optModifyDynFlags = mempty     ,optSkipProgress = defaultSkipProgress     ,optProgressStyle = Explicit+    ,optRunSubset = False     }  defaultSkipProgress :: Typeable a => a -> Bool

@@ -8,11 +8,12 @@     ValueWithDiagnostics (..),     Values,     Key (..),+    SomeShakeValue,     BadDependency (..),     ShakeValue(..),     currentValue,     isBadDependency,-  toShakeValue,encodeShakeValue,decodeShakeValue)+  toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey) where  import           Control.DeepSeq@@ -24,11 +25,13 @@ import           Data.Typeable import           Data.Vector                          (Vector) import           Development.IDE.Core.PositionMapping-import           Development.IDE.Types.Diagnostics-import           Development.IDE.Types.Location-import           Development.IDE.Graph                    (RuleResult,+import           Development.IDE.Graph                (RuleResult,                                                        ShakeException (shakeExceptionInner))+import qualified Development.IDE.Graph                as Shake import           Development.IDE.Graph.Classes+import           Development.IDE.Graph.Database       (SomeShakeValue (..))+import           Development.IDE.Types.Diagnostics+import           Development.IDE.Types.Location import           GHC.Generics import           Language.LSP.Types @@ -54,7 +57,7 @@ type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics  -- | Key type-data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k+data Key = forall k . (Typeable k, Hashable k, Eq k, NFData k, Show k) => Key k  instance Show Key where   show (Key k) = show k@@ -64,8 +67,15 @@                      | otherwise = False  instance Hashable Key where-    hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)+    hashWithSalt salt (Key key) = hashWithSalt salt key +instance Binary Key where+    get = error "not really"+    put _ = error "not really"++instance NFData Key where+    rnf (Key k) = rnf k+ -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency --   which short-circuits the rest of the action newtype BadDependency = BadDependency String deriving Show@@ -76,6 +86,13 @@     | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x     | Just (_ :: BadDependency) <- fromException x = True     | otherwise = False+++toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> SomeShakeValue+toKey = (SomeShakeValue .) . curry Q++toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k, Binary k, NFData k) => k -> SomeShakeValue+toNoFileKey k = toKey k emptyFilePath  newtype Q k = Q (k, NormalizedFilePath)     deriving newtype (Eq, Hashable, NFData)

@@ -10,12 +10,12 @@       largestM     ) where -import Control.Monad-import Data.Functor.Compose (Compose(Compose))-import Data.Monoid (Any(Any))-import Development.IDE.GHC.Compat-import Development.IDE.Graph.Classes-import Generics.SYB+import           Control.Monad+import           Data.Functor.Compose          (Compose (Compose))+import           Data.Monoid                   (Any (Any))+import           Development.IDE.GHC.Compat+import           Development.IDE.Graph.Classes+import           Generics.SYB   -- | A generic query intended to be used for calling 'smallestM' and@@ -80,7 +80,7 @@         Just True -> do           it@(r, x') <- gmapMQ go x           case r of-            Any True -> pure it+            Any True  -> pure it             Any False -> fmap (Any True,) $ f x'         Just False -> pure (mempty, x) @@ -100,9 +100,9 @@     go :: GenericM m     go x = do       case q x of-        Just True -> f x+        Just True  -> f x         Just False -> pure x-        Nothing -> gmapM go x+        Nothing    -> gmapM go x  newtype MonadicQuery r m a = MonadicQuery   { runMonadicQuery :: m (r, a)

@@ -35,8 +35,8 @@                                                            positionResultToMaybe,                                                            toCurrent) import           Development.IDE.Core.Shake               (Q (..))-import qualified Development.IDE.Main                     as IDE import           Development.IDE.GHC.Util+import qualified Development.IDE.Main                     as IDE import           Development.IDE.Plugin.Completions.Types (extendImportCommandId) import           Development.IDE.Plugin.TypeLenses        (typeLensCommandId) import           Development.IDE.Spans.Common@@ -74,37 +74,37 @@ import qualified System.IO.Extra import           System.Info.Extra                        (isWindows) import           System.Process.Extra                     (CreateProcess (cwd),-                                                           proc,-                                                           readCreateProcessWithExitCode, createPipe)+                                                           createPipe, proc,+                                                           readCreateProcessWithExitCode) import           Test.QuickCheck -- import Test.QuickCheck.Instances ()+import           Control.Concurrent                       (threadDelay)+import           Control.Concurrent.Async import           Control.Lens                             ((^.)) import           Control.Monad.Extra                      (whenJust)+import           Data.IORef+import           Data.IORef.Extra                         (atomicModifyIORef_)+import           Data.String                              (IsString (fromString)) import           Data.Tuple.Extra+import           Development.IDE.Core.FileStore           (getModTime) import           Development.IDE.Plugin.CodeAction        (matchRegExMultipleImports)+import qualified Development.IDE.Plugin.HLS.GhcIde        as Ghcide import           Development.IDE.Plugin.Test              (TestRequest (BlockSeconds, GetInterfaceFilesDir),                                                            WaitForIdeRuleResult (..),                                                            blockCommandId)+import           Ide.PluginUtils                          (pluginDescToIdePlugins)+import           Ide.Types+import qualified Language.LSP.Types                       as LSP import qualified Language.LSP.Types.Lens                  as L+import qualified Progress import           System.Time.Extra import           Test.Tasty import           Test.Tasty.ExpectedFailure import           Test.Tasty.HUnit import           Test.Tasty.Ingredients.Rerun import           Test.Tasty.QuickCheck-import           Data.IORef-import           Ide.PluginUtils (pluginDescToIdePlugins)-import           Control.Concurrent.Async-import           Ide.Types-import           Data.String                              (IsString(fromString))-import qualified Language.LSP.Types                       as LSP-import           Data.IORef.Extra                         (atomicModifyIORef_)-import qualified Development.IDE.Plugin.HLS.GhcIde        as Ghcide+import           Text.Printf                              (printf) import           Text.Regex.TDFA                          ((=~))-import qualified Progress-import Development.IDE.Core.FileStore (getModTime)-import Control.Concurrent (threadDelay)-import Text.Printf (printf)  waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case@@ -538,12 +538,17 @@             , "foo = 1 {-|-}"             ]       _ <- createDoc "Foo.hs" "haskell" fooContent+#if MIN_VERSION_ghc(9,0,1)+      -- Haddock parse errors are ignored on ghc-9.0.1+      pure ()+#else       expectDiagnostics         [ ( "Foo.hs"           , [(DsWarning, (2, 8), "Haddock parse error on input")             ]           )         ]+#endif   , testSessionWait "strip file path" $ do       let           name = "Testing"@@ -763,17 +768,18 @@       _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"       watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics -      -- Expect 1 subscription: we only ever send one-      liftIO $ length watchedFileRegs @?= 1+      -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle+      liftIO $ length watchedFileRegs @?= 2    , testSession' "non workspace file" $ \sessionDir -> do       tmpDir <- liftIO getTemporaryDirectory-      liftIO $ writeFile (sessionDir </> "hie.yaml") ("cradle: {direct: {arguments: [\"-i" <> tmpDir <> "\", \"A\", \"WatchedFilesMissingModule\"]}}")+      let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}"+      liftIO $ writeFile (sessionDir </> "hie.yaml") yaml       _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"       watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics -      -- Expect 1 subscription: we only ever send one-      liftIO $ length watchedFileRegs @?= 1+      -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle+      liftIO $ length watchedFileRegs @?= 2    -- TODO add a test for didChangeWorkspaceFolder   ]@@ -2212,14 +2218,14 @@     [ (DsWarning, (6, 8), "Defaulting the following constraint")     , (DsWarning, (6, 16), "Defaulting the following constraint")     ]-    "Add type annotation ‘[Char]’ to ‘\"debug\"’"+    ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’")     (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"                , "{-# LANGUAGE OverloadedStrings #-}"                , "module A (f) where"                , ""                , "import Debug.Trace"                , ""-               , "f = seq (\"debug\" :: [Char]) traceShow \"debug\""+               , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\""                ])   , testSession "add default type to satisfy two contraints" $     testFor@@ -2232,14 +2238,14 @@                , "f a = traceShow \"debug\" a"                ])     [ (DsWarning, (6, 6), "Defaulting the following constraint") ]-    "Add type annotation ‘[Char]’ to ‘\"debug\"’"+    ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’")     (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"                , "{-# LANGUAGE OverloadedStrings #-}"                , "module A (f) where"                , ""                , "import Debug.Trace"                , ""-               , "f a = traceShow (\"debug\" :: [Char]) a"+               , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a"                ])   , testSession "add default type to satisfy two contraints with duplicate literals" $     testFor@@ -2252,14 +2258,14 @@                , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))"                ])     [ (DsWarning, (6, 54), "Defaulting the following constraint") ]-    "Add type annotation ‘[Char]’ to ‘\"debug\"’"+    ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’")     (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"                , "{-# LANGUAGE OverloadedStrings #-}"                , "module A (f) where"                , ""                , "import Debug.Trace"                , ""-               , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: [Char])))"+               , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: " <> listOfChar <> ")))"                ])   ]   where@@ -3405,7 +3411,7 @@         , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a")         , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a")         , ("head = 233", "head :: Integer")-        , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, [Char])")+        , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")")         , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"")         , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing")         , ("typeOperatorTest = Refl", "typeOperatorTest :: a :~: a")@@ -3577,7 +3583,13 @@   in   mkFindTests   --      def    hover  look       expect-  [ test  yes    yes    fffL4      fff           "field in record definition"+  [+#if MIN_VERSION_ghc(9,0,0)+  -- It suggests either going to the constructor or to the field+    test  broken yes    fffL4      fff           "field in record definition"+#else+    test  yes    yes    fffL4      fff           "field in record definition"+#endif   , test  yes    yes    fffL8      fff           "field in record construction    #1102"   , test  yes    yes    fffL14     fff           "field name used as accessor"           -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs   , test  yes    yes    aaaL14     aaa           "top-level name"                        -- https://github.com/haskell/ghcide/pull/120@@ -3613,7 +3625,11 @@   , test  no     broken chrL36     litC          "literal Char in hover info      #1016"   , test  no     broken txtL8      litT          "literal Text in hover info      #1016"   , test  no     broken lstL43     litL          "literal List in hover info      #1016"+#if MIN_VERSION_ghc(9,0,0)+  , test  no     yes    docL41     constr        "type constraint in hover info   #1012"+#else   , test  no     broken docL41     constr        "type constraint in hover info   #1012"+#endif   , test  broken broken outL45     outSig        "top-level signature              #767"   , test  broken broken innL48     innSig        "inner     signature              #767"   , test  no     yes    holeL60    hleInfo       "hole without internal name       #831"@@ -3637,6 +3653,9 @@ pluginSimpleTests :: TestTree pluginSimpleTests =   ignoreInWindowsForGHC88And810 $+#if __GLASGOW_HASKELL__ == 810 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 5+  expectFailBecause "known broken (see GHC #19763)" $+#endif   testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do     _ <- openDoc (dir </> "KnownNat.hs") "haskell"     liftIO $ writeFile (dir</>"hie.yaml")@@ -3801,6 +3820,8 @@               T.unlines                 [ "{-# LANGUAGE TemplateHaskell #-}"                 , "module A (a) where"+                , "import Language.Haskell.TH (ExpQ)"+                , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic                 , "a = [| glorifiedID |]"                 , "glorifiedID :: a -> a"                 , "glorifiedID = id" ]@@ -3843,7 +3864,7 @@     bdoc <- createDoc bPath "haskell" bSource     cdoc <- createDoc cPath "haskell" cSource -    expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]+    expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]      -- Change th from () to Bool     let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"]@@ -3855,7 +3876,7 @@     expectDiagnostics         [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])         ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")])-        ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])+        ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level bindin")])         ]      closeDoc adoc@@ -3878,7 +3899,7 @@     adoc <- createDoc aPath "haskell" aSource     bdoc <- createDoc bPath "haskell" bSource -    expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]+    expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]      let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"]     changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']@@ -3887,7 +3908,7 @@     let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]     changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] -    expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]+    expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]      closeDoc adoc     closeDoc bdoc@@ -4338,16 +4359,21 @@             , DocumentHighlight (R 6 10 6 13) (Just HkRead)             , DocumentHighlight (R 7 12 7 15) (Just HkRead)             ]-  , testSessionWait "record" $ do+  ,+#if MIN_VERSION_ghc(9,0,0)+    expectFailBecause "Ghc9 highlights the constructor and not just this field" $+#endif+    testSessionWait "record" $ do     doc <- createDoc "A.hs" "haskell" recsource     _ <- waitForDiagnostics     highlights <- getHighlights doc (Position 4 15)     liftIO $ highlights @?= List       -- Span is just the .. on 8.10, but Rec{..} before+            [ #if MIN_VERSION_ghc(8,10,0)-            [ DocumentHighlight (R 4 8 4 10) (Just HkWrite)+              DocumentHighlight (R 4 8 4 10) (Just HkWrite) #else-            [ DocumentHighlight (R 4 4 4 11) (Just HkWrite)+              DocumentHighlight (R 4 4 4 11) (Just HkWrite) #endif             , DocumentHighlight (R 4 14 4 20) (Just HkRead)             ]@@ -4693,7 +4719,6 @@   let hieContents = "cradle: {bios: {shell: \"false\"}}"       hiePath = dir </> "hie.yaml"   liftIO $ writeFile hiePath hieContents-  hieDoc <- createDoc hiePath "yaml" $ T.pack hieContents   let aPath = dir </> "A.hs"   doc <- createDoc aPath "haskell" "main = return ()"   Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc@@ -4702,15 +4727,8 @@   -- Fix the cradle and typecheck again   let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"   liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle-  changeDoc-    hieDoc-    [ TextDocumentContentChangeEvent-        { _range = Nothing,-          _rangeLength = Nothing,-          _text = validCradle-        }-    ]-+  sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+          List [FileEvent (filePathToUri $ dir </> "hie.yaml") FcChanged ]   -- Force a session restart by making an edit, just to dirty the typecheck node   changeDoc     doc@@ -4733,7 +4751,8 @@       test dir = do         -- If the file contains B then no type error         -- otherwise type error-        liftIO $ writeFile (dir </> "dep-file.txt") "A"+        let depFilePath = dir </> "dep-file.txt"+        liftIO $ writeFile depFilePath "A"         let fooContent = T.unlines               [ "{-# LANGUAGE TemplateHaskell #-}"               , "module Foo where"@@ -4745,18 +4764,26 @@               , "               if f == \"B\" then [| 1 |] else lift f)"               ]         let bazContent = T.unlines ["module Baz where", "import Foo ()"]-        _ <-createDoc "Foo.hs" "haskell" fooContent+        _ <- createDoc "Foo.hs" "haskell" fooContent         doc <- createDoc "Baz.hs" "haskell" bazContent         expectDiagnostics+#if MIN_VERSION_ghc(9,0,0)+          -- String vs [Char] causes this change in error message+          [("Foo.hs", [(DsError, (4, 6), "Couldn't match type")])]+#else           [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]+#endif         -- Now modify the dependent file-        liftIO $ writeFile (dir </> "dep-file.txt") "B"+        liftIO $ writeFile depFilePath "B"+        sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+          List [FileEvent (filePathToUri "dep-file.txt") FcChanged ]++        -- Modifying Baz will now trigger Foo to be rebuilt as well         let change = TextDocumentContentChangeEvent               { _range = Just (Range (Position 2 0) (Position 2 6))               , _rangeLength = Nothing               , _text = "f = ()"               }-        -- Modifying Baz will now trigger Foo to be rebuilt as well         changeDoc doc [change]         expectDiagnostics [("Foo.hs", [])] @@ -4893,7 +4920,7 @@     changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource]     expectDiagnostics       [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])-      ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]+      ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]     closeDoc cdoc  ifaceErrorTest :: TestTree@@ -5012,12 +5039,19 @@     -- Open without OverloadedStrings and expect an error.     doc <- createDoc "Foo.hs" "haskell" fooContent     expectDiagnostics+#if MIN_VERSION_ghc(9,0,0)+      -- String vs [Char] causes this change in error message+      [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])]+#else       [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]+#endif     -- Update hie.yaml to enable OverloadedStrings.     liftIO $       writeFileUTF8         (dir </> "hie.yaml")         "cradle: {direct: {arguments: [-XOverloadedStrings]}}"+    sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+          List [FileEvent (filePathToUri $ dir </> "hie.yaml") FcChanged ]     -- Send change event.     let change =           TextDocumentContentChangeEvent@@ -5049,7 +5083,7 @@          (ec, _, _) <- readCreateProcessWithExitCode cmd "" -        ec @=? ExitSuccess+        ec @?= ExitSuccess   ]  benchmarkTests :: TestTree@@ -5316,7 +5350,7 @@ testSession' :: String -> (FilePath -> Session ()) -> TestTree testSession' name = testCase name . run' -testSessionWait :: String -> Session () -> TestTree+testSessionWait :: HasCallStack => String -> Session () -> TestTree testSessionWait name = testSession name .       -- Check that any diagnostics produced were already consumed by the test case.       --@@ -5717,3 +5751,19 @@ assertJust s = \case   Nothing -> liftIO $ assertFailure s   Just x  -> pure x++-- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String+listOfChar :: T.Text+#if MIN_VERSION_ghc(9,0,1)+listOfChar = "String"+#else+listOfChar = "[Char]"+#endif++-- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did+thDollarIdx :: Int+#if MIN_VERSION_ghc(9,0,1)+thDollarIdx = 1+#else+thDollarIdx = 0+#endif

@@ -1,9 +1,9 @@ module Progress (tests) where -import Development.IDE.Core.ProgressReporting+import qualified Data.HashMap.Strict                    as Map+import           Development.IDE.Core.ProgressReporting import           Test.Tasty import           Test.Tasty.HUnit-import qualified Data.HashMap.Strict as Map  tests :: TestTree tests = testGroup "Progress"

@@ -47,7 +47,7 @@ cursorPosition :: Cursor -> Position cursorPosition (line,  col) = Position line col -requireDiagnostic :: List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion+requireDiagnostic :: HasCallStack => List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do     unless (any match actuals) $         assertFailure $@@ -69,7 +69,7 @@  -- |wait for @timeout@ seconds and report an assertion failure -- if any diagnostic messages arrive in that period-expectNoMoreDiagnostics :: Seconds -> Session ()+expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session () expectNoMoreDiagnostics timeout =   expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do     let fileUri = diagsNot ^. params . uri@@ -109,7 +109,7 @@ -- --   Rather than trying to assert the absence of diagnostics, introduce an --   expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic.-expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()+expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () expectDiagnostics   = expectDiagnosticsWithTags   . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing))))@@ -117,7 +117,7 @@ unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics  -> (Uri, List Diagnostic) unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) -expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session ()+expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () expectDiagnosticsWithTags expected = do     let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri         next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic@@ -125,7 +125,7 @@     expectDiagnosticsWithTags' next expected'  expectDiagnosticsWithTags' ::-  MonadIO m =>+  (HasCallStack, MonadIO m) =>   m (Uri, List Diagnostic) ->   Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] ->   m ()@@ -165,12 +165,12 @@                     <> show actual             go $ Map.delete canonUri m -expectCurrentDiagnostics :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session ()+expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () expectCurrentDiagnostics doc expected = do     diags <- getCurrentDiagnostics doc     checkDiagnosticsForDoc doc expected diags -checkDiagnosticsForDoc :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session ()+checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do     let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)]         nuri = toNormalizedUri _uri