From 8d356b44a5bb320294564d2858723a7a4111b001 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Fri, 4 Aug 2023 16:39:18 -0500 Subject: [PATCH 01/37] Implement lookupMod function --- ghcide/src/Development/IDE/Core/Actions.hs | 88 ++++++++++++++++++++- ghcide/src/Development/IDE/Spans/AtPoint.hs | 1 + 2 files changed, 86 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 6b9004b0d5..0713147678 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -10,13 +10,21 @@ module Development.IDE.Core.Actions , lookupMod ) where +import Control.Concurrent.MVar (MVar, newEmptyMVar, + putMVar, readMVar) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TQueue (unGetTQueue) +import Control.Monad (unless) import Control.Monad.Extra (mapMaybeM) import Control.Monad.Reader import Control.Monad.Trans.Maybe +import qualified Data.ByteString as BS +import Data.Function ((&)) import qualified Data.HashMap.Strict as HM import Data.Maybe import qualified Data.Text as T import Data.Tuple.Extra +import Development.IDE.Core.Compile (loadHieFile) import Development.IDE.Core.OfInterest import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping @@ -33,10 +41,20 @@ import Language.LSP.Protocol.Types (DocumentHighlight (..), SymbolInformation (..), normalizedFilePathToUri, uriToNormalizedFilePath) +import Language.LSP.Server (resRootPath) +import System.Directory (createDirectoryIfMissing, + doesFileExist, + getPermissions, + setOwnerExecutable, + setOwnerWritable, + setPermissions) +import System.FilePath (takeDirectory, (<.>), + ()) --- | Eventually this will lookup/generate URIs for files in dependencies, but not in the --- project. Right now, this is just a stub. +-- | Generates URIs for files in dependencies, but not in the +-- project. Dependency files are produced from an HIE file and +-- placed in the .hls/dependencies directory. lookupMod :: HieDbWriter -- ^ access the database -> FilePath -- ^ The `.hie` file we got from the database @@ -44,7 +62,71 @@ lookupMod -> Unit -> Bool -- ^ Is this file a boot file? -> MaybeT IdeAction Uri -lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing +lookupMod HieDbWriter{indexQueue} hieFile moduleName uid _boot = MaybeT $ do + -- We need the project root directory to determine where to put + -- the .hls directory. + mProjectRoot <- (resRootPath =<<) <$> asks lspEnv + case mProjectRoot of + Nothing -> pure Nothing + Just projectRoot -> do + -- Database writes happen asynchronously. We use an MVar to mark + -- completion of the database update. + completionToken <- liftIO $ newEmptyMVar + -- Write out the contents of the dependency source to the + -- .hls/dependencies directory, generate a URI for that + -- location, and update the HieDb database with the source + -- file location. + moduleUri <- writeAndIndexSource projectRoot completionToken + -- Wait for the database update to be completed. + -- Reading the completionToken is blocked until it has + -- a value. + liftIO $ readMVar completionToken + pure $ Just moduleUri + where + writeAndIndexSource :: FilePath -> MVar () -> IdeAction Uri + writeAndIndexSource projectRoot completionToken = do + fileExists <- liftIO $ doesFileExist writeOutPath + -- No need to write out the file if it already exists. + unless fileExists $ do + nc <- asks ideNc + liftIO $ do + -- Create the directory where we will put the source. + createDirectoryIfMissing True $ takeDirectory writeOutPath + -- Load a raw Bytestring of the source from the HIE file. + moduleSource <- hie_hs_src <$> loadHieFile (mkUpdater nc) hieFile + -- Write the source into the .hls/dependencies directory. + BS.writeFile writeOutPath moduleSource + fileDefaultPermissions <- getPermissions writeOutPath + let filePermissions = fileDefaultPermissions + & setOwnerWritable False + & setOwnerExecutable False + -- Set the source file to readonly permissions. + setPermissions writeOutPath filePermissions + liftIO $ atomically $ + unGetTQueue indexQueue $ \withHieDb -> do + withHieDb $ \db -> + -- Add a source file to the database row for + -- the HIE file. + HieDb.addSrcFile db hieFile writeOutPath False + -- Mark completion of the database update. + putMVar completionToken () + pure $ moduleUri + where + -- The source will be written out in a directory from the + -- name and hash of the package the dependency module is + -- found in. The name and hash are both parts of the UnitId. + writeOutDir :: FilePath + writeOutDir = projectRoot ".hls" "dependencies" show uid + -- The module name is separated into directories, with the + -- last part of the module name giving the name of the + -- haskell file with a .hs extension. + writeOutFile :: FilePath + writeOutFile = moduleNameSlashes moduleName <.> "hs" + writeOutPath :: FilePath + writeOutPath = writeOutDir writeOutFile + moduleUri :: Uri + moduleUri = AtPoint.toUri writeOutPath + -- IMPORTANT NOTE : make sure all rules `useWithStaleFastMT`d by these have a "Persistent Stale" rule defined, diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 5f1c68b83b..24811a375a 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -20,6 +20,7 @@ module Development.IDE.Spans.AtPoint ( , defRowToSymbolInfo , getNamesAtPoint , toCurrentLocation + , toUri , rowToLoc , nameToLocation , LookupModule From 59502a602289e94f79a65966ee0367ea429f2ca0 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Fri, 4 Aug 2023 17:07:58 -0500 Subject: [PATCH 02/37] Index dependency hie files --- cabal.project | 5 + ghcide/ghcide.cabal | 7 +- .../session-loader/Development/IDE/Session.hs | 10 +- ghcide/src/Development/IDE/Core/Compile.hs | 34 ++-- .../src/Development/IDE/Core/Dependencies.hs | 162 ++++++++++++++++++ ghcide/src/Development/IDE/Core/RuleTypes.hs | 56 +++--- ghcide/src/Development/IDE/Core/Rules.hs | 115 +++++++++---- .../src/Development/IDE/GHC/Compat/Units.hs | 14 ++ ghcide/src/Development/IDE/Types/HscEnvEq.hs | 52 +++--- .../Development/IDE/Types/HscEnvEq.hs-boot | 42 +++++ 10 files changed, 390 insertions(+), 107 deletions(-) create mode 100644 ghcide/src/Development/IDE/Core/Dependencies.hs create mode 100644 ghcide/src/Development/IDE/Types/HscEnvEq.hs-boot diff --git a/cabal.project b/cabal.project index 00c983b81b..2c383287da 100644 --- a/cabal.project +++ b/cabal.project @@ -34,6 +34,11 @@ packages: ./plugins/hls-refactor-plugin ./plugins/hls-overloaded-record-dot-plugin +source-repository-package + type:git + location: https://github.com/nlander/HieDb.git + tag: f10051a6dc1b809d5f40a45beab92205d1829736 + -- Standard location for temporary packages needed for particular environments -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script -- See https://github.com/haskell/haskell-language-server/blob/master/.gitlab-ci.yml diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 6840b52349..60c0533a65 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -72,7 +72,7 @@ library hls-plugin-api == 2.3.0.0, lens, list-t, - hiedb == 0.4.3.*, + hiedb ^>= 0.4.3.0, lsp-types ^>= 2.0.2.0, lsp ^>= 2.2.0.0 , mtl, @@ -154,6 +154,7 @@ library Development.IDE.Core.Actions Development.IDE.Main.HeapStats Development.IDE.Core.Debouncer + Development.IDE.Core.Dependencies Development.IDE.Core.FileStore Development.IDE.Core.FileUtils Development.IDE.Core.IdeConfiguration @@ -238,7 +239,7 @@ library -- We eventually want to build with Werror fully, but we haven't -- finished purging the warnings, so some are set to not be errors -- for now - ghc-options: -Werror + ghc-options: -Werror -Wwarn=unused-packages -Wwarn=unrecognised-pragmas -Wwarn=dodgy-imports @@ -248,7 +249,7 @@ library -Wwarn=incomplete-patterns -Wwarn=overlapping-patterns -Wwarn=incomplete-record-updates - + -- ambiguous-fields is only understood by GHC >= 9.2, so we only disable it -- then. The above comment goes for here too -- this should be understood to -- be temporary until we can remove these warnings. diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index c1225a4f40..19993cccd0 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -48,6 +48,7 @@ import Data.Proxy import qualified Data.Text as T import Data.Time.Clock import Data.Version +import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, Priority, knownTargets, withHieDb) @@ -135,6 +136,7 @@ data Log | LogNoneCradleFound FilePath | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log + | LogRules Rules.Log deriving instance Show Log instance Pretty Log where @@ -205,6 +207,7 @@ instance Pretty Log where LogNewComponentCache componentCache -> "New component cache HscEnvEq:" <+> viaShow componentCache LogHieBios msg -> pretty msg + LogRules msg -> pretty msg -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -607,7 +610,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- New HscEnv for the component in question, returns the new HscEnvEq and -- a mapping from FilePath to the newly created HscEnvEq. - let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv uids + let new_cache = newComponentCache recorder extras optExtensions hieYaml _cfp hscEnv uids (cs, res) <- new_cache new -- Modified cache targets for everything else in the hie.yaml file -- which now uses the same EPS and so on @@ -813,6 +816,7 @@ setNameCache nc hsc = hsc { hsc_NC = nc } -- | Create a mapping from FilePaths to HscEnvEqs newComponentCache :: Recorder (WithPriority Log) + -> ShakeExtras -> [String] -- File extensions to consider -> Maybe FilePath -- Path to cradle -> NormalizedFilePath -- Path to file that caused the creation of this component @@ -820,7 +824,7 @@ newComponentCache -> [(UnitId, DynFlags)] -> ComponentInfo -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) -newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do +newComponentCache recorder extras exts cradlePath cfp hsc_env uids ci = do let df = componentDynFlags ci hscEnv' <- #if MIN_VERSION_ghc(9,3,0) @@ -843,7 +847,7 @@ newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do #endif let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath - henv <- newFunc hscEnv' uids + henv <- newFunc (cmapWithPrio LogRules recorder) extras hscEnv' uids let targetEnv = ([], Just henv) targetDepends = componentDependencyInfo ci res = (targetEnv, targetDepends) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index bbaf3d036e..a385355462 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -925,23 +925,23 @@ spliceExpressions Splices{..} = -- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we -- can just increment the 'indexCompleted' TVar and exit. -- -indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO () -indexHieFile se mod_summary srcPath !hash hf = do +indexHieFile :: ShakeExtras -> NormalizedFilePath -> HieDb.SourceFile -> Util.Fingerprint -> Compat.HieFile -> IO () +indexHieFile se hiePath sourceFile !hash hf = do IdeOptions{optProgressStyle} <- getIdeOptionsIO se atomically $ do pending <- readTVar indexPending - case HashMap.lookup srcPath pending of + case HashMap.lookup hiePath pending of Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled _ -> do -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around let !hf' = hf{hie_hs_src = mempty} - modifyTVar' indexPending $ HashMap.insert srcPath hash + modifyTVar' indexPending $ HashMap.insert hiePath hash writeTQueue indexQueue $ \withHieDb -> do -- We are now in the worker thread -- Check if a newer index of this file has been scheduled, and if so skip this one newerScheduled <- atomically $ do pendingOps <- readTVar indexPending - pure $ case HashMap.lookup srcPath pendingOps of + pure $ case HashMap.lookup hiePath pendingOps of Nothing -> False -- If the hash in the pending list doesn't match the current hash, then skip Just pendingHash -> pendingHash /= hash @@ -949,10 +949,8 @@ indexHieFile se mod_summary srcPath !hash hf = do -- Using bracket, so even if an exception happen during withHieDb call, -- the `post` (which clean the progress indicator) will still be called. bracket_ (pre optProgressStyle) post $ - withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf') + withHieDb (\db -> HieDb.addRefsFromLoaded db (fromNormalizedFilePath hiePath) sourceFile hash hf') where - mod_location = ms_location mod_summary - targetPath = Compat.ml_hie_file mod_location HieDbWriter{..} = hiedbWriter se -- Get a progress token to report progress and update it for the current file @@ -1016,7 +1014,7 @@ indexHieFile se mod_summary srcPath !hash hf = do mdone <- atomically $ do -- Remove current element from pending pending <- stateTVar indexPending $ - dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath + dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) hiePath modifyTVar' indexCompleted (+1) -- If we are done, report and reset completed whenMaybe (HashMap.null pending) $ @@ -1024,7 +1022,9 @@ indexHieFile se mod_summary srcPath !hash hf = do whenJust (lspEnv se) $ \env -> LSP.runLspT env $ when (coerce $ ideTesting se) $ LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ - toJSON $ fromNormalizedFilePath srcPath + toJSON $ case sourceFile of + HieDb.RealFile sourceFilePath -> sourceFilePath + HieDb.FakeFile _ -> fromNormalizedFilePath hiePath whenJust mdone $ \done -> modifyVar_ indexProgressToken $ \tok -> do whenJust (lspEnv se) $ \env -> LSP.runLspT env $ @@ -1045,7 +1045,7 @@ writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = GHC.mkHieFile' mod_summary exports ast source atomicFileWrite se targetPath $ flip GHC.writeHieFile hf hash <- Util.getFileHash targetPath - indexHieFile se mod_summary srcPath hash hf + indexHieFile se (toNormalizedFilePath' targetPath) (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf where dflags = hsc_dflags hscEnv mod_location = ms_location mod_summary @@ -1779,19 +1779,19 @@ pathToModuleName = mkModuleName . map rep - CPP clauses should be placed at the end of the imports section. The clauses should be ordered by the GHC version they target from earlier to later versions, - with negative if clauses coming before positive if clauses of the same - version. (If you think about which GHC version a clause activates for this + with negative if clauses coming before positive if clauses of the same + version. (If you think about which GHC version a clause activates for this should make sense `!MIN_VERSION_GHC(9,0,0)` refers to 8.10 and lower which is - a earlier version than `MIN_VERSION_GHC(9,0,0)` which refers to versions 9.0 + a earlier version than `MIN_VERSION_GHC(9,0,0)` which refers to versions 9.0 and later). In addition there should be a space before and after each CPP clause. - - In if clauses that use `&&` and depend on more than one statement, the + - In if clauses that use `&&` and depend on more than one statement, the positive statement should come before the negative statement. In addition the clause should come after the single positive clause for that GHC version. - - There shouldn't be multiple identical CPP statements. The use of odd or even + - There shouldn't be multiple identical CPP statements. The use of odd or even GHC numbers is identical, with the only preference being to use what is - already there. (i.e. (`MIN_VERSION_GHC(9,2,0)` and `MIN_VERSION_GHC(9,1,0)` + already there. (i.e. (`MIN_VERSION_GHC(9,2,0)` and `MIN_VERSION_GHC(9,1,0)` are functionally equivalent) -} diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs new file mode 100644 index 0000000000..56bf3d1a0e --- /dev/null +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -0,0 +1,162 @@ +module Development.IDE.Core.Dependencies + ( indexDependencyHieFiles + ) where + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TQueue (writeTQueue) +import Control.Monad (unless, void) +import Data.Foldable (traverse_) +import qualified Data.Map as Map +import Data.Maybe (isNothing) +import Data.Set (Set) +import qualified Data.Set as Set +import Development.IDE.Core.Compile (indexHieFile) +import Development.IDE.Core.Rules (HieFileCheck (..), Log, + checkHieFile) +import Development.IDE.Core.Shake (HieDbWriter (indexQueue), + ShakeExtras (hiedbWriter, lspEnv, withHieDb)) +import qualified Development.IDE.GHC.Compat as GHC +import Development.IDE.Types.Location (NormalizedFilePath, + toNormalizedFilePath') +import HieDb (SourceFile (FakeFile), + lookupPackage, + removeDependencySrcFiles) +import Ide.Logger (Recorder, WithPriority) +import Language.LSP.Server (resRootPath) +import System.Directory (doesDirectoryExist) +import System.FilePath ((<.>), ()) + +newtype Package = Package GHC.UnitInfo deriving Eq +instance Ord Package where + compare (Package u1) (Package u2) = compare (GHC.unitId u1) (GHC.unitId u2) + +-- indexDependencyHieFiles gets all of the direct and transitive dependencies +-- from the HscEnv and indexes their HIE files in the HieDb. +indexDependencyHieFiles :: Recorder (WithPriority Log) -> ShakeExtras -> GHC.HscEnv -> IO () +indexDependencyHieFiles recorder se hscEnv = do + -- Check whether the .hls directory exists. + dotHlsDirExists <- maybe (pure False) doesDirectoryExist mHlsDir + -- If the .hls directory does not exits, it may have been deleted. + -- In this case, delete the indexed source files for all + -- dependencies that are already indexed. + unless dotHlsDirExists deleteMissingDependencySources + -- Index all dependency HIE files in the HieDb database. + void $ Map.traverseWithKey indexPackageHieFiles packagesWithModules + where + mHlsDir :: Maybe FilePath + mHlsDir = do + projectDir <- resRootPath =<< lspEnv se + pure $ projectDir ".hls" + -- Add the deletion of dependency source files from the + -- HieDb database to the database write queue. + deleteMissingDependencySources :: IO () + deleteMissingDependencySources = + atomically $ writeTQueue (indexQueue $ hiedbWriter se) $ + \withHieDb -> + withHieDb $ \db -> + removeDependencySrcFiles db + -- Index all of the modules in a package (a Unit). + indexPackageHieFiles :: Package -> [GHC.Module] -> IO () + indexPackageHieFiles (Package package) modules = do + let pkgLibDir :: FilePath + pkgLibDir = case GHC.unitLibraryDirs package of + [] -> "" + (libraryDir : _) -> libraryDir + -- Cabal puts the HIE files for a package in the + -- extra-compilation-artifacts directory, provided + -- it is compiled with the -fwrite-ide-info ghc option. + hieDir :: FilePath + hieDir = pkgLibDir "extra-compilation-artifacts" + unit :: GHC.Unit + unit = GHC.RealUnit $ GHC.Definite $ GHC.unitId package + -- Check if we have already indexed this package. + moduleRows <- withHieDb se $ \db -> + lookupPackage db unit + case moduleRows of + -- There are no modules from this package in the database, + -- so go ahead and index all the modules. + [] -> traverse_ (indexModuleHieFile hieDir) modules + -- There are modules from this package in the database, + -- so assume all the modules have already been indexed + -- and do nothing. + _ -> return () + indexModuleHieFile :: FilePath -> GHC.Module -> IO () + indexModuleHieFile hieDir m = do + let hiePath :: NormalizedFilePath + hiePath = toNormalizedFilePath' $ + hieDir GHC.moduleNameSlashes (GHC.moduleName m) <.> "hie" + -- Check that the module HIE file has correctly loaded. If there + -- was some problem loading it, or if it has already been indexed + -- (which shouldn't happen because we check whether each package + -- has been indexed), then do nothing. Otherwise, call the + -- indexHieFile function from Core.Compile. + hieCheck <- checkHieFile recorder se "newHscEnvEqWithImportPaths" hiePath + case hieCheck of + HieFileMissing -> return () + HieAlreadyIndexed -> return () + CouldNotLoadHie _e -> return () + DoIndexing hash hie -> + -- At this point there is no source file for the HIE file, + -- so the HieDb.SourceFile we give is FakeFile Nothing. + indexHieFile se hiePath (FakeFile Nothing) hash hie + packagesWithModules :: Map.Map Package [GHC.Module] + packagesWithModules = Map.fromSet getModulesForPackage packages + packages :: Set Package + packages = Set.fromList + $ map Package + $ Map.elems + -- Take only the packages in the unitInfoMap that are direct + -- or transitive dependencies. + $ Map.filterWithKey (\uid _ -> uid `Set.member` dependencyIds) unitInfoMap + where + unitInfoMap :: GHC.UnitInfoMap + unitInfoMap = GHC.getUnitInfoMap hscEnv + dependencyIds :: Set GHC.UnitId + dependencyIds = + calculateTransitiveDependencies unitInfoMap directDependencyIds directDependencyIds + directDependencyIds :: Set GHC.UnitId + directDependencyIds = Set.fromList + $ map GHC.toUnitId + $ GHC.explicitUnits + $ GHC.unitState hscEnv + +-- calculateTransitiveDependencies finds the UnitId keys in the UnitInfoMap +-- that are dependencies or transitive dependencies. +calculateTransitiveDependencies :: GHC.UnitInfoMap -> Set GHC.UnitId -> Set GHC.UnitId -> Set GHC.UnitId +calculateTransitiveDependencies unitInfoMap allDependencies newDepencencies + -- If there are no new dependencies, we have found them all, + -- so return allDependencies + | Set.null newDepencencies = allDependencies + -- Otherwise recursively add any dependencies of the newDepencencies + -- that are not in allDependencies already. + | otherwise = calculateTransitiveDependencies unitInfoMap nextAll nextNew + where + nextAll :: Set GHC.UnitId + nextAll = Set.union allDependencies nextNew + -- Get the dependencies of the newDependencies. Then the nextNew depencencies + -- will be the set difference of the dependencies we have so far (allDependencies), + -- and the dependencies of the newDepencencies. + nextNew :: Set GHC.UnitId + nextNew = flip Set.difference allDependencies + $ Set.unions + $ map (Set.fromList . GHC.unitDepends) + $ Map.elems + $ Map.filterWithKey (\uid _ -> uid `Set.member` newDepencencies) unitInfoMap + +getModulesForPackage :: Package -> [GHC.Module] +getModulesForPackage (Package package) = + map makeModule allModules + where + allModules :: [GHC.ModuleName] + allModules = map fst + -- The modules with a Just value in the tuple + -- are from other packages. These won't have + -- an HIE file in this package, and should be + -- covered by the transitive dependencies. + ( filter (isNothing . snd) + $ GHC.unitExposedModules package + ) + ++ GHC.unitHiddenModules package + makeModule :: GHC.ModuleName + -> GHC.Module + makeModule = GHC.mkModule (GHC.mkUnit package) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 30251ee8d3..4f312d6b6c 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -16,34 +16,34 @@ module Development.IDE.Core.RuleTypes( module Development.IDE.Core.RuleTypes ) where -import Control.DeepSeq -import Control.Exception (assert) -import Control.Lens -import Data.Aeson.Types (Value) -import Data.Hashable -import qualified Data.Map as M -import Data.Time.Clock.POSIX -import Data.Typeable -import Development.IDE.GHC.Compat hiding - (HieFileResult) -import Development.IDE.GHC.Compat.Util -import Development.IDE.GHC.CoreFile -import Development.IDE.GHC.Util -import Development.IDE.Graph -import Development.IDE.Import.DependencyInformation -import Development.IDE.Types.HscEnvEq (HscEnvEq) -import Development.IDE.Types.KnownTargets -import GHC.Generics (Generic) - -import Data.ByteString (ByteString) -import Data.Text (Text) -import Development.IDE.Import.FindImports (ArtifactsLocation) -import Development.IDE.Spans.Common -import Development.IDE.Spans.LocalBindings -import Development.IDE.Types.Diagnostics -import GHC.Serialized (Serialized) -import Language.LSP.Protocol.Types (Int32, - NormalizedFilePath) +import Control.DeepSeq +import Control.Exception (assert) +import Control.Lens +import Data.Aeson.Types (Value) +import Data.Hashable +import qualified Data.Map as M +import Data.Time.Clock.POSIX +import Data.Typeable +import Development.IDE.GHC.Compat hiding + (HieFileResult) +import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.CoreFile +import Development.IDE.GHC.Util +import Development.IDE.Graph +import Development.IDE.Import.DependencyInformation +import {-# SOURCE #-} Development.IDE.Types.HscEnvEq (HscEnvEq) +import Development.IDE.Types.KnownTargets +import GHC.Generics (Generic) + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Development.IDE.Import.FindImports (ArtifactsLocation) +import Development.IDE.Spans.Common +import Development.IDE.Spans.LocalBindings +import Development.IDE.Types.Diagnostics +import GHC.Serialized (Serialized) +import Language.LSP.Protocol.Types (Int32, + NormalizedFilePath) data LinkableType = ObjectLinkable | BCOLinkable deriving (Eq,Ord,Show, Generic) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index ae4e6a44bd..7674ae2182 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -13,7 +13,9 @@ module Development.IDE.Core.Rules( -- * Types IdeState, GetParsedModule(..), TransitiveDependencies(..), Priority(..), GhcSessionIO(..), GetClientSettings(..), + HieFileCheck(..), -- * Functions + checkHieFile, priorityTypeCheck, priorityGenerateCore, priorityFilesOfInterest, @@ -76,6 +78,7 @@ import Control.Monad.Trans.Except (ExceptT, except, import Control.Monad.Trans.Maybe import Data.Aeson (toJSON) import qualified Data.Binary as B +import Data.Bool (bool) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Coerce @@ -128,7 +131,7 @@ import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Spans.Documentation import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics as Diag -import Development.IDE.Types.HscEnvEq +import {-# SOURCE #-} Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified GHC.LanguageExtensions as LangExt @@ -177,8 +180,9 @@ data Log = LogShake Shake.Log | LogReindexingHieFile !NormalizedFilePath | LogLoadingHieFile !NormalizedFilePath - | LogLoadingHieFileFail !FilePath !SomeException - | LogLoadingHieFileSuccess !FilePath + | LogMissingHieFile !NormalizedFilePath + | LogLoadingHieFileFail !NormalizedFilePath !SomeException + | LogLoadingHieFileSuccess !NormalizedFilePath | LogTypecheckedFOI !NormalizedFilePath deriving Show @@ -189,13 +193,15 @@ instance Pretty Log where "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path) LogLoadingHieFile path -> "LOADING HIE FILE FOR" <+> pretty (fromNormalizedFilePath path) + LogMissingHieFile path -> + "MISSING HIE FILE" <+> pretty (fromNormalizedFilePath path) LogLoadingHieFileFail path e -> nest 2 $ vcat - [ "FAILED LOADING HIE FILE FOR" <+> pretty path + [ "FAILED LOADING HIE FILE" <+> pretty (fromNormalizedFilePath path) , pretty (displayException e) ] LogLoadingHieFileSuccess path -> - "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path + "SUCCEEDED LOADING HIE FILE" <+> pretty (fromNormalizedFilePath path) LogTypecheckedFOI path -> vcat [ "Typechecked a file which is not currently open in the editor:" <+> pretty (fromNormalizedFilePath path) , "This can indicate a bug which results in excessive memory usage." @@ -538,7 +544,7 @@ reportImportCyclesRule recorder = let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs) -- Convert cycles of files into cycles of module names forM cycles $ \(imp, files) -> do - modNames <- forM files $ + modNames <- forM files $ getModuleName . idToPath depPathIdMap pure $ toDiag imp $ sort modNames where cycleErrorInFile f (PartOfCycle imp fs) @@ -642,14 +648,14 @@ readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath - readHieFileForSrcFromDisk recorder file = do ShakeExtras{withHieDb} <- ask row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file) - let hie_loc = HieDb.hieModuleHieFile row + let hie_loc = toNormalizedFilePath' $ HieDb.hieModuleHieFile row liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFile file exceptToMaybeT $ readHieFileFromDisk recorder hie_loc -readHieFileFromDisk :: Recorder (WithPriority Log) -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile +readHieFileFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> ExceptT SomeException IdeAction Compat.HieFile readHieFileFromDisk recorder hie_loc = do nc <- asks ideNc - res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc + res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) (fromNormalizedFilePath hie_loc) case res of Left e -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileFail hie_loc e Right _ -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileSuccess hie_loc @@ -870,6 +876,56 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco let !fp = Just $! hiFileFingerPrint x return (fp, (diags, Just x)) +-- The result of checkHieFile, which returns a reason why an +-- HIE file should not be indexed, or the data necessary for +-- indexing in the HieDb database. +data HieFileCheck + = HieFileMissing + | HieAlreadyIndexed + | CouldNotLoadHie SomeException + | DoIndexing Util.Fingerprint HieFile + +-- checkHieFile verifies that an HIE file exists, that it has not already +-- been indexed, and attempts to load it. This is intended to happen before +-- any indexing of HIE files in the HieDb database. In addition to returning +-- a HieFileCheck, this function also handles logging. +checkHieFile + :: Recorder (WithPriority Log) + -> ShakeExtras + -> String + -> NormalizedFilePath + -> IO HieFileCheck +checkHieFile recorder se@ShakeExtras{withHieDb} tag hieFileLocation = do + hieFileExists <- doesFileExist $ fromNormalizedFilePath hieFileLocation + bool logHieFileMissing checkExistingHieFile hieFileExists + where + -- Log that the HIE file does not exist where we expect that it should. + logHieFileMissing :: IO HieFileCheck + logHieFileMissing = do + let log :: Log + log = LogMissingHieFile hieFileLocation + logWith recorder Logger.Debug log + pure HieFileMissing + -- When we know that the HIE file exists, check that it has not already + -- been indexed. If it hasn't, try to load it. + checkExistingHieFile :: IO HieFileCheck + checkExistingHieFile = do + hash <- Util.getFileHash $ fromNormalizedFilePath hieFileLocation + mrow <- withHieDb (\hieDb -> HieDb.lookupHieFileFromHash hieDb hash) + dbHieFileLocation <- traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow + bool (tryLoadingHieFile hash) (pure HieAlreadyIndexed) $ + Just hieFileLocation == fmap toNormalizedFilePath' dbHieFileLocation + -- Attempt to load the HIE file, logging on failure (logging happens + -- in readHieFileFromDisk). If the file loads successfully, return + -- the data necessary for indexing it in the HieDb database. + tryLoadingHieFile :: Util.Fingerprint -> IO HieFileCheck + tryLoadingHieFile hash = do + ehf <- runIdeAction tag se $ runExceptT $ + readHieFileFromDisk recorder hieFileLocation + pure $ case ehf of + Left err -> CouldNotLoadHie err + Right hf -> DoIndexing hash hf + -- | Check state of hiedb after loading an iface from disk - have we indexed the corresponding `.hie` file? -- This function is responsible for ensuring database consistency -- Whenever we read a `.hi` file, we must check to ensure we have also @@ -887,31 +943,24 @@ getModIfaceFromDiskAndIndexRule recorder = -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db let ms = hirModSummary x - hie_loc = Compat.ml_hie_file $ ms_location ms - fileHash <- liftIO $ Util.getFileHash hie_loc - mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f)) - hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow - case mrow of - Just row - | fileHash == HieDb.modInfoHash (HieDb.hieModInfo row) - && Just hie_loc == hie_loc' - -> do - -- All good, the db has indexed the file - when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ - LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ - toJSON $ fromNormalizedFilePath f + hie_loc = toNormalizedFilePath' $ Compat.ml_hie_file $ ms_location ms + hieFailure :: Maybe SomeException -> Action () + hieFailure mErr = fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ + maybe "Does not exist" displayException mErr + hieCheck <- liftIO $ checkHieFile recorder se "GetModIfaceFromDiskAndIndex" hie_loc + case hieCheck of + HieFileMissing -> hieFailure Nothing + -- All good, the db has indexed the file + HieAlreadyIndexed -> when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ + toJSON $ fromNormalizedFilePath f -- Not in db, must re-index - _ -> do - ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $ - readHieFileFromDisk recorder hie_loc - case ehf of - -- Uh oh, we failed to read the file for some reason, need to regenerate it - Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err - -- can just re-index the file we read from disk - Right hf -> liftIO $ do - logWith recorder Logger.Debug $ LogReindexingHieFile f - indexHieFile se ms f fileHash hf - + -- Uh oh, we failed to read the file for some reason, need to regenerate it + CouldNotLoadHie err -> hieFailure $ Just err + -- can just re-index the file we read from disk + DoIndexing hash hf -> liftIO $ do + logWith recorder Logger.Debug $ LogReindexingHieFile f + indexHieFile se hie_loc (HieDb.RealFile $ fromNormalizedFilePath f) hash hf return (Just x) newtype DisplayTHWarning = DisplayTHWarning (IO()) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index cd890d855e..68c8d4caa9 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Units.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs @@ -24,6 +24,9 @@ module Development.IDE.GHC.Compat.Units ( -- * UnitInfo UnitInfo, unitExposedModules, + unitHiddenModules, + unitLibraryDirs, + UnitInfo.unitId, unitDepends, unitHaddockInterfaces, mkUnit, @@ -216,6 +219,17 @@ lookupUnit env pid = State.lookupUnit (unitState env) pid preloadClosureUs :: HscEnv -> PreloadUnitClosure preloadClosureUs = State.preloadClosure . unitState +unitHiddenModules :: UnitInfo -> [ModuleName] +unitHiddenModules = UnitInfo.unitHiddenModules + +unitLibraryDirs :: UnitInfo -> [FilePath] +unitLibraryDirs = +#if MIN_VERSION_ghc(9,2,0) + fmap ST.unpack . UnitInfo.unitLibraryDirs +#else + UnitInfo.unitLibraryDirs +#endif + unitHaddockInterfaces :: UnitInfo -> [FilePath] unitHaddockInterfaces = #if MIN_VERSION_ghc(9,2,0) diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 502c265077..68f7cf7f32 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -12,24 +12,29 @@ module Development.IDE.Types.HscEnvEq ) where -import Control.Concurrent.Async (Async, async, waitCatch) -import Control.Concurrent.Strict (modifyVar, newVar) -import Control.DeepSeq (force) -import Control.Exception (evaluate, mask, throwIO) -import Control.Monad.Extra (eitherM, join, mapMaybeM) -import Data.Either (fromRight) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Unique (Unique) -import qualified Data.Unique as Unique -import Development.IDE.GHC.Compat hiding (newUnique) -import qualified Development.IDE.GHC.Compat.Util as Maybes -import Development.IDE.GHC.Error (catchSrcErrors) -import Development.IDE.GHC.Util (lookupPackageConfig) +import Control.Concurrent.Async (Async, async, waitCatch) +import Control.Concurrent.Strict (modifyVar, newVar) +import Control.DeepSeq (force) +import Control.Exception (evaluate, mask, throwIO) +import Control.Monad.Extra (eitherM, join, mapMaybeM) +import Data.Either (fromRight) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Unique (Unique) +import qualified Data.Unique as Unique +import Development.IDE.Core.Dependencies (indexDependencyHieFiles) +import Development.IDE.Core.Rules (Log) +import Development.IDE.Core.Shake (ShakeExtras) +import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Util as Maybes +import Development.IDE.GHC.Error (catchSrcErrors) +import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes -import Development.IDE.Types.Exports (ExportsMap, createExportsMap) -import OpenTelemetry.Eventlog (withSpan) -import System.Directory (makeAbsolute) +import Development.IDE.Types.Exports (ExportsMap, + createExportsMap) +import Ide.Logger (Recorder, WithPriority) +import OpenTelemetry.Eventlog (withSpan) +import System.Directory (makeAbsolute) import System.FilePath -- | An 'HscEnv' with equality. Two values are considered equal @@ -59,8 +64,8 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do update <$> Unique.newUnique -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEq cradlePath hscEnv0 deps = do +newHscEnvEq :: FilePath -> Recorder (WithPriority Log) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq cradlePath recorder se hscEnv0 deps = do let relativeToCradle = (takeDirectory cradlePath ) hscEnv = removeImportPaths hscEnv0 @@ -68,10 +73,11 @@ newHscEnvEq cradlePath hscEnv0 deps = do importPathsCanon <- mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) - newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps + newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) recorder se hscEnv deps -newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do +newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> Recorder (WithPriority Log) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqWithImportPaths envImportPaths recorder se hscEnv deps = do + _ <- async $ indexDependencyHieFiles recorder se hscEnv let dflags = hsc_dflags hscEnv @@ -115,7 +121,7 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do -- | Wrap an 'HscEnv' into an 'HscEnvEq'. newHscEnvEqPreserveImportPaths - :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq + :: Recorder (WithPriority Log) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing -- | Unwrap the 'HscEnv' with the original import paths. diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs-boot b/ghcide/src/Development/IDE/Types/HscEnvEq.hs-boot new file mode 100644 index 0000000000..6213efa558 --- /dev/null +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs-boot @@ -0,0 +1,42 @@ +module Development.IDE.Types.HscEnvEq +( HscEnvEq, + hscEnv, + hscEnvWithImportPaths, + updateHscEnvEq, + envImportPaths, + deps +) where + +import Data.Set (Set) +import Data.Unique (Unique) +import Development.IDE.GHC.Compat +import Development.IDE.Graph.Classes +import Development.IDE.Types.Exports (ExportsMap) + +-- | An 'HscEnv' with equality. Two values are considered equal +-- if they are created with the same call to 'newHscEnvEq'. +data HscEnvEq = HscEnvEq + { envUnique :: !Unique + , hscEnv :: !HscEnv + , deps :: [(UnitId, DynFlags)] + -- ^ In memory components for this HscEnv + -- This is only used at the moment for the import dirs in + -- the DynFlags + , envImportPaths :: Maybe (Set FilePath) + -- ^ If Just, import dirs originally configured in this env + -- If Nothing, the env import dirs are unaltered + , envPackageExports :: IO ExportsMap + , envVisibleModuleNames :: IO (Maybe [ModuleName]) + -- ^ 'listVisibleModuleNames' is a pure function, + -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365 + -- So it's wrapped in IO here for error handling + -- If Nothing, 'listVisibleModuleNames' panic + } + +instance Show HscEnvEq +instance Hashable HscEnvEq +instance NFData HscEnvEq + +updateHscEnvEq :: HscEnvEq -> HscEnv -> IO HscEnvEq + +hscEnvWithImportPaths :: HscEnvEq -> HscEnv From 36d3a91026563c7b4b2090e95c84e59272bc9605 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Mon, 7 Aug 2023 14:41:49 -0500 Subject: [PATCH 03/37] Properly handle open dependency files --- ghcide/src/Development/IDE/Core/Actions.hs | 13 +++-- ghcide/src/Development/IDE/Core/OfInterest.hs | 14 ++++-- ghcide/src/Development/IDE/Core/RuleTypes.hs | 1 + ghcide/src/Development/IDE/Core/Rules.hs | 33 ++++++++++-- ghcide/src/Development/IDE/Core/Shake.hs | 44 +++++++++++++--- .../src/Development/IDE/LSP/Notifications.hs | 25 +++++++--- ghcide/src/Development/IDE/LSP/Outline.hs | 4 +- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 5 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 41 ++++++++++----- hls-plugin-api/src/Ide/Types.hs | 50 ++++++++++++++++--- 10 files changed, 187 insertions(+), 43 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 0713147678..b111f0768e 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -143,11 +143,18 @@ getAtPoint file pos = runMaybeT $ do opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useWithStaleFastMT GetHieAst file - env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file - dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file) + -- The HscEnv and DKMap are not strictly necessary for hover + -- to work, so we only calculate them for project files, not + -- for dependency files. + (mEnv, mDkMap) <- case getSourceFileOrigin file of + FromDependency -> pure (Nothing, Nothing) + FromProject -> do + env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file + dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file) + pure (Just env, Just dkMap) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' + MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf mDkMap mEnv pos' -- | For each Location, determine if we have the PositionMapping -- for the correct file. If not, get the correct position mapping diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 599947659b..9432641f33 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -78,6 +78,7 @@ ofInterestRules recorder = do summarize (IsFOI OnDisk) = BS.singleton 1 summarize (IsFOI (Modified False)) = BS.singleton 2 summarize (IsFOI (Modified True)) = BS.singleton 3 + summarize (IsFOI ReadOnly) = BS.singleton 4 ------------------------------------------------------------ newtype GarbageCollectVar = GarbageCollectVar (Var Bool) @@ -130,23 +131,30 @@ scheduleGarbageCollection state = do -- Could be improved kick :: Action () kick = do - files <- HashMap.keys <$> getFilesOfInterestUntracked + filesOfInterestMap <- getFilesOfInterestUntracked ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras let signal :: KnownSymbol s => Proxy s -> Action () signal msg = when testing $ liftIO $ mRunLspT lspEnv $ LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ toJSON $ map fromNormalizedFilePath files + files :: [NormalizedFilePath] + files = HashMap.keys filesOfInterestMap + -- We cannot run all the Rules on ReadOnly dependency files, so + -- we filter those out. + projectFiles :: [NormalizedFilePath] + projectFiles = HashMap.keys + $ HashMap.filter (/= ReadOnly) filesOfInterestMap signal (Proxy @"kick/start") liftIO $ progressUpdate progress KickStarted -- Update the exports map - results <- uses GenerateCore files + results <- uses GenerateCore projectFiles <* uses GetHieAst files -- needed to have non local completions on the first edit -- when the first edit breaks the module header - <* uses NonLocalCompletions files + <* uses NonLocalCompletions projectFiles let mguts = catMaybes results void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 4f312d6b6c..53e85ac5d1 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -335,6 +335,7 @@ instance Hashable GetFileExists data FileOfInterestStatus = OnDisk + | ReadOnly | Modified { firstOpen :: !Bool -- ^ was this file just opened } deriving (Eq, Show, Typeable, Generic) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 7674ae2182..ddcaa4dbdf 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -571,9 +571,36 @@ reportImportCyclesRule recorder = getHieAstsRule :: Recorder (WithPriority Log) -> Rules () getHieAstsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetHieAst f -> do - tmr <- use_ TypeCheck f - hsc <- hscEnv <$> use_ GhcSessionDeps f - getHieAstRuleDefinition f hsc tmr + case getSourceFileOrigin f of + -- For dependency source files, get the HieAstResult from + -- the HIE file in the HieDb database. + FromDependency -> do + se <- getShakeExtras + mHieFile <- liftIO + $ runIdeAction "GetHieAst" se + $ runMaybeT + -- We can look up the HIE file from its source + -- because at this point lookupMod has already been + -- called and has created the the source file in + -- the .hls directory and indexed it. + $ readHieFileForSrcFromDisk recorder f + pure ([], makeHieAstResult <$> mHieFile) + FromProject -> do + tmr <- use_ TypeCheck f + hsc <- hscEnv <$> use_ GhcSessionDeps f + getHieAstRuleDefinition f hsc tmr + where + makeHieAstResult :: Compat.HieFile -> HieAstResult + makeHieAstResult hieFile = + HAR + (Compat.hie_module hieFile) + hieAsts + (Compat.generateReferencesMap $ M.elems $ getAsts hieAsts) + mempty + (HieFromDisk hieFile) + where + hieAsts :: HieASTs TypeIndex + hieAsts = Compat.hie_asts hieFile persistentHieFileRule :: Recorder (WithPriority Log) -> Rules () persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 82aeb73811..2052a6a574 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -44,6 +44,8 @@ module Development.IDE.Core.Shake( define, defineNoDiagnostics, defineEarlyCutoff, defineNoFile, defineEarlyCutOffNoFile, + getSourceFileOrigin, + SourceFileOrigin(..), getDiagnostics, mRunLspT, mRunLspTCallback, getHiddenDiagnostics, @@ -162,7 +164,9 @@ import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS import Ide.Types (IdePlugins (IdePlugins), PluginDescriptor (pluginId), - PluginId) + PluginId, + SourceFileOrigin (..), + getSourceFileOrigin) import Language.LSP.Diagnostics import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -1186,11 +1190,23 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do Just (Succeeded ver v, _) -> Stale Nothing ver v Just (Stale d ver v, _) -> Stale d ver v Just (Failed b, _) -> Failed b - (mbBs, (diags, mbRes)) <- actionCatch - (do v <- action staleV; liftIO $ evaluate $ force v) $ - \(e :: SomeException) -> do - pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - + (mbBs, (diags, mbRes)) <- do + let doAction = actionCatch + (do v <- action staleV; liftIO $ evaluate $ force v) $ + \(e :: SomeException) -> do + pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) + case getSourceFileOrigin file of + FromProject -> doAction + FromDependency -> if isSafeDependencyRule key + then doAction + -- This should never happen. All code paths that run a + -- Rule that is not on the whitelist defined by + -- isSafeDependencyRule should be disabled for dependency + -- files. If one is found, it should be changed. + else error $ + "defineEarlyCutoff': Undefined action for dependency source files\n" + ++ show file ++ "\n" + ++ show key ver <- estimateFileVersionUnsafely key mbRes file (bs, res) <- case mbRes of Nothing -> do @@ -1231,6 +1247,22 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do -- * creating a dependency: If everything depends on GetModificationTime, we lose early cutoff -- * creating bogus "file does not exists" diagnostics | otherwise = useWithoutDependency (GetModificationTime_ False) fp + isSafeDependencyRule + :: forall k v + . IdeRule k v + => k + -> Bool + isSafeDependencyRule _k + -- The only Rules that are safe for dependencies. + -- GetHieAst is necessary for hover, + -- which can be called in dependency files. + | Just Refl <- eqT @k @GetHieAst = True + -- Dependency files can be files of interest. + | Just Refl <- eqT @k @IsFileOfInterest = True + -- GetModificationTime is safe for any file, and + -- can be called in dependency files by estimateFileVersionUnsafely. + | Just Refl <- eqT @k @GetModificationTime = True + | otherwise = False traceA :: A v -> String traceA (A Failed{}) = "Failed" diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index d0967a25a4..b5e2bd76cb 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -59,25 +59,37 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri _version) [] whenUriFile _uri $ \file -> do + let foiStatus = case getSourceFileOrigin file of + FromProject -> Modified{firstOpen=True} + FromDependency -> ReadOnly -- 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 - addFileOfInterest ide file Modified{firstOpen=True} - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file + addFileOfInterest ide file foiStatus + unless (foiStatus == ReadOnly) + $ setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do - addFileOfInterest ide file Modified{firstOpen=False} - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file + let foiStatus = case getSourceFileOrigin file of + FromProject -> Modified{firstOpen=True} + FromDependency -> ReadOnly + addFileOfInterest ide file foiStatus + unless (foiStatus == ReadOnly) + $ setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do - addFileOfInterest ide file OnDisk - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file + let foiStatus = case getSourceFileOrigin file of + FromProject -> OnDisk + FromDependency -> ReadOnly + addFileOfInterest ide file foiStatus + unless (foiStatus == ReadOnly) + $ setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ @@ -141,6 +153,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa -- The ghcide descriptors should come last'ish so that the notification handlers -- (which restart the Shake build) run after everything else pluginPriority = ghcideNotificationsPluginPriority + , pluginFileType = PluginFileType [FromProject, FromDependency] defaultPluginFileExtensions } ghcideNotificationsPluginPriority :: Natural diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 03260b1b51..eb6fe79d09 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -44,7 +44,9 @@ moduleOutline moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } = liftIO $ case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do - mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) + mb_decls <- case getSourceFileOrigin fp of + FromDependency -> pure Nothing + FromProject -> fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) pure $ case mb_decls of Nothing -> InL [] Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index f85f0c8522..63aa060d1e 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -52,9 +52,10 @@ descriptor plId = (defaultPluginDescriptor plId) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> documentHighlight ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentReferences references - <> mkPluginHandler SMethod_WorkspaceSymbol wsSymbols, + <> mkPluginHandler SMethod_WorkspaceSymbol wsSymbols - pluginConfigDescriptor = defaultConfigDescriptor + , pluginConfigDescriptor = defaultConfigDescriptor + , pluginFileType = PluginFileType [FromProject, FromDependency] defaultPluginFileExtensions } -- --------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 24811a375a..6f5512ce40 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -210,11 +210,11 @@ gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos atPoint :: IdeOptions -> HieAstResult - -> DocAndKindMap - -> HscEnv + -> Maybe DocAndKindMap + -> Maybe HscEnv -> Position -> IO (Maybe (Maybe Range, [T.Text])) -atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env pos = +atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) mDkMap mEnv pos = listToMaybe <$> sequence (pointCommand hf pos hoverInfo) where -- Hover info for values/data @@ -253,9 +253,15 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env prettyName (Right n, dets) = pure $ T.unlines $ wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) : maybeToList (pretty (definedAt n) (prettyPackageName n)) - ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n + ++ catMaybes [ T.unlines . spanDocToMarkdown <$> maybeDoc ] - where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n + where maybeKind = do + (DKMap _ km) <- mDkMap + nameEnv <- lookupNameEnv km n + printOutputable <$> safeTyThingType nameEnv + maybeDoc = do + (DKMap dm _) <- mDkMap + lookupNameEnv dm n pretty Nothing Nothing = Nothing pretty (Just define) Nothing = Just $ define <> "\n" pretty Nothing (Just pkgName) = Just $ pkgName <> "\n" @@ -272,7 +278,8 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env -- the package(with version) this `ModuleName` belongs to. packageNameForImportStatement :: ModuleName -> IO T.Text packageNameForImportStatement mod = do - mpkg <- findImportedModule env mod :: IO (Maybe Module) + mpkg <- fmap join $ sequence $ + flip findImportedModule mod <$> mEnv :: IO (Maybe Module) let moduleName = printOutputable mod case mpkg >>= packageNameWithVersion of Nothing -> pure moduleName @@ -281,12 +288,22 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env -- Return the package name and version of a module. -- For example, given module `Data.List`, it should return something like `base-4.x`. packageNameWithVersion :: Module -> Maybe T.Text - packageNameWithVersion m = do - let pid = moduleUnit m - conf <- lookupUnit env pid - let pkgName = T.pack $ unitPackageNameString conf - version = T.pack $ showVersion (unitPackageVersion conf) - pure $ pkgName <> "-" <> version + packageNameWithVersion m = let pid = moduleUnit m in + case mEnv of + -- If we have an HscEnv (because this is a project file), + -- we can get the package name from that. + Just env -> do + conf <- lookupUnit env pid + let pkgName = T.pack $ unitPackageNameString conf + version = T.pack $ showVersion (unitPackageVersion conf) + pure $ pkgName <> "-" <> version + -- If we don't have an HscEnv (because this is a dependency file), + -- then we can get a similar format for the package name + -- from the UnitId. + Nothing -> + let uid = toUnitId pid + pkgStr = takeWhile (/= ':') $ show uid + in Just $ T.pack pkgStr -- Type info for the current node, it may contains several symbols -- for one range, like wildcard diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 9159fc4596..bd488b02d8 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -24,7 +24,7 @@ {-# LANGUAGE ViewPatterns #-} module Ide.Types ( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor -, defaultPluginPriority +, defaultPluginPriority, defaultPluginFileExtensions , IdeCommand(..) , IdeMethod(..) , IdeNotification(..) @@ -37,6 +37,7 @@ module Ide.Types , FormattingType(..), FormattingMethod, FormattingHandler, mkFormattingHandlers , HasTracing(..) , PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId +, PluginFileType(..) , PluginId(..) , PluginHandler(..), mkPluginHandler , PluginHandlers(..) @@ -45,6 +46,8 @@ module Ide.Types , PluginNotificationHandler(..), mkPluginNotificationHandler , PluginNotificationHandlers(..) , PluginRequestMethod(..) +, SourceFileOrigin(..) +, getSourceFileOrigin , getProcessID, getPid , installSigUsr1Handler , lookupCommandProvider @@ -81,6 +84,7 @@ import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Kind (Type) +import Data.List (isInfixOf) import Data.List.Extra (find, sortOn) import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map @@ -275,23 +279,52 @@ data PluginDescriptor (ideState :: Type) = , pluginNotificationHandlers :: PluginNotificationHandlers ideState , pluginModifyDynflags :: DynFlagsModifications , pluginCli :: Maybe (ParserInfo (IdeCommand ideState)) - , pluginFileType :: [T.Text] + , pluginFileType :: PluginFileType -- ^ File extension of the files the plugin is responsible for. -- The plugin is only allowed to handle files with these extensions. -- When writing handlers, etc. for this plugin it can be assumed that all handled files are of this type. -- The file extension must have a leading '.'. } +-- A description of the types of files that the plugin +-- is intended to work on. It includes the origin of the +-- file (the project, a dependency, or both), and the +-- file extensions the plugin should work on. +data PluginFileType = PluginFileType [SourceFileOrigin] [T.Text] + +data SourceFileOrigin = FromProject | FromDependency deriving Eq + +-- Dependency files are written to the .hls/dependencies directory. +-- If a file is not in this directory, we assume that it is a +-- project file. +getSourceFileOrigin :: NormalizedFilePath -> SourceFileOrigin +getSourceFileOrigin f = + case [".hls", "dependencies"] `isInfixOf` (splitDirectories file) of + True -> FromDependency + False -> FromProject + where + file :: FilePath + file = fromNormalizedFilePath f + -- | Check whether the given plugin descriptor is responsible for the file with the given path. -- Compares the file extension of the file at the given path with the file extension --- the plugin is responsible for. +-- the plugin is responsible for. Also checks that the file origin is included +-- in the valid file origins (project or dependency) for this plugin. pluginResponsible :: Uri -> PluginDescriptor c -> Bool pluginResponsible uri pluginDesc | Just fp <- mfp - , T.pack (takeExtension fp) `elem` pluginFileType pluginDesc = True + , checkFile (pluginFileType pluginDesc) fp = True | otherwise = False where - mfp = uriToFilePath uri + checkFile :: PluginFileType -> NormalizedFilePath -> Bool + checkFile (PluginFileType validOrigins validExtensions) fp = + getSourceFileOrigin fp `elem` validOrigins + && + getExtension fp `elem` validExtensions + getExtension :: NormalizedFilePath -> T.Text + getExtension = T.pack . takeExtension . fromNormalizedFilePath + mfp :: Maybe NormalizedFilePath + mfp = uriToNormalizedFilePath $ toNormalizedUri uri -- | An existential wrapper of 'Properties' data CustomConfig = forall r. CustomConfig (Properties r) @@ -862,7 +895,10 @@ defaultPluginDescriptor plId = mempty mempty Nothing - [".hs", ".lhs", ".hs-boot"] + (PluginFileType [FromProject] defaultPluginFileExtensions) + +defaultPluginFileExtensions :: [T.Text] +defaultPluginFileExtensions = [".hs", ".lhs", ".hs-boot"] -- | Set up a plugin descriptor, initialized with default values. -- This plugin descriptor is prepared for @.cabal@ files and as such, @@ -882,7 +918,7 @@ defaultCabalPluginDescriptor plId = mempty mempty Nothing - [".cabal"] + (PluginFileType [FromProject] [".cabal"]) newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord) From dc6fc8f50ebd5940f97891dcb0d5e85b402bdc7a Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Mon, 7 Aug 2023 23:47:47 -0500 Subject: [PATCH 04/37] Add goto dependency definition test --- ghcide/ghcide.cabal | 1 + ghcide/test/data/dependency/Dependency.hs | 6 ++ ghcide/test/data/dependency/dependency.cabal | 11 +++ ghcide/test/data/dependency/hie.yaml | 2 + ghcide/test/exe/Dependency.hs | 72 ++++++++++++++++++++ ghcide/test/exe/Main.hs | 2 + 6 files changed, 94 insertions(+) create mode 100644 ghcide/test/data/dependency/Dependency.hs create mode 100644 ghcide/test/data/dependency/dependency.cabal create mode 100644 ghcide/test/data/dependency/hie.yaml create mode 100644 ghcide/test/exe/Dependency.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 60c0533a65..5ad132a5b5 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -439,6 +439,7 @@ test-suite ghcide-tests ReferenceTests GarbageCollectionTests OpenCloseTest + Dependency default-extensions: BangPatterns DeriveFunctor diff --git a/ghcide/test/data/dependency/Dependency.hs b/ghcide/test/data/dependency/Dependency.hs new file mode 100644 index 0000000000..aacefa3fbf --- /dev/null +++ b/ghcide/test/data/dependency/Dependency.hs @@ -0,0 +1,6 @@ +module Dependency where + +import Control.Concurrent.Async (AsyncCancelled (..)) + +asyncCancelled :: AsyncCancelled +asyncCancelled = AsyncCancelled diff --git a/ghcide/test/data/dependency/dependency.cabal b/ghcide/test/data/dependency/dependency.cabal new file mode 100644 index 0000000000..154f6d4f88 --- /dev/null +++ b/ghcide/test/data/dependency/dependency.cabal @@ -0,0 +1,11 @@ +name: dependency +version: 0.1.0.0 +cabal-version: 2.0 +build-type: Simple + +library + exposed-modules: Dependency + default-language: Haskell2010 + build-depends: base + , async == 2.2.4 + ghc-options: -fwrite-ide-info diff --git a/ghcide/test/data/dependency/hie.yaml b/ghcide/test/data/dependency/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/ghcide/test/data/dependency/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs new file mode 100644 index 0000000000..281863905e --- /dev/null +++ b/ghcide/test/exe/Dependency.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +module Dependency where + +import qualified Control.Applicative as Applicative +import Control.Applicative.Combinators (skipManyTill) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Bool (bool) +import Data.List (isSuffixOf) +import Data.Proxy (Proxy (..)) +import Language.LSP.Protocol.Message (TCustomMessage (NotMess), + TNotificationMessage (..)) +import Language.LSP.Protocol.Types (Definition (..), + Location (..), Position (..), + Range (..), + type (|?) (InL, InR), + uriToFilePath) +import Language.LSP.Test (Session, anyMessage, + customNotification, + getDefinitions, openDoc) +import System.FilePath (splitDirectories, (<.>), + ()) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, + (@?=)) +import TestUtils (testSessionWithExtraFiles) + +tests :: TestTree +tests = + testGroup "gotoDefinition for dependencies" + [ dependencyTest + ] + where + dependencyTest :: TestTree + dependencyTest = testSessionWithExtraFiles "dependency" "gotoDefinition in async" $ + \dir -> do + doc <- openDoc (dir "Dependency" <.> "hs") "haskell" + _hieFile <- fileDoneIndexing ["Control", "Concurrent", "Async.hie"] + defs <- getDefinitions doc (Position 5 20) + let expRange = Range (Position 430 22) (Position 430 36) + case defs of + InL (Definition (InR [Location fp actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath fp + assertBool "AsyncCancelled found in a module that is not Control.Concurrent Async" + $ ["Control", "Concurrent", "Async.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for AsyncCancelled: " + ++ show wrongLocation + fileDoneIndexing :: [String] -> Session FilePath + fileDoneIndexing fpSuffix = + skipManyTill anyMessage indexedFile + where + indexedFile :: Session FilePath + indexedFile = do + NotMess TNotificationMessage{_params} <- + customNotification (Proxy @"ghcide/reference/ready") + case A.fromJSON _params of + A.Success fp -> do + let fpDirs :: [String] + fpDirs = splitDirectories fp + bool Applicative.empty (pure fp) $ + fpSuffix `isSuffixOf` fpDirs + other -> error $ "Failed to parse ghcide/reference/ready file: " <> show other diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 18296dce16..8e2cecf22c 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -76,6 +76,7 @@ import ClientSettingsTests import ReferenceTests import GarbageCollectionTests import ExceptionTests +import Dependency main :: IO () main = do @@ -124,4 +125,5 @@ main = do , GarbageCollectionTests.tests , HieDbRetry.tests , ExceptionTests.tests recorder logger + , Dependency.tests ] From 19bf2b84e183f0e2d8302e4e8e6a4829784bc2da Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Wed, 9 Aug 2023 13:52:17 -0500 Subject: [PATCH 05/37] Fix older ghc builds --- cabal.project | 2 +- .../src/Development/IDE/Core/Dependencies.hs | 25 ++++++++----------- .../src/Development/IDE/GHC/Compat/Units.hs | 24 ++++++++++++++++++ 3 files changed, 36 insertions(+), 15 deletions(-) diff --git a/cabal.project b/cabal.project index 2c383287da..12ecf8a4fb 100644 --- a/cabal.project +++ b/cabal.project @@ -37,7 +37,7 @@ packages: source-repository-package type:git location: https://github.com/nlander/HieDb.git - tag: f10051a6dc1b809d5f40a45beab92205d1829736 + tag: 4eebfcf8fab54f24808e6301227d77ae64d2509c -- Standard location for temporary packages needed for particular environments -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs index 56bf3d1a0e..34fe8143dd 100644 --- a/ghcide/src/Development/IDE/Core/Dependencies.hs +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -68,7 +68,7 @@ indexDependencyHieFiles recorder se hscEnv = do hieDir :: FilePath hieDir = pkgLibDir "extra-compilation-artifacts" unit :: GHC.Unit - unit = GHC.RealUnit $ GHC.Definite $ GHC.unitId package + unit = GHC.fromUnitId $ GHC.unitId package -- Check if we have already indexed this package. moduleRows <- withHieDb se $ \db -> lookupPackage db unit @@ -104,16 +104,14 @@ indexDependencyHieFiles recorder se hscEnv = do packages :: Set Package packages = Set.fromList $ map Package - $ Map.elems - -- Take only the packages in the unitInfoMap that are direct - -- or transitive dependencies. - $ Map.filterWithKey (\uid _ -> uid `Set.member` dependencyIds) unitInfoMap + -- Take only the packages that are direct or transitive dependencies. + $ filter (\unitInfo -> GHC.unitId unitInfo `Set.member` dependencyIds) allPackages where - unitInfoMap :: GHC.UnitInfoMap - unitInfoMap = GHC.getUnitInfoMap hscEnv + allPackages :: [GHC.UnitInfo] + allPackages = GHC.getUnitInfo hscEnv dependencyIds :: Set GHC.UnitId dependencyIds = - calculateTransitiveDependencies unitInfoMap directDependencyIds directDependencyIds + calculateTransitiveDependencies allPackages directDependencyIds directDependencyIds directDependencyIds :: Set GHC.UnitId directDependencyIds = Set.fromList $ map GHC.toUnitId @@ -122,14 +120,14 @@ indexDependencyHieFiles recorder se hscEnv = do -- calculateTransitiveDependencies finds the UnitId keys in the UnitInfoMap -- that are dependencies or transitive dependencies. -calculateTransitiveDependencies :: GHC.UnitInfoMap -> Set GHC.UnitId -> Set GHC.UnitId -> Set GHC.UnitId -calculateTransitiveDependencies unitInfoMap allDependencies newDepencencies - -- If there are no new dependencies, we have found them all, +calculateTransitiveDependencies :: [GHC.UnitInfo] -> Set GHC.UnitId -> Set GHC.UnitId -> Set GHC.UnitId +calculateTransitiveDependencies allPackages allDependencies newDepencencies + -- If there are no new dependencies, then we have found them all, -- so return allDependencies | Set.null newDepencencies = allDependencies -- Otherwise recursively add any dependencies of the newDepencencies -- that are not in allDependencies already. - | otherwise = calculateTransitiveDependencies unitInfoMap nextAll nextNew + | otherwise = calculateTransitiveDependencies allPackages nextAll nextNew where nextAll :: Set GHC.UnitId nextAll = Set.union allDependencies nextNew @@ -140,8 +138,7 @@ calculateTransitiveDependencies unitInfoMap allDependencies newDepencencies nextNew = flip Set.difference allDependencies $ Set.unions $ map (Set.fromList . GHC.unitDepends) - $ Map.elems - $ Map.filterWithKey (\uid _ -> uid `Set.member` newDepencencies) unitInfoMap + $ filter (\unitInfo -> GHC.unitId unitInfo `Set.member` newDepencencies) allPackages getModulesForPackage :: Package -> [GHC.Module] getModulesForPackage (Package package) = diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index 68c8d4caa9..9d741e8615 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Units.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs @@ -19,6 +19,7 @@ module Development.IDE.GHC.Compat.Units ( -- * UnitInfoMap UnitInfoMap, getUnitInfoMap, + getUnitInfo, lookupUnit, lookupUnit', -- * UnitInfo @@ -42,6 +43,7 @@ module Development.IDE.GHC.Compat.Units ( installedModule, -- * Module toUnitId, + fromUnitId, Development.IDE.GHC.Compat.Units.moduleUnitId, moduleUnit, -- * ExternalPackageState @@ -213,6 +215,16 @@ getUnitInfoMap = unitInfoMap . unitState #endif +getUnitInfo :: HscEnv -> [UnitInfo] +getUnitInfo = +#if MIN_VERSION_ghc(9,2,0) + State.listUnitInfo . ue_units . hsc_unit_env +#elif MIN_VERSION_ghc(9,0,0) + State.listUnitInfo . unitState +#else + Packages.listPackageConfigMap . hsc_dflags +#endif + lookupUnit :: HscEnv -> Unit -> Maybe UnitInfo lookupUnit env pid = State.lookupUnit (unitState env) pid @@ -220,7 +232,11 @@ preloadClosureUs :: HscEnv -> PreloadUnitClosure preloadClosureUs = State.preloadClosure . unitState unitHiddenModules :: UnitInfo -> [ModuleName] +#if MIN_VERSION_ghc(9,0,0) unitHiddenModules = UnitInfo.unitHiddenModules +#else +unitHiddenModules = Packages.hiddenModules +#endif unitLibraryDirs :: UnitInfo -> [FilePath] unitLibraryDirs = @@ -261,6 +277,14 @@ installedModule = Module #endif +fromUnitId :: UnitId -> Unit +fromUnitId = +#if MIN_VERSION_ghc(9,0,0) + RealUnit . Definite +#else + id +#endif + moduleUnitId :: Module -> UnitId moduleUnitId = Unit.toUnitId . Unit.moduleUnit From 727a044d127c1ee4dc7ce174de2ece43f9458c53 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 10 Aug 2023 19:53:21 -0500 Subject: [PATCH 06/37] Install cabal head in CI --- .github/actions/setup-build/action.yml | 4 ++-- .github/workflows/bench.yml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/actions/setup-build/action.yml b/.github/actions/setup-build/action.yml index f126941a90..680c3feb2c 100644 --- a/.github/actions/setup-build/action.yml +++ b/.github/actions/setup-build/action.yml @@ -7,7 +7,7 @@ inputs: cabal: description: "Cabal version" required: false - default: "3.8.1.0" + default: "head" os: description: "Operating system: Linux, Windows or macOS" required: true @@ -31,7 +31,7 @@ runs: sudo chown -R $USER /usr/local/.ghcup shell: bash - - uses: haskell/actions/setup@v2.4.7 + - uses: haskell-actions/setup@v2.5.0 id: HaskEnvSetup with: ghc-version : ${{ inputs.ghc }} diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index bd558576d1..6f548c5157 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -121,7 +121,7 @@ jobs: example: ['cabal', 'lsp-types'] steps: - - uses: haskell/actions/setup@v2.4.7 + - uses: haskell-actions/setup@v2.5.0 with: ghc-version : ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} From a1a70b7d862b205056d10d0f9269afb9451156fa Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 10 Aug 2023 23:00:25 -0500 Subject: [PATCH 07/37] Move -fwrite-ide-info to cabal.project --- ghcide/test/data/dependency/cabal.project | 3 +++ ghcide/test/data/dependency/dependency.cabal | 1 - 2 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 ghcide/test/data/dependency/cabal.project diff --git a/ghcide/test/data/dependency/cabal.project b/ghcide/test/data/dependency/cabal.project new file mode 100644 index 0000000000..5614f62977 --- /dev/null +++ b/ghcide/test/data/dependency/cabal.project @@ -0,0 +1,3 @@ +packages: . +package * + ghc-options: -fwrite-ide-info diff --git a/ghcide/test/data/dependency/dependency.cabal b/ghcide/test/data/dependency/dependency.cabal index 154f6d4f88..0fd4ddc646 100644 --- a/ghcide/test/data/dependency/dependency.cabal +++ b/ghcide/test/data/dependency/dependency.cabal @@ -8,4 +8,3 @@ library default-language: Haskell2010 build-depends: base , async == 2.2.4 - ghc-options: -fwrite-ide-info From 3b9470eb8eff00fc80690a182a8b767816118be7 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Fri, 11 Aug 2023 15:29:30 -0500 Subject: [PATCH 08/37] Add new hiedb to stack.yaml --- stack-lts21.yaml | 4 +++- stack.yaml | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/stack-lts21.yaml b/stack-lts21.yaml index c119576d1f..5f35008472 100644 --- a/stack-lts21.yaml +++ b/stack-lts21.yaml @@ -43,7 +43,9 @@ allow-newer: true extra-deps: - floskell-0.10.7 -- hiedb-0.4.3.0 +# - hiedb-0.4.3.0 +- git: https://github.com/nlander/HieDb.git + commit: 4eebfcf8fab54f24808e6301227d77ae64d2509c - implicit-hie-0.1.2.7 - implicit-hie-cradle-0.5.0.1 - monad-dijkstra-0.1.1.3 diff --git a/stack.yaml b/stack.yaml index 7a0744226a..a17bf64172 100644 --- a/stack.yaml +++ b/stack.yaml @@ -43,7 +43,9 @@ allow-newer: true extra-deps: - Cabal-syntax-3.10.1.0@sha256:bb835ebab577fd0f9c11dab96210dbb8d68ffc62652576f4b092563c345930e7,7434 # - floskell-0.10.7 -- hiedb-0.4.3.0 +# - hiedb-0.4.3.0 +- git: https://github.com/nlander/HieDb.git + commit: 4eebfcf8fab54f24808e6301227d77ae64d2509c - implicit-hie-0.1.2.7 - implicit-hie-cradle-0.5.0.1 - algebraic-graphs-0.6.1 From d6d245e58a133a8fc1f5ca0fbcbe907d7de37778 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Fri, 11 Aug 2023 15:32:11 -0500 Subject: [PATCH 09/37] Add new hiedb to nix config --- configuration-ghc-90.nix | 2 ++ configuration-ghc-92.nix | 2 ++ configuration-ghc-94.nix | 2 ++ configuration-ghc-96.nix | 2 ++ flake.nix | 4 ++++ 5 files changed, 12 insertions(+) diff --git a/configuration-ghc-90.nix b/configuration-ghc-90.nix index 8152f110fa..364070625a 100644 --- a/configuration-ghc-90.nix +++ b/configuration-ghc-90.nix @@ -24,6 +24,8 @@ let lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; lsp-test = hself.callCabal2nix "lsp-test" inputs.lsp-test {}; + hiedb = hself.callCabal2nix "hiedb" inputs.hiedb {}; + hlint = appendConfigureFlag (hself.callCabal2nix "hlint" inputs.hlint-35 {}) "-fghc-lib"; hls-hlint-plugin = hself.callCabal2nixWithOptions "hls-hlint-plugin" diff --git a/configuration-ghc-92.nix b/configuration-ghc-92.nix index 01402a6497..b309017ba0 100644 --- a/configuration-ghc-92.nix +++ b/configuration-ghc-92.nix @@ -25,6 +25,8 @@ let ghc-lib-parser = hsuper.ghc-lib-parser_9_4_5_20230430; + hiedb = hself.callCabal2nix "hiedb" inputs.hiedb {}; + hlint = appendConfigureFlag (hself.callCabal2nix "hlint" inputs.hlint-35 {}) "-fghc-lib"; ormolu = hself.callCabal2nix "ormolu" inputs.ormolu-052 {}; diff --git a/configuration-ghc-94.nix b/configuration-ghc-94.nix index e561496955..4a1ca93e66 100644 --- a/configuration-ghc-94.nix +++ b/configuration-ghc-94.nix @@ -23,6 +23,8 @@ let lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; lsp-test = dontCheck (hself.callCabal2nix "lsp-test" inputs.lsp-test {}); + hiedb = hself.callCabal2nix "hiedb" inputs.hiedb {}; + # Re-generate HLS drv excluding some plugins haskell-language-server = hself.callCabal2nixWithOptions "haskell-language-server" ./. diff --git a/configuration-ghc-96.nix b/configuration-ghc-96.nix index 744e7047d1..bf0f7f8581 100644 --- a/configuration-ghc-96.nix +++ b/configuration-ghc-96.nix @@ -48,6 +48,8 @@ let lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; lsp-test = dontCheck (hself.callCabal2nix "lsp-test" inputs.lsp-test {}); + hiedb = hself.callCabal2nix "hiedb" inputs.hiedb {}; + # Re-generate HLS drv excluding some plugins haskell-language-server = hself.callCabal2nixWithOptions "haskell-language-server" ./. diff --git a/flake.nix b/flake.nix index b68f43c2d1..88907b1b90 100644 --- a/flake.nix +++ b/flake.nix @@ -81,6 +81,10 @@ url = "github:smunix/implicit-hie-cradle?ref=smunix-patch-hls-0.5-1"; flake = false; }; + hiedb = { + url = "github:nlander/HieDb?ref=all-new-functions"; + flake = false; + }; }; outputs = inputs@{ self, nixpkgs, flake-compat, flake-utils, gitignore, ... }: From 95afde55871347f193a106421ad6dc4961efa42b Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Mon, 14 Aug 2023 19:09:46 -0500 Subject: [PATCH 10/37] Move dependencyTest to top level --- ghcide/test/exe/Dependency.hs | 75 ++++++++++++++++++----------------- 1 file changed, 38 insertions(+), 37 deletions(-) diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index 281863905e..69c5a97069 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -32,41 +32,42 @@ tests = testGroup "gotoDefinition for dependencies" [ dependencyTest ] + +fileDoneIndexing :: [String] -> Session FilePath +fileDoneIndexing fpSuffix = + skipManyTill anyMessage indexedFile where - dependencyTest :: TestTree - dependencyTest = testSessionWithExtraFiles "dependency" "gotoDefinition in async" $ - \dir -> do - doc <- openDoc (dir "Dependency" <.> "hs") "haskell" - _hieFile <- fileDoneIndexing ["Control", "Concurrent", "Async.hie"] - defs <- getDefinitions doc (Position 5 20) - let expRange = Range (Position 430 22) (Position 430 36) - case defs of - InL (Definition (InR [Location fp actualRange])) -> - liftIO $ do - let locationDirectories :: [String] - locationDirectories = - maybe [] splitDirectories $ - uriToFilePath fp - assertBool "AsyncCancelled found in a module that is not Control.Concurrent Async" - $ ["Control", "Concurrent", "Async.hs"] - `isSuffixOf` locationDirectories - actualRange @?= expRange - wrongLocation -> - liftIO $ - assertFailure $ "Wrong location for AsyncCancelled: " - ++ show wrongLocation - fileDoneIndexing :: [String] -> Session FilePath - fileDoneIndexing fpSuffix = - skipManyTill anyMessage indexedFile - where - indexedFile :: Session FilePath - indexedFile = do - NotMess TNotificationMessage{_params} <- - customNotification (Proxy @"ghcide/reference/ready") - case A.fromJSON _params of - A.Success fp -> do - let fpDirs :: [String] - fpDirs = splitDirectories fp - bool Applicative.empty (pure fp) $ - fpSuffix `isSuffixOf` fpDirs - other -> error $ "Failed to parse ghcide/reference/ready file: " <> show other + indexedFile :: Session FilePath + indexedFile = do + NotMess TNotificationMessage{_params} <- + customNotification (Proxy @"ghcide/reference/ready") + case A.fromJSON _params of + A.Success fp -> do + let fpDirs :: [String] + fpDirs = splitDirectories fp + bool Applicative.empty (pure fp) $ + fpSuffix `isSuffixOf` fpDirs + other -> error $ "Failed to parse ghcide/reference/ready file: " <> show other + +dependencyTest :: TestTree +dependencyTest = testSessionWithExtraFiles "dependency" "gotoDefinition in async" $ + \dir -> do + doc <- openDoc (dir "Dependency" <.> "hs") "haskell" + _hieFile <- fileDoneIndexing ["Control", "Concurrent", "Async.hie"] + defs <- getDefinitions doc (Position 5 20) + let expRange = Range (Position 430 22) (Position 430 36) + case defs of + InL (Definition (InR [Location fp actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath fp + assertBool "AsyncCancelled found in a module that is not Control.Concurrent Async" + $ ["Control", "Concurrent", "Async.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for AsyncCancelled: " + ++ show wrongLocation From 377e6c1abed9762a199bf2cd0355a47890bed88c Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Tue, 15 Aug 2023 09:06:09 -0500 Subject: [PATCH 11/37] Add transitive dependency test --- ghcide/src/Development/IDE/Core/Actions.hs | 4 +- ghcide/src/Development/IDE/Core/Shake.hs | 3 ++ ghcide/test/exe/Dependency.hs | 48 ++++++++++++++++++++++ 3 files changed, 54 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index b111f0768e..1a1c3f5bf2 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -193,7 +193,9 @@ getDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file - (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file + (ImportMap imports, _) <- case getSourceFileOrigin file of + FromProject -> useWithStaleFastMT GetImportMap file + FromDependency -> pure (ImportMap mempty, PositionMapping idDelta) !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' MaybeT $ Just <$> toCurrentLocations mapping file locations diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 2052a6a574..557b834796 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1262,6 +1262,9 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do -- GetModificationTime is safe for any file, and -- can be called in dependency files by estimateFileVersionUnsafely. | Just Refl <- eqT @k @GetModificationTime = True + -- AddWatchedFile can be called by GetModificationTime + -- and is also safe for any file. + | Just Refl <- eqT @k @AddWatchedFile = True | otherwise = False traceA :: A v -> String diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index 69c5a97069..2c1f26570c 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -9,6 +9,7 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import Data.Bool (bool) import Data.List (isSuffixOf) +import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) import Language.LSP.Protocol.Message (TCustomMessage (NotMess), TNotificationMessage (..)) @@ -31,6 +32,7 @@ tests :: TestTree tests = testGroup "gotoDefinition for dependencies" [ dependencyTest + , transitiveDependencyTest ] fileDoneIndexing :: [String] -> Session FilePath @@ -71,3 +73,49 @@ dependencyTest = testSessionWithExtraFiles "dependency" "gotoDefinition in async liftIO $ assertFailure $ "Wrong location for AsyncCancelled: " ++ show wrongLocation + +-- Tests that we can go to the definition of a dependency, and then +-- from the dependency file we can use gotoDefinition to see a +-- tranisive dependency. +transitiveDependencyTest :: TestTree +transitiveDependencyTest = testSessionWithExtraFiles "dependency" "goto transitive dependency async -> hashable" $ + \dir -> do + localDoc <- openDoc (dir "Dependency" <.> "hs") "haskell" + _asyncHieFile <- fileDoneIndexing ["Control", "Concurrent", "Async.hie"] + _hashableHieFile <- fileDoneIndexing ["Data", "Hashable", "Class.hie"] + asyncDefs <- getDefinitions localDoc (Position 5 20) + asyncHsFile <- case asyncDefs of + InL (Definition (InR [Location uri _actualRange])) -> + liftIO $ do + let fp :: FilePath + fp = fromMaybe "" $ uriToFilePath uri + locationDirectories :: [String] + locationDirectories = splitDirectories fp + assertBool "AsyncCancelled found in a module that is not Control.Concurrent Async" + $ ["Control", "Concurrent", "Async.hs"] + `isSuffixOf` locationDirectories + pure fp + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for AsyncCancelled: " + ++ show wrongLocation + asyncDoc <- openDoc asyncHsFile "haskell" + hashableDefs <- getDefinitions asyncDoc (Position 246 11) + -- The location of the definition of Hashable in + -- Data.Hashable.Class + let expRange = Range (Position 198 14) (Position 198 22) + case hashableDefs of + InL (Definition (InR [Location uri actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath uri + assertBool "Hashable found in a module that is not Data.Hashable.Class" + $ ["Data", "Hashable", "Class.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for Hashable: " + ++ show wrongLocation From e2578a07f25cc6065b70220da3ee3d799a822a40 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Wed, 16 Aug 2023 23:34:59 -0500 Subject: [PATCH 12/37] Add augogen dependency test --- .../data/dependency-autogen/Dependency.hs | 6 ++ .../data/dependency-autogen/cabal.project | 3 + .../dependency-autogen.cabal | 10 ++++ ghcide/test/data/dependency-autogen/hie.yaml | 2 + ghcide/test/exe/Dependency.hs | 56 ++++++++++++++++++- 5 files changed, 76 insertions(+), 1 deletion(-) create mode 100644 ghcide/test/data/dependency-autogen/Dependency.hs create mode 100644 ghcide/test/data/dependency-autogen/cabal.project create mode 100644 ghcide/test/data/dependency-autogen/dependency-autogen.cabal create mode 100644 ghcide/test/data/dependency-autogen/hie.yaml diff --git a/ghcide/test/data/dependency-autogen/Dependency.hs b/ghcide/test/data/dependency-autogen/Dependency.hs new file mode 100644 index 0000000000..0a9a2e7f60 --- /dev/null +++ b/ghcide/test/data/dependency-autogen/Dependency.hs @@ -0,0 +1,6 @@ +module Dependency where + +import Language.Haskell.Stylish (Step, tabs) + +t :: Int -> Step +t = tabs diff --git a/ghcide/test/data/dependency-autogen/cabal.project b/ghcide/test/data/dependency-autogen/cabal.project new file mode 100644 index 0000000000..5614f62977 --- /dev/null +++ b/ghcide/test/data/dependency-autogen/cabal.project @@ -0,0 +1,3 @@ +packages: . +package * + ghc-options: -fwrite-ide-info diff --git a/ghcide/test/data/dependency-autogen/dependency-autogen.cabal b/ghcide/test/data/dependency-autogen/dependency-autogen.cabal new file mode 100644 index 0000000000..4e50c77da4 --- /dev/null +++ b/ghcide/test/data/dependency-autogen/dependency-autogen.cabal @@ -0,0 +1,10 @@ +name: dependency-autogen +version: 0.1.0.0 +cabal-version: 2.0 +build-type: Simple + +library + exposed-modules: Dependency + default-language: Haskell2010 + build-depends: base + , stylish-haskell == 0.14.5.0 diff --git a/ghcide/test/data/dependency-autogen/hie.yaml b/ghcide/test/data/dependency-autogen/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/ghcide/test/data/dependency-autogen/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index 2c1f26570c..ffa90c94de 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -11,6 +11,7 @@ import Data.Bool (bool) import Data.List (isSuffixOf) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) +import Development.IDE.GHC.Compat (GhcVersion (..)) import Language.LSP.Protocol.Message (TCustomMessage (NotMess), TNotificationMessage (..)) import Language.LSP.Protocol.Types (Definition (..), @@ -26,13 +27,14 @@ import System.FilePath (splitDirectories, (<.>), import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, (@?=)) -import TestUtils (testSessionWithExtraFiles) +import TestUtils (testSessionWithExtraFiles, knownBrokenForGhcVersions) tests :: TestTree tests = testGroup "gotoDefinition for dependencies" [ dependencyTest , transitiveDependencyTest + , autogenDependencyTest ] fileDoneIndexing :: [String] -> Session FilePath @@ -119,3 +121,55 @@ transitiveDependencyTest = testSessionWithExtraFiles "dependency" "goto transiti liftIO $ assertFailure $ "Wrong location for Hashable: " ++ show wrongLocation + +-- Testing that we can go to a definition in an autogen module of a +-- dependency. Stylish haskell is a package that has an autogen module, +-- but it doesn't seem to build with ghc 9.0 or earlier. Suggestions on +-- another package we could use for this test are welcome! This test +-- doesn't go directly to the fuction in the autogen module because +-- it is a hidden module, so we can't import that function directly +-- in our project. However, hidden modules are also indexed, so we +-- can go to a definition in a module that imports the autogen module +-- and goto the autogen module from there. +autogenDependencyTest :: TestTree +autogenDependencyTest = knownBrokenForGhcVersions [GHC810, GHC90] "stylish-haskell does not build with older GHC versions" $ + testSessionWithExtraFiles "dependency-autogen" "goto autogen module in dependency" $ + \dir -> do + localDoc <- openDoc (dir "Dependency" <.> "hs") "haskell" + _hieFile <- fileDoneIndexing ["Paths_stylish_haskell.hie"] + stylishDefs <- getDefinitions localDoc (Position 5 5) + stylishFile <- case stylishDefs of + InL (Definition (InR [Location uri _actualRange])) -> + liftIO $ do + let fp :: FilePath + fp = fromMaybe "" $ uriToFilePath uri + locationDirectories :: [String] + locationDirectories = splitDirectories fp + assertBool "tags found in a module that is not Language.Haskell.Stylish" + $ ["Language", "Haskell", "Stylish.hs"] + `isSuffixOf` locationDirectories + pure fp + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for AsyncCancelled: " + ++ show wrongLocation + stylishDoc <- openDoc stylishFile "haskell" + pathsDefs <- getDefinitions stylishDoc (Position 19 8) + -- The location of the definition of version in + -- Paths_stylish_haskell + let expRange = Range (Position 35 0) (Position 35 7) + case pathsDefs of + InL (Definition (InR [Location uri actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath uri + assertBool "version found in a module that is not Paths_stylish_haskell" + $ ["Paths_stylish_haskell.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for version: " + ++ show wrongLocation From ac6d4b969d921176e21f0e17651148cbe590060e Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 17 Aug 2023 00:17:06 -0500 Subject: [PATCH 13/37] Add goto dependency type test --- ghcide/test/exe/Dependency.hs | 35 ++++++++++++++++++++++++++++++++--- 1 file changed, 32 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index ffa90c94de..8c9dd13e37 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -32,7 +32,8 @@ import TestUtils (testSessionWithExtraFiles, kno tests :: TestTree tests = testGroup "gotoDefinition for dependencies" - [ dependencyTest + [ dependencyTermTest + , dependencyTypeTest , transitiveDependencyTest , autogenDependencyTest ] @@ -53,8 +54,11 @@ fileDoneIndexing fpSuffix = fpSuffix `isSuffixOf` fpDirs other -> error $ "Failed to parse ghcide/reference/ready file: " <> show other -dependencyTest :: TestTree -dependencyTest = testSessionWithExtraFiles "dependency" "gotoDefinition in async" $ +-- Tests that we can go to the definition of a term in a dependency. +-- In this case, we are getting the definition of the data +-- constructor AsyncCancelled. +dependencyTermTest :: TestTree +dependencyTermTest = testSessionWithExtraFiles "dependency" "gotoDefinition term in async" $ \dir -> do doc <- openDoc (dir "Dependency" <.> "hs") "haskell" _hieFile <- fileDoneIndexing ["Control", "Concurrent", "Async.hie"] @@ -76,6 +80,31 @@ dependencyTest = testSessionWithExtraFiles "dependency" "gotoDefinition in async assertFailure $ "Wrong location for AsyncCancelled: " ++ show wrongLocation +-- Tests that we can go to the definition of a type in a dependency. +-- In this case, we are getting the definition of the type AsyncCancelled. +dependencyTypeTest :: TestTree +dependencyTypeTest = testSessionWithExtraFiles "dependency" "gotoDefinition type in async" $ + \dir -> do + doc <- openDoc (dir "Dependency" <.> "hs") "haskell" + _hieFile <- fileDoneIndexing ["Control", "Concurrent", "Async.hie"] + defs <- getDefinitions doc (Position 4 21) + let expRange = Range (Position 430 0) (Position 435 5) + case defs of + InL (Definition (InR [Location fp actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath fp + assertBool "AsyncCancelled found in a module that is not Control.Concurrent Async" + $ ["Control", "Concurrent", "Async.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for AsyncCancelled: " + ++ show wrongLocation + -- Tests that we can go to the definition of a dependency, and then -- from the dependency file we can use gotoDefinition to see a -- tranisive dependency. From 71f94c6c70898c315b3bfbb7afcb28a308f08142 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 17 Aug 2023 01:14:47 -0500 Subject: [PATCH 14/37] Add boot dependency test (failing) --- .../test/data/dependency-boot/Dependency.hs | 6 ++++ .../test/data/dependency-boot/cabal.project | 3 ++ .../dependency-boot/dependency-boot.cabal | 10 ++++++ ghcide/test/data/dependency-boot/hie.yaml | 2 ++ ghcide/test/exe/Dependency.hs | 33 +++++++++++++++++++ 5 files changed, 54 insertions(+) create mode 100644 ghcide/test/data/dependency-boot/Dependency.hs create mode 100644 ghcide/test/data/dependency-boot/cabal.project create mode 100644 ghcide/test/data/dependency-boot/dependency-boot.cabal create mode 100644 ghcide/test/data/dependency-boot/hie.yaml diff --git a/ghcide/test/data/dependency-boot/Dependency.hs b/ghcide/test/data/dependency-boot/Dependency.hs new file mode 100644 index 0000000000..c672fce14f --- /dev/null +++ b/ghcide/test/data/dependency-boot/Dependency.hs @@ -0,0 +1,6 @@ +module Dependency where + +import Data.Set (Set, empty) + +emptySet :: Set Int +emptySet = empty diff --git a/ghcide/test/data/dependency-boot/cabal.project b/ghcide/test/data/dependency-boot/cabal.project new file mode 100644 index 0000000000..5614f62977 --- /dev/null +++ b/ghcide/test/data/dependency-boot/cabal.project @@ -0,0 +1,3 @@ +packages: . +package * + ghc-options: -fwrite-ide-info diff --git a/ghcide/test/data/dependency-boot/dependency-boot.cabal b/ghcide/test/data/dependency-boot/dependency-boot.cabal new file mode 100644 index 0000000000..2ebc45a983 --- /dev/null +++ b/ghcide/test/data/dependency-boot/dependency-boot.cabal @@ -0,0 +1,10 @@ +name: dependency-boot +version: 0.1.0.0 +cabal-version: 2.0 +build-type: Simple + +library + exposed-modules: Dependency + default-language: Haskell2010 + build-depends: base + , containers diff --git a/ghcide/test/data/dependency-boot/hie.yaml b/ghcide/test/data/dependency-boot/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/ghcide/test/data/dependency-boot/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index 8c9dd13e37..cbefd22e3f 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -36,6 +36,7 @@ tests = , dependencyTypeTest , transitiveDependencyTest , autogenDependencyTest + , bootDependencyTest ] fileDoneIndexing :: [String] -> Session FilePath @@ -202,3 +203,35 @@ autogenDependencyTest = knownBrokenForGhcVersions [GHC810, GHC90] "stylish-haske liftIO $ assertFailure $ "Wrong location for version: " ++ show wrongLocation + +-- Tests that we can go to a definition in a boot library, that is, +-- one of the libraries that ships with GHC. In this case we are +-- going to a definition in containers. This does not currently work +-- for available GHC versions but hopefully will for later versions +-- of GHC. +bootDependencyTest :: TestTree +bootDependencyTest = knownBrokenForGhcVersions [GHC810, GHC90, GHC92, GHC94, GHC96] "HIE files are not generated by older GHCs" $ + testSessionWithExtraFiles "dependency-boot" "gotoDefinition term in boot library containers" $ + \dir -> do + doc <- openDoc (dir "Dependency" <.> "hs") "haskell" + _hieFile <- fileDoneIndexing ["Data", "Set", "Internal.hie"] + defs <- getDefinitions doc (Position 5 20) + -- The location of the definition of empty in Data.Set.Internal. + -- This will likely need to be updated when there is a GHC for + -- which this test can pass. + let expRange = Range (Position 513 0) (Position 513 11) + case defs of + InL (Definition (InR [Location fp actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath fp + assertBool "empty found in a module that is not Data.Set.Internal" + $ ["Data", "Set", "Internal.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for empty: " + ++ show wrongLocation From 74fd8cc01d9a2c18101c1ea9659506c67fc843d5 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 17 Aug 2023 02:55:17 -0500 Subject: [PATCH 15/37] Add dependency where clause test (failing) --- .../test/data/dependency-where/Dependency.hs | 6 +++ .../test/data/dependency-where/cabal.project | 3 ++ .../dependency-where/dependency-where.cabal | 10 ++++ ghcide/test/data/dependency-where/hie.yaml | 2 + ghcide/test/exe/Dependency.hs | 49 +++++++++++++++++++ 5 files changed, 70 insertions(+) create mode 100644 ghcide/test/data/dependency-where/Dependency.hs create mode 100644 ghcide/test/data/dependency-where/cabal.project create mode 100644 ghcide/test/data/dependency-where/dependency-where.cabal create mode 100644 ghcide/test/data/dependency-where/hie.yaml diff --git a/ghcide/test/data/dependency-where/Dependency.hs b/ghcide/test/data/dependency-where/Dependency.hs new file mode 100644 index 0000000000..29f171b7bd --- /dev/null +++ b/ghcide/test/data/dependency-where/Dependency.hs @@ -0,0 +1,6 @@ +module Dependency where + +import Data.Scientific (Scientific(base10Exponent)) + +b :: Scientific -> Int +b = base10Exponent diff --git a/ghcide/test/data/dependency-where/cabal.project b/ghcide/test/data/dependency-where/cabal.project new file mode 100644 index 0000000000..5614f62977 --- /dev/null +++ b/ghcide/test/data/dependency-where/cabal.project @@ -0,0 +1,3 @@ +packages: . +package * + ghc-options: -fwrite-ide-info diff --git a/ghcide/test/data/dependency-where/dependency-where.cabal b/ghcide/test/data/dependency-where/dependency-where.cabal new file mode 100644 index 0000000000..09adf5c74d --- /dev/null +++ b/ghcide/test/data/dependency-where/dependency-where.cabal @@ -0,0 +1,10 @@ +name: dependency +version: 0.1.0.0 +cabal-version: 2.0 +build-type: Simple + +library + exposed-modules: Dependency + default-language: Haskell2010 + build-depends: base + , scientific == 0.3.7.0 diff --git a/ghcide/test/data/dependency-where/hie.yaml b/ghcide/test/data/dependency-where/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/ghcide/test/data/dependency-where/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index cbefd22e3f..f316e5f0e3 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -25,6 +25,7 @@ import Language.LSP.Test (Session, anyMessage, import System.FilePath (splitDirectories, (<.>), ()) import Test.Tasty (TestTree, testGroup) +import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit (assertBool, assertFailure, (@?=)) import TestUtils (testSessionWithExtraFiles, knownBrokenForGhcVersions) @@ -37,6 +38,7 @@ tests = , transitiveDependencyTest , autogenDependencyTest , bootDependencyTest + , whereClauseDependencyTest ] fileDoneIndexing :: [String] -> Session FilePath @@ -235,3 +237,50 @@ bootDependencyTest = knownBrokenForGhcVersions [GHC810, GHC90, GHC92, GHC94, GHC liftIO $ assertFailure $ "Wrong location for empty: " ++ show wrongLocation + +-- Testing that we can go to a definition in a where clause in a dependency. +-- This currently fails, but it is unclear why. +whereClauseDependencyTest :: TestTree +whereClauseDependencyTest = expectFailBecause "TODO: figure out why where clauses in dependencies are not indexed" $ + testSessionWithExtraFiles "dependency-where" "goto where clause definition in dependency" $ + \dir -> do + localDoc <- openDoc (dir "Dependency" <.> "hs") "haskell" + _hieFile <- fileDoneIndexing ["Data", "Scientific.hie"] + scientificDefs <- getDefinitions localDoc (Position 5 5) + scientificFile <- case scientificDefs of + InL (Definition (InR [Location uri _actualRange])) -> + liftIO $ do + let fp :: FilePath + fp = fromMaybe "" $ uriToFilePath uri + locationDirectories :: [String] + locationDirectories = splitDirectories fp + assertBool "base10Exponent found in a module that is not Data.Scientific" + $ ["Data", "Scientific.hs"] + `isSuffixOf` locationDirectories + pure fp + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for base10Exponent: " + ++ show wrongLocation + scientificDoc <- openDoc scientificFile "haskell" + -- Where longDiv is referenced in the function body + -- of unsafeFromRational in Data.Scientific + longDivDefs <- getDefinitions scientificDoc (Position 367 33) + -- The location of the definition of longDiv in + -- the where clause of unsafeFromRational + let expRange = Range (Position 371 4) (Position 376 55) + case longDivDefs of + InL (Definition (InR [Location uri actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath uri + assertBool "longDiv found in a module that is not Data.Scientific" + $ ["Data", "Scientific.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for longDiv: " + ++ show wrongLocation From 1add24f568f86d0a80e7b88ebf133b6e75635247 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 17 Aug 2023 03:46:41 -0500 Subject: [PATCH 16/37] Add comment about cabal head in CI --- .github/actions/setup-build/action.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/actions/setup-build/action.yml b/.github/actions/setup-build/action.yml index 680c3feb2c..b58b301cea 100644 --- a/.github/actions/setup-build/action.yml +++ b/.github/actions/setup-build/action.yml @@ -7,6 +7,9 @@ inputs: cabal: description: "Cabal version" required: false + # TODO: We should change this to 3.11 or latest once version 3.11 is released. + # For now we need the functionality in cabal head that generates HIE files + # for dependencies. default: "head" os: description: "Operating system: Linux, Windows or macOS" From 0b674d081e8fe1b47857f1da4c4c1a7afe96fe9f Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 17 Aug 2023 03:47:23 -0500 Subject: [PATCH 17/37] Revert "Add new hiedb to nix config" This reverts commit d0c18d3611eb03b680cb77ee04c59eb134cbf2c8. --- configuration-ghc-90.nix | 2 -- configuration-ghc-92.nix | 2 -- configuration-ghc-94.nix | 2 -- configuration-ghc-96.nix | 2 -- flake.nix | 4 ---- 5 files changed, 12 deletions(-) diff --git a/configuration-ghc-90.nix b/configuration-ghc-90.nix index 364070625a..8152f110fa 100644 --- a/configuration-ghc-90.nix +++ b/configuration-ghc-90.nix @@ -24,8 +24,6 @@ let lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; lsp-test = hself.callCabal2nix "lsp-test" inputs.lsp-test {}; - hiedb = hself.callCabal2nix "hiedb" inputs.hiedb {}; - hlint = appendConfigureFlag (hself.callCabal2nix "hlint" inputs.hlint-35 {}) "-fghc-lib"; hls-hlint-plugin = hself.callCabal2nixWithOptions "hls-hlint-plugin" diff --git a/configuration-ghc-92.nix b/configuration-ghc-92.nix index b309017ba0..01402a6497 100644 --- a/configuration-ghc-92.nix +++ b/configuration-ghc-92.nix @@ -25,8 +25,6 @@ let ghc-lib-parser = hsuper.ghc-lib-parser_9_4_5_20230430; - hiedb = hself.callCabal2nix "hiedb" inputs.hiedb {}; - hlint = appendConfigureFlag (hself.callCabal2nix "hlint" inputs.hlint-35 {}) "-fghc-lib"; ormolu = hself.callCabal2nix "ormolu" inputs.ormolu-052 {}; diff --git a/configuration-ghc-94.nix b/configuration-ghc-94.nix index 4a1ca93e66..e561496955 100644 --- a/configuration-ghc-94.nix +++ b/configuration-ghc-94.nix @@ -23,8 +23,6 @@ let lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; lsp-test = dontCheck (hself.callCabal2nix "lsp-test" inputs.lsp-test {}); - hiedb = hself.callCabal2nix "hiedb" inputs.hiedb {}; - # Re-generate HLS drv excluding some plugins haskell-language-server = hself.callCabal2nixWithOptions "haskell-language-server" ./. diff --git a/configuration-ghc-96.nix b/configuration-ghc-96.nix index bf0f7f8581..744e7047d1 100644 --- a/configuration-ghc-96.nix +++ b/configuration-ghc-96.nix @@ -48,8 +48,6 @@ let lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; lsp-test = dontCheck (hself.callCabal2nix "lsp-test" inputs.lsp-test {}); - hiedb = hself.callCabal2nix "hiedb" inputs.hiedb {}; - # Re-generate HLS drv excluding some plugins haskell-language-server = hself.callCabal2nixWithOptions "haskell-language-server" ./. diff --git a/flake.nix b/flake.nix index 88907b1b90..b68f43c2d1 100644 --- a/flake.nix +++ b/flake.nix @@ -81,10 +81,6 @@ url = "github:smunix/implicit-hie-cradle?ref=smunix-patch-hls-0.5-1"; flake = false; }; - hiedb = { - url = "github:nlander/HieDb?ref=all-new-functions"; - flake = false; - }; }; outputs = inputs@{ self, nixpkgs, flake-compat, flake-utils, gitignore, ... }: From 5a8abcceba4af0a1ba3a57b9150a93b4c764ad13 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 17 Aug 2023 04:06:26 -0500 Subject: [PATCH 18/37] Improve comments about plugin file types --- hls-plugin-api/src/Ide/Types.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index bd488b02d8..c7319b23a4 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -286,17 +286,18 @@ data PluginDescriptor (ideState :: Type) = -- The file extension must have a leading '.'. } --- A description of the types of files that the plugin --- is intended to work on. It includes the origin of the --- file (the project, a dependency, or both), and the --- file extensions the plugin should work on. +-- | A description of the types of files that the plugin +-- is intended to work on. It includes the origin of the +-- file (the project, a dependency, or both), and the +-- file extensions the plugin should work on. data PluginFileType = PluginFileType [SourceFileOrigin] [T.Text] data SourceFileOrigin = FromProject | FromDependency deriving Eq --- Dependency files are written to the .hls/dependencies directory. --- If a file is not in this directory, we assume that it is a --- project file. +-- | Dependency files are written to the .hls/dependencies directory +-- under the project root. +-- If a file is not in this directory, we assume that it is a +-- project file. getSourceFileOrigin :: NormalizedFilePath -> SourceFileOrigin getSourceFileOrigin f = case [".hls", "dependencies"] `isInfixOf` (splitDirectories file) of From 1fea4fd180f1b7eed3521732c12c367e62085041 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 17 Aug 2023 04:09:24 -0500 Subject: [PATCH 19/37] Remove .hls directory magic strings --- ghcide/src/Development/IDE/Core/Actions.hs | 3 ++- ghcide/src/Development/IDE/Core/Dependencies.hs | 3 ++- hls-plugin-api/src/Ide/Types.hs | 10 +++++++++- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 1a1c3f5bf2..eefd066905 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -37,6 +37,7 @@ import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb +import Ide.Types (hlsDirectory, dependenciesDirectory) import Language.LSP.Protocol.Types (DocumentHighlight (..), SymbolInformation (..), normalizedFilePathToUri, @@ -116,7 +117,7 @@ lookupMod HieDbWriter{indexQueue} hieFile moduleName uid _boot = MaybeT $ do -- name and hash of the package the dependency module is -- found in. The name and hash are both parts of the UnitId. writeOutDir :: FilePath - writeOutDir = projectRoot ".hls" "dependencies" show uid + writeOutDir = projectRoot hlsDirectory dependenciesDirectory show uid -- The module name is separated into directories, with the -- last part of the module name giving the name of the -- haskell file with a .hs extension. diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs index 34fe8143dd..0cc7d092c4 100644 --- a/ghcide/src/Development/IDE/Core/Dependencies.hs +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -22,6 +22,7 @@ import HieDb (SourceFile (FakeFile), lookupPackage, removeDependencySrcFiles) import Ide.Logger (Recorder, WithPriority) +import Ide.Types (hlsDirectory) import Language.LSP.Server (resRootPath) import System.Directory (doesDirectoryExist) import System.FilePath ((<.>), ()) @@ -46,7 +47,7 @@ indexDependencyHieFiles recorder se hscEnv = do mHlsDir :: Maybe FilePath mHlsDir = do projectDir <- resRootPath =<< lspEnv se - pure $ projectDir ".hls" + pure $ projectDir hlsDirectory -- Add the deletion of dependency source files from the -- HieDb database to the database write queue. deleteMissingDependencySources :: IO () diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index c7319b23a4..ccfbb548de 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -47,6 +47,8 @@ module Ide.Types , PluginNotificationHandlers(..) , PluginRequestMethod(..) , SourceFileOrigin(..) +, dependenciesDirectory +, hlsDirectory , getSourceFileOrigin , getProcessID, getPid , installSigUsr1Handler @@ -294,13 +296,19 @@ data PluginFileType = PluginFileType [SourceFileOrigin] [T.Text] data SourceFileOrigin = FromProject | FromDependency deriving Eq +hlsDirectory :: FilePath +hlsDirectory = ".hls" + +dependenciesDirectory :: FilePath +dependenciesDirectory = "dependencies" + -- | Dependency files are written to the .hls/dependencies directory -- under the project root. -- If a file is not in this directory, we assume that it is a -- project file. getSourceFileOrigin :: NormalizedFilePath -> SourceFileOrigin getSourceFileOrigin f = - case [".hls", "dependencies"] `isInfixOf` (splitDirectories file) of + case [hlsDirectory, dependenciesDirectory] `isInfixOf` (splitDirectories file) of True -> FromDependency False -> FromProject where From f6dd2011fc9df9840bd20f35ce61d74228b01d00 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 17 Aug 2023 04:28:12 -0500 Subject: [PATCH 20/37] Run stylish-haskell --- ghcide/src/Development/IDE/Core/Actions.hs | 3 ++- ghcide/test/exe/Dependency.hs | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index eefd066905..c3d6c9d9a0 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -37,7 +37,8 @@ import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb -import Ide.Types (hlsDirectory, dependenciesDirectory) +import Ide.Types (dependenciesDirectory, + hlsDirectory) import Language.LSP.Protocol.Types (DocumentHighlight (..), SymbolInformation (..), normalizedFilePathToUri, diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index f316e5f0e3..b1516a3085 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -28,7 +28,8 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit (assertBool, assertFailure, (@?=)) -import TestUtils (testSessionWithExtraFiles, knownBrokenForGhcVersions) +import TestUtils (knownBrokenForGhcVersions, + testSessionWithExtraFiles) tests :: TestTree tests = From fbcb22e730a90c5fb0c005e15f677007e816f283 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Wed, 23 Aug 2023 05:08:01 -0500 Subject: [PATCH 21/37] Add note about how it all works --- .../src/Development/IDE/Core/Dependencies.hs | 36 +++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs index 0cc7d092c4..c7b842d0ee 100644 --- a/ghcide/src/Development/IDE/Core/Dependencies.hs +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -27,6 +27,42 @@ import Language.LSP.Server (resRootPath) import System.Directory (doesDirectoryExist) import System.FilePath ((<.>), ()) +{- Note [Going to definitions in dependencies] + - There are two main components of the functionality that enables gotoDefinition for + - third party dependencies: + - + the changes to the lookupMod function in ghcide/src/Development/IDE/Core/Actions.hs, + - which are triggered on calls to gotoDefinition. + - + the code that indexes dependencies in the hiedb, which can be found in this module. + - This gets run asynchronously, triggering every time newHscEnvEqWithImportPaths gets called. + - + - The gotoDefinition code was originally written in such a way that it was + - expecting that we would eventually be able to go to dependency definitions. + - Before the funtionality was implemented, lookupMod was a no-op stub intended to + - be where functionality would eventually go for dependencies. You can see the + - code that eventually ends up calling lookupMod in the function nameToLocation in + - ghcide/src/Development/IDE/Spans/AtPoint.hs. To summarize, gotoDefinition will look + - for a file in the project, and look in the hiedb if it can't find it. In this sense, + - the name lookupMod might be a little misleading, because by the time it gets called, + - the HIE file has already been looked up in the database and we have the FilePath + - of its location. A more appropriate name might be something like loadModule, + - since what it does is load the module source code from an HIE file and write it out to + - .hls/dependencies. The way nameToLocation works, if we have already opened a + - dependency file once, lookupMod won't get called. In addition to loading the + - dependency source and writing it out, lookupMod handles indexing the source file + - that we wrote out, which can't happen in the initial indexing since the + - source file doesn't exist at that point. To summarize, for gotoDefinition to work + - for a dependency we need to have already indexed the HIE file for that dependency module. + - + - The indexing process gets the packages and modules for dependencies from the HscEnv. + - It filters them for packages we know are direct or transitive dependencies, using the + - function calculateTransitiveDependencies. indexDependencyHieFiles attempts to load an + - HIE file for each module, checking for it in the extra-compilation-artifacts directory, + - found in the package lib directory. This fails for the packages that ship with GHC, + - because it doesn't yet generate HIE files. If it is able to load the HIE file, + - it indexes it in hiedb using indexHieFile, which is the same function used to + - index project HIE files. + -} + newtype Package = Package GHC.UnitInfo deriving Eq instance Ord Package where compare (Package u1) (Package u2) = compare (GHC.unitId u1) (GHC.unitId u2) From 34df92c9043633a37a6651fb177bbfdae3ddf9a0 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Wed, 23 Aug 2023 07:50:32 -0500 Subject: [PATCH 22/37] Fix transitive dependency test for ghc 8.10 --- ghcide/test/exe/Dependency.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index b1516a3085..871b41561d 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -11,7 +11,7 @@ import Data.Bool (bool) import Data.List (isSuffixOf) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) -import Development.IDE.GHC.Compat (GhcVersion (..)) +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Language.LSP.Protocol.Message (TCustomMessage (NotMess), TNotificationMessage (..)) import Language.LSP.Protocol.Types (Definition (..), @@ -138,7 +138,9 @@ transitiveDependencyTest = testSessionWithExtraFiles "dependency" "goto transiti hashableDefs <- getDefinitions asyncDoc (Position 246 11) -- The location of the definition of Hashable in -- Data.Hashable.Class - let expRange = Range (Position 198 14) (Position 198 22) + let expRange = if ghcVersion >= GHC90 + then Range (Position 198 14) (Position 198 22) + else Range (Position 198 0) (Position 235 31) case hashableDefs of InL (Definition (InR [Location uri actualRange])) -> liftIO $ do From d61b290186fc29aa8bc610e2727a198dd6bc79b0 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Mon, 28 Aug 2023 21:50:02 -0500 Subject: [PATCH 23/37] Fix some warnings on ghc 8.10 --- ghcide/src/Development/IDE/Core/Rules.hs | 22 ++++++++++---------- ghcide/src/Development/IDE/Core/Shake.hs | 4 +--- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 2 +- 3 files changed, 13 insertions(+), 15 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index ddcaa4dbdf..6ee0e42abe 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -929,29 +929,29 @@ checkHieFile recorder se@ShakeExtras{withHieDb} tag hieFileLocation = do -- Log that the HIE file does not exist where we expect that it should. logHieFileMissing :: IO HieFileCheck logHieFileMissing = do - let log :: Log - log = LogMissingHieFile hieFileLocation - logWith recorder Logger.Debug log + let logMissing :: Log + logMissing = LogMissingHieFile hieFileLocation + logWith recorder Logger.Debug logMissing pure HieFileMissing -- When we know that the HIE file exists, check that it has not already -- been indexed. If it hasn't, try to load it. checkExistingHieFile :: IO HieFileCheck checkExistingHieFile = do - hash <- Util.getFileHash $ fromNormalizedFilePath hieFileLocation - mrow <- withHieDb (\hieDb -> HieDb.lookupHieFileFromHash hieDb hash) + hieFileHash <- Util.getFileHash $ fromNormalizedFilePath hieFileLocation + mrow <- withHieDb (\hieDb -> HieDb.lookupHieFileFromHash hieDb hieFileHash) dbHieFileLocation <- traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow - bool (tryLoadingHieFile hash) (pure HieAlreadyIndexed) $ + bool (tryLoadingHieFile hieFileHash) (pure HieAlreadyIndexed) $ Just hieFileLocation == fmap toNormalizedFilePath' dbHieFileLocation -- Attempt to load the HIE file, logging on failure (logging happens -- in readHieFileFromDisk). If the file loads successfully, return -- the data necessary for indexing it in the HieDb database. tryLoadingHieFile :: Util.Fingerprint -> IO HieFileCheck - tryLoadingHieFile hash = do + tryLoadingHieFile hieFileHash = do ehf <- runIdeAction tag se $ runExceptT $ readHieFileFromDisk recorder hieFileLocation pure $ case ehf of Left err -> CouldNotLoadHie err - Right hf -> DoIndexing hash hf + Right hf -> DoIndexing hieFileHash hf -- | Check state of hiedb after loading an iface from disk - have we indexed the corresponding `.hie` file? -- This function is responsible for ensuring database consistency @@ -966,7 +966,7 @@ getModIfaceFromDiskAndIndexRule recorder = -- doesn't need early cutoff since all its dependencies already have it defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetModIfaceFromDiskAndIndex f -> do x <- use_ GetModIfaceFromDisk f - se@ShakeExtras{withHieDb} <- getShakeExtras + se <- getShakeExtras -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db let ms = hirModSummary x @@ -985,9 +985,9 @@ getModIfaceFromDiskAndIndexRule recorder = -- Uh oh, we failed to read the file for some reason, need to regenerate it CouldNotLoadHie err -> hieFailure $ Just err -- can just re-index the file we read from disk - DoIndexing hash hf -> liftIO $ do + DoIndexing hieFileHash hf -> liftIO $ do logWith recorder Logger.Debug $ LogReindexingHieFile f - indexHieFile se hie_loc (HieDb.RealFile $ fromNormalizedFilePath f) hash hf + indexHieFile se hie_loc (HieDb.RealFile $ fromNormalizedFilePath f) hieFileHash hf return (Just x) newtype DisplayTHWarning = DisplayTHWarning (IO()) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 557b834796..68331d0de8 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1248,9 +1248,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do -- * creating bogus "file does not exists" diagnostics | otherwise = useWithoutDependency (GetModificationTime_ False) fp isSafeDependencyRule - :: forall k v - . IdeRule k v - => k + :: k -> Bool isSafeDependencyRule _k -- The only Rules that are safe for dependencies. diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 68f7cf7f32..5fa98812eb 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -25,7 +25,7 @@ import qualified Data.Unique as Unique import Development.IDE.Core.Dependencies (indexDependencyHieFiles) import Development.IDE.Core.Rules (Log) import Development.IDE.Core.Shake (ShakeExtras) -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (newUnique) import qualified Development.IDE.GHC.Compat.Util as Maybes import Development.IDE.GHC.Error (catchSrcErrors) import Development.IDE.GHC.Util (lookupPackageConfig) From fbb3b570d767dfd8a0d66651a244ef10ec98a462 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 31 Aug 2023 05:54:07 -0500 Subject: [PATCH 24/37] Filter hlint FOIs --- ghcide/src/Development/IDE/Core/RuleTypes.hs | 11 ++----- .../src/Development/IDE/LSP/Notifications.hs | 1 + .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 1 + hls-plugin-api/hls-plugin-api.cabal | 1 + hls-plugin-api/src/Ide/Types.hs | 31 +++++++++++++++++++ .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 +- 6 files changed, 37 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 53e85ac5d1..771ceaacaa 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -12,6 +12,7 @@ -- using the "Shaker" abstraction layer for in-memory use. -- module Development.IDE.Core.RuleTypes( + FileOfInterestStatus(..), GhcSessionDeps(.., GhcSessionDeps), module Development.IDE.Core.RuleTypes ) where @@ -42,6 +43,7 @@ import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics import GHC.Serialized (Serialized) +import Ide.Types (FileOfInterestStatus (..)) import Language.LSP.Protocol.Types (Int32, NormalizedFilePath) @@ -333,15 +335,6 @@ data GetFileExists = GetFileExists instance NFData GetFileExists instance Hashable GetFileExists -data FileOfInterestStatus - = OnDisk - | ReadOnly - | Modified { firstOpen :: !Bool -- ^ was this file just opened - } - deriving (Eq, Show, Typeable, Generic) -instance Hashable FileOfInterestStatus -instance NFData FileOfInterestStatus - data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus deriving (Eq, Show, Typeable, Generic) instance Hashable IsFileOfInterestResult diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index b5e2bd76cb..17b6dd197e 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -154,6 +154,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa -- (which restart the Shake build) run after everything else pluginPriority = ghcideNotificationsPluginPriority , pluginFileType = PluginFileType [FromProject, FromDependency] defaultPluginFileExtensions + , pluginFOIStatus = ReadOnly : defaultPluginFOIStatus } ghcideNotificationsPluginPriority :: Natural diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index 63aa060d1e..1d6b65a2ca 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -56,6 +56,7 @@ descriptor plId = (defaultPluginDescriptor plId) , pluginConfigDescriptor = defaultConfigDescriptor , pluginFileType = PluginFileType [FromProject, FromDependency] defaultPluginFileExtensions + , pluginFOIStatus = ReadOnly : defaultPluginFOIStatus } -- --------------------------------------------------------------------- diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 0349340f6e..3b4788e57f 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -51,6 +51,7 @@ library , co-log-core , containers , data-default + , deepseq , dependent-map , dependent-sum >=0.7 , Diff ^>=0.4.0 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index ccfbb548de..9323215edc 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -25,6 +25,7 @@ module Ide.Types ( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor , defaultPluginPriority, defaultPluginFileExtensions +, defaultPluginFOIStatus , IdeCommand(..) , IdeMethod(..) , IdeNotification(..) @@ -34,6 +35,7 @@ module Ide.Types , ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin, pluginEnabledConfig , CustomConfig(..), mkCustomConfig , FallbackCodeActionParams(..) +, FileOfInterestStatus(..) , FormattingType(..), FormattingMethod, FormattingHandler, mkFormattingHandlers , HasTracing(..) , PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId @@ -55,6 +57,7 @@ module Ide.Types , lookupCommandProvider , ResolveFunction , mkResolveHandler +, filterResponsibleFOI ) where @@ -71,6 +74,7 @@ import System.Posix.Signals import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) +import Control.DeepSeq (NFData) import Control.Lens (_Just, (.~), (?~), (^.), (^?)) import Control.Monad (void) import Control.Monad.Error.Class (MonadError (throwError)) @@ -96,6 +100,7 @@ import Data.Semigroup import Data.String import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (Typeable) import Development.IDE.Graph import GHC (DynFlags) import GHC.Generics @@ -286,6 +291,11 @@ data PluginDescriptor (ideState :: Type) = -- The plugin is only allowed to handle files with these extensions. -- When writing handlers, etc. for this plugin it can be assumed that all handled files are of this type. -- The file extension must have a leading '.'. + , pluginFOIStatus :: [FileOfInterestStatus] + -- ^ For plugins that have rules that run on files of interest, + -- we specify which FileOfInterestStatus are relevant for the + -- plugin. By default, ReadOnly files of interest are + -- excluded. } -- | A description of the types of files that the plugin @@ -335,6 +345,22 @@ pluginResponsible uri pluginDesc mfp :: Maybe NormalizedFilePath mfp = uriToNormalizedFilePath $ toNormalizedUri uri +data FileOfInterestStatus + = OnDisk + | ReadOnly + | Modified { firstOpen :: !Bool -- ^ was this file just opened + } + deriving (Eq, Show, Typeable, Generic) +instance Hashable FileOfInterestStatus +instance NFData FileOfInterestStatus + +filterResponsibleFOI + :: PluginDescriptor c + -> HashMap NormalizedFilePath FileOfInterestStatus + -> HashMap NormalizedFilePath FileOfInterestStatus +filterResponsibleFOI pluginDesc = + HashMap.filter (\foiStatus -> foiStatus `elem` pluginFOIStatus pluginDesc) + -- | An existential wrapper of 'Properties' data CustomConfig = forall r. CustomConfig (Properties r) @@ -905,10 +931,14 @@ defaultPluginDescriptor plId = mempty Nothing (PluginFileType [FromProject] defaultPluginFileExtensions) + defaultPluginFOIStatus defaultPluginFileExtensions :: [T.Text] defaultPluginFileExtensions = [".hs", ".lhs", ".hs-boot"] +defaultPluginFOIStatus :: [FileOfInterestStatus] +defaultPluginFOIStatus = [OnDisk, Modified True, Modified False] + -- | Set up a plugin descriptor, initialized with default values. -- This plugin descriptor is prepared for @.cabal@ files and as such, -- will only respond / run when @.cabal@ files are currently in scope. @@ -928,6 +958,7 @@ defaultCabalPluginDescriptor plId = mempty Nothing (PluginFileType [FromProject] [".cabal"]) + defaultPluginFOIStatus newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 2c02c6c6e0..590e28a541 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -234,7 +234,7 @@ rules recorder plugin = do liftIO $ argsSettings flags action $ do - files <- getFilesOfInterestUntracked + files <- filterResponsibleFOI (descriptor recorder plugin) <$> getFilesOfInterestUntracked void $ uses GetHlintDiagnostics $ Map.keys files where From ec223758508b6d15fc234030526b173451edb681 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 31 Aug 2023 07:51:54 -0500 Subject: [PATCH 25/37] Revert "Fix older ghc builds" This reverts commit 5d111f62d239be3a211e08737191557ae9c670d7. --- cabal.project | 2 +- .../src/Development/IDE/Core/Dependencies.hs | 25 +++++++++++-------- .../src/Development/IDE/GHC/Compat/Units.hs | 24 ------------------ 3 files changed, 15 insertions(+), 36 deletions(-) diff --git a/cabal.project b/cabal.project index 12ecf8a4fb..2c383287da 100644 --- a/cabal.project +++ b/cabal.project @@ -37,7 +37,7 @@ packages: source-repository-package type:git location: https://github.com/nlander/HieDb.git - tag: 4eebfcf8fab54f24808e6301227d77ae64d2509c + tag: f10051a6dc1b809d5f40a45beab92205d1829736 -- Standard location for temporary packages needed for particular environments -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs index c7b842d0ee..9d3aa54889 100644 --- a/ghcide/src/Development/IDE/Core/Dependencies.hs +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -105,7 +105,7 @@ indexDependencyHieFiles recorder se hscEnv = do hieDir :: FilePath hieDir = pkgLibDir "extra-compilation-artifacts" unit :: GHC.Unit - unit = GHC.fromUnitId $ GHC.unitId package + unit = GHC.RealUnit $ GHC.Definite $ GHC.unitId package -- Check if we have already indexed this package. moduleRows <- withHieDb se $ \db -> lookupPackage db unit @@ -141,14 +141,16 @@ indexDependencyHieFiles recorder se hscEnv = do packages :: Set Package packages = Set.fromList $ map Package - -- Take only the packages that are direct or transitive dependencies. - $ filter (\unitInfo -> GHC.unitId unitInfo `Set.member` dependencyIds) allPackages + $ Map.elems + -- Take only the packages in the unitInfoMap that are direct + -- or transitive dependencies. + $ Map.filterWithKey (\uid _ -> uid `Set.member` dependencyIds) unitInfoMap where - allPackages :: [GHC.UnitInfo] - allPackages = GHC.getUnitInfo hscEnv + unitInfoMap :: GHC.UnitInfoMap + unitInfoMap = GHC.getUnitInfoMap hscEnv dependencyIds :: Set GHC.UnitId dependencyIds = - calculateTransitiveDependencies allPackages directDependencyIds directDependencyIds + calculateTransitiveDependencies unitInfoMap directDependencyIds directDependencyIds directDependencyIds :: Set GHC.UnitId directDependencyIds = Set.fromList $ map GHC.toUnitId @@ -157,14 +159,14 @@ indexDependencyHieFiles recorder se hscEnv = do -- calculateTransitiveDependencies finds the UnitId keys in the UnitInfoMap -- that are dependencies or transitive dependencies. -calculateTransitiveDependencies :: [GHC.UnitInfo] -> Set GHC.UnitId -> Set GHC.UnitId -> Set GHC.UnitId -calculateTransitiveDependencies allPackages allDependencies newDepencencies - -- If there are no new dependencies, then we have found them all, +calculateTransitiveDependencies :: GHC.UnitInfoMap -> Set GHC.UnitId -> Set GHC.UnitId -> Set GHC.UnitId +calculateTransitiveDependencies unitInfoMap allDependencies newDepencencies + -- If there are no new dependencies, we have found them all, -- so return allDependencies | Set.null newDepencencies = allDependencies -- Otherwise recursively add any dependencies of the newDepencencies -- that are not in allDependencies already. - | otherwise = calculateTransitiveDependencies allPackages nextAll nextNew + | otherwise = calculateTransitiveDependencies unitInfoMap nextAll nextNew where nextAll :: Set GHC.UnitId nextAll = Set.union allDependencies nextNew @@ -175,7 +177,8 @@ calculateTransitiveDependencies allPackages allDependencies newDepencencies nextNew = flip Set.difference allDependencies $ Set.unions $ map (Set.fromList . GHC.unitDepends) - $ filter (\unitInfo -> GHC.unitId unitInfo `Set.member` newDepencencies) allPackages + $ Map.elems + $ Map.filterWithKey (\uid _ -> uid `Set.member` newDepencencies) unitInfoMap getModulesForPackage :: Package -> [GHC.Module] getModulesForPackage (Package package) = diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index 9d741e8615..68c8d4caa9 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Units.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs @@ -19,7 +19,6 @@ module Development.IDE.GHC.Compat.Units ( -- * UnitInfoMap UnitInfoMap, getUnitInfoMap, - getUnitInfo, lookupUnit, lookupUnit', -- * UnitInfo @@ -43,7 +42,6 @@ module Development.IDE.GHC.Compat.Units ( installedModule, -- * Module toUnitId, - fromUnitId, Development.IDE.GHC.Compat.Units.moduleUnitId, moduleUnit, -- * ExternalPackageState @@ -215,16 +213,6 @@ getUnitInfoMap = unitInfoMap . unitState #endif -getUnitInfo :: HscEnv -> [UnitInfo] -getUnitInfo = -#if MIN_VERSION_ghc(9,2,0) - State.listUnitInfo . ue_units . hsc_unit_env -#elif MIN_VERSION_ghc(9,0,0) - State.listUnitInfo . unitState -#else - Packages.listPackageConfigMap . hsc_dflags -#endif - lookupUnit :: HscEnv -> Unit -> Maybe UnitInfo lookupUnit env pid = State.lookupUnit (unitState env) pid @@ -232,11 +220,7 @@ preloadClosureUs :: HscEnv -> PreloadUnitClosure preloadClosureUs = State.preloadClosure . unitState unitHiddenModules :: UnitInfo -> [ModuleName] -#if MIN_VERSION_ghc(9,0,0) unitHiddenModules = UnitInfo.unitHiddenModules -#else -unitHiddenModules = Packages.hiddenModules -#endif unitLibraryDirs :: UnitInfo -> [FilePath] unitLibraryDirs = @@ -277,14 +261,6 @@ installedModule = Module #endif -fromUnitId :: UnitId -> Unit -fromUnitId = -#if MIN_VERSION_ghc(9,0,0) - RealUnit . Definite -#else - id -#endif - moduleUnitId :: Module -> UnitId moduleUnitId = Unit.toUnitId . Unit.moduleUnit From 666afb1bea83618a78417316b91f3c716cd41741 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 31 Aug 2023 07:53:16 -0500 Subject: [PATCH 26/37] Revert "Fix transitive dependency test for ghc 8.10" This reverts commit ad7254dc28988a32c74c1263237afc322ffa070e. --- ghcide/test/exe/Dependency.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index 871b41561d..b1516a3085 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -11,7 +11,7 @@ import Data.Bool (bool) import Data.List (isSuffixOf) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) -import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Compat (GhcVersion (..)) import Language.LSP.Protocol.Message (TCustomMessage (NotMess), TNotificationMessage (..)) import Language.LSP.Protocol.Types (Definition (..), @@ -138,9 +138,7 @@ transitiveDependencyTest = testSessionWithExtraFiles "dependency" "goto transiti hashableDefs <- getDefinitions asyncDoc (Position 246 11) -- The location of the definition of Hashable in -- Data.Hashable.Class - let expRange = if ghcVersion >= GHC90 - then Range (Position 198 14) (Position 198 22) - else Range (Position 198 0) (Position 235 31) + let expRange = Range (Position 198 14) (Position 198 22) case hashableDefs of InL (Definition (InR [Location uri actualRange])) -> liftIO $ do From 34f2307cf960b5f50dcfd90add489ca8c7b0798b Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 31 Aug 2023 08:04:13 -0500 Subject: [PATCH 27/37] Remove dependency on hiedb fork --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 2c383287da..351bbe3b28 100644 --- a/cabal.project +++ b/cabal.project @@ -36,8 +36,8 @@ packages: source-repository-package type:git - location: https://github.com/nlander/HieDb.git - tag: f10051a6dc1b809d5f40a45beab92205d1829736 + location: https://github.com/wz1000/HieDb.git + tag: 7bd029804a91c795d9dc29dd98df00905f486df7 -- Standard location for temporary packages needed for particular environments -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script From c23139d902ae6f58cdebd9db3206f6b06fd39f1b Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Thu, 31 Aug 2023 08:59:56 -0500 Subject: [PATCH 28/37] Fix pedantic build --- ghcide/src/Development/IDE/Core/Actions.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index c3d6c9d9a0..a61afb7364 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -14,7 +14,6 @@ import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue (unGetTQueue) -import Control.Monad (unless) import Control.Monad.Extra (mapMaybeM) import Control.Monad.Reader import Control.Monad.Trans.Maybe @@ -89,7 +88,7 @@ lookupMod HieDbWriter{indexQueue} hieFile moduleName uid _boot = MaybeT $ do writeAndIndexSource projectRoot completionToken = do fileExists <- liftIO $ doesFileExist writeOutPath -- No need to write out the file if it already exists. - unless fileExists $ do + if fileExists then pure () else do nc <- asks ideNc liftIO $ do -- Create the directory where we will put the source. From 9902ab7ea5ee775d31603940f6fd21d579cd958d Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Fri, 8 Sep 2023 04:46:48 -0500 Subject: [PATCH 29/37] Use minimal package for autogen dependency test --- .../data/dependency-autogen/Dependency.hs | 7 +-- .../data/dependency-autogen/cabal.project | 4 ++ .../dependency-autogen.cabal | 2 +- ghcide/test/exe/Dependency.hs | 44 +++++-------------- 4 files changed, 20 insertions(+), 37 deletions(-) diff --git a/ghcide/test/data/dependency-autogen/Dependency.hs b/ghcide/test/data/dependency-autogen/Dependency.hs index 0a9a2e7f60..0af82a4051 100644 --- a/ghcide/test/data/dependency-autogen/Dependency.hs +++ b/ghcide/test/data/dependency-autogen/Dependency.hs @@ -1,6 +1,7 @@ module Dependency where -import Language.Haskell.Stylish (Step, tabs) +import Data.Version (Version) +import Paths_minimal_autogen (version) -t :: Int -> Step -t = tabs +v :: Version +v = version diff --git a/ghcide/test/data/dependency-autogen/cabal.project b/ghcide/test/data/dependency-autogen/cabal.project index 5614f62977..a45001ac4a 100644 --- a/ghcide/test/data/dependency-autogen/cabal.project +++ b/ghcide/test/data/dependency-autogen/cabal.project @@ -1,3 +1,7 @@ packages: . package * ghc-options: -fwrite-ide-info +source-repository-package + type:git + location: https://github.com/nlander/minimal-autogen.git + tag: 1c6a440fa213185a34ebd5a0b1870e5e73f03c10 diff --git a/ghcide/test/data/dependency-autogen/dependency-autogen.cabal b/ghcide/test/data/dependency-autogen/dependency-autogen.cabal index 4e50c77da4..b333cff716 100644 --- a/ghcide/test/data/dependency-autogen/dependency-autogen.cabal +++ b/ghcide/test/data/dependency-autogen/dependency-autogen.cabal @@ -7,4 +7,4 @@ library exposed-modules: Dependency default-language: Haskell2010 build-depends: base - , stylish-haskell == 0.14.5.0 + , minimal-autogen diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index b1516a3085..e77e2facd2 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -156,50 +156,28 @@ transitiveDependencyTest = testSessionWithExtraFiles "dependency" "goto transiti ++ show wrongLocation -- Testing that we can go to a definition in an autogen module of a --- dependency. Stylish haskell is a package that has an autogen module, --- but it doesn't seem to build with ghc 9.0 or earlier. Suggestions on --- another package we could use for this test are welcome! This test --- doesn't go directly to the fuction in the autogen module because --- it is a hidden module, so we can't import that function directly --- in our project. However, hidden modules are also indexed, so we --- can go to a definition in a module that imports the autogen module --- and goto the autogen module from there. +-- dependency. We use the repository https://github.com/nlander/minimal-autogen.git +-- as the dependency. It is a minimal package with an autogen module, +-- allowing us to avoid building a larger dependency in CI just for +-- this test. autogenDependencyTest :: TestTree -autogenDependencyTest = knownBrokenForGhcVersions [GHC810, GHC90] "stylish-haskell does not build with older GHC versions" $ - testSessionWithExtraFiles "dependency-autogen" "goto autogen module in dependency" $ +autogenDependencyTest = testSessionWithExtraFiles "dependency-autogen" "goto autogen module in dependency" $ \dir -> do localDoc <- openDoc (dir "Dependency" <.> "hs") "haskell" - _hieFile <- fileDoneIndexing ["Paths_stylish_haskell.hie"] - stylishDefs <- getDefinitions localDoc (Position 5 5) - stylishFile <- case stylishDefs of - InL (Definition (InR [Location uri _actualRange])) -> - liftIO $ do - let fp :: FilePath - fp = fromMaybe "" $ uriToFilePath uri - locationDirectories :: [String] - locationDirectories = splitDirectories fp - assertBool "tags found in a module that is not Language.Haskell.Stylish" - $ ["Language", "Haskell", "Stylish.hs"] - `isSuffixOf` locationDirectories - pure fp - wrongLocation -> - liftIO $ - assertFailure $ "Wrong location for AsyncCancelled: " - ++ show wrongLocation - stylishDoc <- openDoc stylishFile "haskell" - pathsDefs <- getDefinitions stylishDoc (Position 19 8) + _hieFile <- fileDoneIndexing ["Paths_minimal_autogen.hie"] + defs <- getDefinitions localDoc (Position 6 5) -- The location of the definition of version in - -- Paths_stylish_haskell + -- Paths_minimal_autogen let expRange = Range (Position 35 0) (Position 35 7) - case pathsDefs of + case defs of InL (Definition (InR [Location uri actualRange])) -> liftIO $ do let locationDirectories :: [String] locationDirectories = maybe [] splitDirectories $ uriToFilePath uri - assertBool "version found in a module that is not Paths_stylish_haskell" - $ ["Paths_stylish_haskell.hs"] + assertBool "version found in a module that is not Paths_minimal_autogen" + $ ["Paths_minimal_autogen.hs"] `isSuffixOf` locationDirectories actualRange @?= expRange wrongLocation -> From b1f0af362ba036fd383735ab6a2db9ebb508fad9 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Tue, 19 Sep 2023 16:25:15 -0500 Subject: [PATCH 30/37] Remove redundant $ --- ghcide/src/Development/IDE/Core/Actions.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index a61afb7364..845bc662bc 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -72,7 +72,7 @@ lookupMod HieDbWriter{indexQueue} hieFile moduleName uid _boot = MaybeT $ do Just projectRoot -> do -- Database writes happen asynchronously. We use an MVar to mark -- completion of the database update. - completionToken <- liftIO $ newEmptyMVar + completionToken <- liftIO newEmptyMVar -- Write out the contents of the dependency source to the -- .hls/dependencies directory, generate a URI for that -- location, and update the HieDb database with the source @@ -111,7 +111,7 @@ lookupMod HieDbWriter{indexQueue} hieFile moduleName uid _boot = MaybeT $ do HieDb.addSrcFile db hieFile writeOutPath False -- Mark completion of the database update. putMVar completionToken () - pure $ moduleUri + pure moduleUri where -- The source will be written out in a directory from the -- name and hash of the package the dependency module is From 2329109e360b5a8aae91dc2d4e9ab8f7ea4a227f Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Tue, 19 Sep 2023 16:42:13 -0500 Subject: [PATCH 31/37] Expand hover comment --- ghcide/src/Development/IDE/Core/Actions.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 845bc662bc..97ec5716c5 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -146,7 +146,10 @@ getAtPoint file pos = runMaybeT $ do (hf, mapping) <- useWithStaleFastMT GetHieAst file -- The HscEnv and DKMap are not strictly necessary for hover -- to work, so we only calculate them for project files, not - -- for dependency files. + -- for dependency files. They provide information that will + -- not be displayed in dependency files. See the atPoint + -- function in ghcide/src/Development/IDE/Spans/AtPoint.hs + -- for the specifics of how they are used. (mEnv, mDkMap) <- case getSourceFileOrigin file of FromDependency -> pure (Nothing, Nothing) FromProject -> do From 192446b26b68c440169829638624296335edf2a8 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Tue, 19 Sep 2023 16:51:00 -0500 Subject: [PATCH 32/37] Add comment for Package newtype --- ghcide/src/Development/IDE/Core/Dependencies.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs index 9d3aa54889..febd9bbceb 100644 --- a/ghcide/src/Development/IDE/Core/Dependencies.hs +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -63,6 +63,11 @@ import System.FilePath ((<.>), ()) - index project HIE files. -} +-- | We make this newtype only so that we can have an Ord +-- instance. This gives us the convenience of being able +-- to use a Package as the key in the Map packagesWithModules, +-- and process the packages and their modules using the +-- Map.traverseWithKey function. newtype Package = Package GHC.UnitInfo deriving Eq instance Ord Package where compare (Package u1) (Package u2) = compare (GHC.unitId u1) (GHC.unitId u2) From 60264bcc213bf75c4f13c4a2bbb61feea7756faa Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Tue, 19 Sep 2023 17:16:10 -0500 Subject: [PATCH 33/37] Move makeHieAstResult function to RuleTypes --- ghcide/src/Development/IDE/Core/RuleTypes.hs | 13 +++++++++++++ ghcide/src/Development/IDE/Core/Rules.hs | 12 ------------ 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 771ceaacaa..902e9ed77b 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -217,6 +217,19 @@ data HieAstResult -- ^ Is this hie file loaded from the disk, or freshly computed? } +-- | Make an HieAstResult from a loaded HieFile +makeHieAstResult :: HieFile -> HieAstResult +makeHieAstResult hieFile = + HAR + (hie_module hieFile) + hieAsts + (generateReferencesMap $ M.elems $ getAsts hieAsts) + mempty + (HieFromDisk hieFile) + where + hieAsts :: HieASTs TypeIndex + hieAsts = hie_asts hieFile + data HieKind a where HieFromDisk :: !HieFile -> HieKind TypeIndex HieFresh :: HieKind Type diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 6ee0e42abe..e584ae562b 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -589,18 +589,6 @@ getHieAstsRule recorder = tmr <- use_ TypeCheck f hsc <- hscEnv <$> use_ GhcSessionDeps f getHieAstRuleDefinition f hsc tmr - where - makeHieAstResult :: Compat.HieFile -> HieAstResult - makeHieAstResult hieFile = - HAR - (Compat.hie_module hieFile) - hieAsts - (Compat.generateReferencesMap $ M.elems $ getAsts hieAsts) - mempty - (HieFromDisk hieFile) - where - hieAsts :: HieASTs TypeIndex - hieAsts = Compat.hie_asts hieFile persistentHieFileRule :: Recorder (WithPriority Log) -> Rules () persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do From 092b5d7432ea0a121cac2a267f60c33ae337cd3d Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Fri, 22 Sep 2023 11:40:13 -0500 Subject: [PATCH 34/37] Add missing haddock to toplevel comments --- ghcide/src/Development/IDE/Core/Dependencies.hs | 4 ++-- ghcide/src/Development/IDE/Core/Rules.hs | 4 ++-- ghcide/test/exe/Dependency.hs | 12 ++++++------ 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs index febd9bbceb..9fc9db8fbe 100644 --- a/ghcide/src/Development/IDE/Core/Dependencies.hs +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -72,7 +72,7 @@ newtype Package = Package GHC.UnitInfo deriving Eq instance Ord Package where compare (Package u1) (Package u2) = compare (GHC.unitId u1) (GHC.unitId u2) --- indexDependencyHieFiles gets all of the direct and transitive dependencies +-- | indexDependencyHieFiles gets all of the direct and transitive dependencies -- from the HscEnv and indexes their HIE files in the HieDb. indexDependencyHieFiles :: Recorder (WithPriority Log) -> ShakeExtras -> GHC.HscEnv -> IO () indexDependencyHieFiles recorder se hscEnv = do @@ -162,7 +162,7 @@ indexDependencyHieFiles recorder se hscEnv = do $ GHC.explicitUnits $ GHC.unitState hscEnv --- calculateTransitiveDependencies finds the UnitId keys in the UnitInfoMap +-- | calculateTransitiveDependencies finds the UnitId keys in the UnitInfoMap -- that are dependencies or transitive dependencies. calculateTransitiveDependencies :: GHC.UnitInfoMap -> Set GHC.UnitId -> Set GHC.UnitId -> Set GHC.UnitId calculateTransitiveDependencies unitInfoMap allDependencies newDepencencies diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index e584ae562b..7a89ab3c26 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -891,7 +891,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco let !fp = Just $! hiFileFingerPrint x return (fp, (diags, Just x)) --- The result of checkHieFile, which returns a reason why an +-- | The result of checkHieFile, which returns a reason why an -- HIE file should not be indexed, or the data necessary for -- indexing in the HieDb database. data HieFileCheck @@ -900,7 +900,7 @@ data HieFileCheck | CouldNotLoadHie SomeException | DoIndexing Util.Fingerprint HieFile --- checkHieFile verifies that an HIE file exists, that it has not already +-- | checkHieFile verifies that an HIE file exists, that it has not already -- been indexed, and attempts to load it. This is intended to happen before -- any indexing of HIE files in the HieDb database. In addition to returning -- a HieFileCheck, this function also handles logging. diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index e77e2facd2..0afc68db53 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -58,7 +58,7 @@ fileDoneIndexing fpSuffix = fpSuffix `isSuffixOf` fpDirs other -> error $ "Failed to parse ghcide/reference/ready file: " <> show other --- Tests that we can go to the definition of a term in a dependency. +-- | Tests that we can go to the definition of a term in a dependency. -- In this case, we are getting the definition of the data -- constructor AsyncCancelled. dependencyTermTest :: TestTree @@ -84,7 +84,7 @@ dependencyTermTest = testSessionWithExtraFiles "dependency" "gotoDefinition term assertFailure $ "Wrong location for AsyncCancelled: " ++ show wrongLocation --- Tests that we can go to the definition of a type in a dependency. +-- | Tests that we can go to the definition of a type in a dependency. -- In this case, we are getting the definition of the type AsyncCancelled. dependencyTypeTest :: TestTree dependencyTypeTest = testSessionWithExtraFiles "dependency" "gotoDefinition type in async" $ @@ -109,7 +109,7 @@ dependencyTypeTest = testSessionWithExtraFiles "dependency" "gotoDefinition type assertFailure $ "Wrong location for AsyncCancelled: " ++ show wrongLocation --- Tests that we can go to the definition of a dependency, and then +-- | Tests that we can go to the definition of a dependency, and then -- from the dependency file we can use gotoDefinition to see a -- tranisive dependency. transitiveDependencyTest :: TestTree @@ -155,7 +155,7 @@ transitiveDependencyTest = testSessionWithExtraFiles "dependency" "goto transiti assertFailure $ "Wrong location for Hashable: " ++ show wrongLocation --- Testing that we can go to a definition in an autogen module of a +-- | Testing that we can go to a definition in an autogen module of a -- dependency. We use the repository https://github.com/nlander/minimal-autogen.git -- as the dependency. It is a minimal package with an autogen module, -- allowing us to avoid building a larger dependency in CI just for @@ -185,7 +185,7 @@ autogenDependencyTest = testSessionWithExtraFiles "dependency-autogen" "goto aut assertFailure $ "Wrong location for version: " ++ show wrongLocation --- Tests that we can go to a definition in a boot library, that is, +-- | Tests that we can go to a definition in a boot library, that is, -- one of the libraries that ships with GHC. In this case we are -- going to a definition in containers. This does not currently work -- for available GHC versions but hopefully will for later versions @@ -217,7 +217,7 @@ bootDependencyTest = knownBrokenForGhcVersions [GHC810, GHC90, GHC92, GHC94, GHC assertFailure $ "Wrong location for empty: " ++ show wrongLocation --- Testing that we can go to a definition in a where clause in a dependency. +-- | Testing that we can go to a definition in a where clause in a dependency. -- This currently fails, but it is unclear why. whereClauseDependencyTest :: TestTree whereClauseDependencyTest = expectFailBecause "TODO: figure out why where clauses in dependencies are not indexed" $ From 004568f8020283de324cc114469641ebd7863ca7 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Mon, 25 Sep 2023 17:27:53 -0500 Subject: [PATCH 35/37] Look for hie files in hie directory --- ghcide/src/Development/IDE/Core/Dependencies.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs index 9fc9db8fbe..59c16472e9 100644 --- a/ghcide/src/Development/IDE/Core/Dependencies.hs +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -108,7 +108,7 @@ indexDependencyHieFiles recorder se hscEnv = do -- extra-compilation-artifacts directory, provided -- it is compiled with the -fwrite-ide-info ghc option. hieDir :: FilePath - hieDir = pkgLibDir "extra-compilation-artifacts" + hieDir = pkgLibDir "extra-compilation-artifacts" "hie" unit :: GHC.Unit unit = GHC.RealUnit $ GHC.Definite $ GHC.unitId package -- Check if we have already indexed this package. From 9b90f0a59ac6bf61f64c249276a3fbab12373d02 Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Wed, 4 Oct 2023 18:04:48 -0500 Subject: [PATCH 36/37] Add test of no diagnostics --- ghcide/test/exe/Dependency.hs | 39 ++++++++++++++++++++++++++++++++--- 1 file changed, 36 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/Dependency.hs b/ghcide/test/exe/Dependency.hs index 0afc68db53..9fb0303fb3 100644 --- a/ghcide/test/exe/Dependency.hs +++ b/ghcide/test/exe/Dependency.hs @@ -5,23 +5,33 @@ module Dependency where import qualified Control.Applicative as Applicative import Control.Applicative.Combinators (skipManyTill) +import Control.Lens (preview, (^.)) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import Data.Bool (bool) import Data.List (isSuffixOf) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) +import Data.Text (isPrefixOf) import Development.IDE.GHC.Compat (GhcVersion (..)) -import Language.LSP.Protocol.Message (TCustomMessage (NotMess), +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (FromServerMessage' (FromServerMess), + SMethod (SMethod_Progress, SMethod_TextDocumentPublishDiagnostics), + TCustomMessage (NotMess), TNotificationMessage (..)) -import Language.LSP.Protocol.Types (Definition (..), +import Language.LSP.Protocol.Types (Definition (..), Diagnostic, Location (..), Position (..), + ProgressParams (..), Range (..), + WorkDoneProgressEnd (..), + _workDoneProgressEnd, type (|?) (InL, InR), uriToFilePath) import Language.LSP.Test (Session, anyMessage, customNotification, - getDefinitions, openDoc) + getDefinitions, message, + openDoc, satisfyMaybe, + waitForDiagnostics) import System.FilePath (splitDirectories, (<.>), ()) import Test.Tasty (TestTree, testGroup) @@ -58,6 +68,27 @@ fileDoneIndexing fpSuffix = fpSuffix `isSuffixOf` fpDirs other -> error $ "Failed to parse ghcide/reference/ready file: " <> show other +waitForDiagnosticsOrDoneIndexing :: Session [Diagnostic] +waitForDiagnosticsOrDoneIndexing = + skipManyTill anyMessage (diagnosticsMessage Applicative.<|> doneIndexing) + where + diagnosticsMessage :: Session [Diagnostic] + diagnosticsMessage = do + diagnosticsNotification <- message SMethod_TextDocumentPublishDiagnostics + let diagnosticss = diagnosticsNotification ^. L.params . L.diagnostics + return diagnosticss + doneIndexing :: Session [Diagnostic] + doneIndexing = satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams t (preview _workDoneProgressEnd -> Just params))) -> + case params of + (WorkDoneProgressEnd _ m) -> + case m of + Just message -> bool Nothing (Just []) $ + "Finished indexing" `isPrefixOf` message + _ -> Nothing + _ -> Nothing + _ -> Nothing + -- | Tests that we can go to the definition of a term in a dependency. -- In this case, we are getting the definition of the data -- constructor AsyncCancelled. @@ -68,6 +99,7 @@ dependencyTermTest = testSessionWithExtraFiles "dependency" "gotoDefinition term _hieFile <- fileDoneIndexing ["Control", "Concurrent", "Async.hie"] defs <- getDefinitions doc (Position 5 20) let expRange = Range (Position 430 22) (Position 430 36) + diagnostics <- waitForDiagnosticsOrDoneIndexing case defs of InL (Definition (InR [Location fp actualRange])) -> liftIO $ do @@ -78,6 +110,7 @@ dependencyTermTest = testSessionWithExtraFiles "dependency" "gotoDefinition term assertBool "AsyncCancelled found in a module that is not Control.Concurrent Async" $ ["Control", "Concurrent", "Async.hs"] `isSuffixOf` locationDirectories + diagnostics @?= [] actualRange @?= expRange wrongLocation -> liftIO $ From e9ea310b6f512f09ddf3d548dd16047c39b137cb Mon Sep 17 00:00:00 2001 From: Elodie Lander Date: Tue, 10 Oct 2023 10:13:04 -0500 Subject: [PATCH 37/37] Change error to log --- ghcide/src/Development/IDE/Core/Shake.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 68331d0de8..5c5c7bdc95 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1164,7 +1164,7 @@ defineEarlyCutoff' -> (Value v -> Action (Maybe BS.ByteString, IdeResult v)) -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do - ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras + ShakeExtras{state, progress, dirtyKeys, logger} <- getShakeExtras options <- getIdeOptions (if optSkipProgress options key then id else inProgress progress file) $ do val <- case mbOld of @@ -1203,10 +1203,12 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do -- Rule that is not on the whitelist defined by -- isSafeDependencyRule should be disabled for dependency -- files. If one is found, it should be changed. - else error $ - "defineEarlyCutoff': Undefined action for dependency source files\n" - ++ show file ++ "\n" - ++ show key + else do + liftIO $ logError logger $ T.pack $ + "defineEarlyCutoff': Undefined action for dependency source files\n" + ++ show file ++ "\n" + ++ show key + doAction ver <- estimateFileVersionUnsafely key mbRes file (bs, res) <- case mbRes of Nothing -> do