diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -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 diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -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) diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 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, diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -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 diff --git a/src/Control/Concurrent/Strict.hs b/src/Control/Concurrent/Strict.hs --- a/src/Control/Concurrent/Strict.hs +++ b/src/Control/Concurrent/Strict.hs @@ -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 diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -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) diff --git a/src/Development/IDE/Core/Actions.hs b/src/Development/IDE/Core/Actions.hs --- a/src/Development/IDE/Core/Actions.hs +++ b/src/Development/IDE/Core/Actions.hs @@ -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) diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -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 diff --git a/src/Development/IDE/Core/Debouncer.hs b/src/Development/IDE/Core/Debouncer.hs --- a/src/Development/IDE/Core/Debouncer.hs +++ b/src/Development/IDE/Core/Debouncer.hs @@ -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 diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -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 diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -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 diff --git a/src/Development/IDE/Core/IdeConfiguration.hs b/src/Development/IDE/Core/IdeConfiguration.hs --- a/src/Development/IDE/Core/IdeConfiguration.hs +++ b/src/Development/IDE/Core/IdeConfiguration.hs @@ -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) diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -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 diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -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) = diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -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"))) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -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 $ diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -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 diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -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 diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -1,5 +1,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 diff --git a/src/Development/IDE/Core/UseStale.hs b/src/Development/IDE/Core/UseStale.hs --- a/src/Development/IDE/Core/UseStale.hs +++ b/src/Development/IDE/Core/UseStale.hs @@ -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 diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -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 diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -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 diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs --- a/src/Development/IDE/GHC/ExactPrint.hs +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -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 diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -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 _ = "" 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 diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -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 diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -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) diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -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 diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -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 diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -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" ] } diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -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 diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -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 diff --git a/src/Development/IDE/Plugin.hs b/src/Development/IDE/Plugin.hs --- a/src/Development/IDE/Plugin.hs +++ b/src/Development/IDE/Plugin.hs @@ -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 diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -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 "" _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) diff --git a/src/Development/IDE/Plugin/CodeAction/Args.hs b/src/Development/IDE/Plugin/CodeAction/Args.hs --- a/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -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 diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -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) diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -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 = [] diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -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 diff --git a/src/Development/IDE/Plugin/HLS/GhcIde.hs b/src/Development/IDE/Plugin/HLS/GhcIde.hs --- a/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -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" diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -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 diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -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 diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -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 diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -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 diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -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 diff --git a/src/Development/IDE/Spans/LocalBindings.hs b/src/Development/IDE/Spans/LocalBindings.hs --- a/src/Development/IDE/Spans/LocalBindings.hs +++ b/src/Development/IDE/Spans/LocalBindings.hs @@ -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 diff --git a/src/Development/IDE/Types/Action.hs b/src/Development/IDE/Types/Action.hs --- a/src/Development/IDE/Types/Action.hs +++ b/src/Development/IDE/Types/Action.hs @@ -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 diff --git a/src/Development/IDE/Types/HscEnvEq.hs b/src/Development/IDE/Types/HscEnvEq.hs --- a/src/Development/IDE/Types/HscEnvEq.hs +++ b/src/Development/IDE/Types/HscEnvEq.hs @@ -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{..} diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -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 diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -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) diff --git a/src/Generics/SYB/GHC.hs b/src/Generics/SYB/GHC.hs --- a/src/Generics/SYB/GHC.hs +++ b/src/Generics/SYB/GHC.hs @@ -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) diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -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 diff --git a/test/exe/Progress.hs b/test/exe/Progress.hs --- a/test/exe/Progress.hs +++ b/test/exe/Progress.hs @@ -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" diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -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