diff --git a/cabal.project b/cabal.project index 2dc12eb573..65753a4e2d 100644 --- a/cabal.project +++ b/cabal.project @@ -38,6 +38,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 9ba17e756a..045ca7b512 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -68,7 +68,7 @@ library hls-plugin-api == 2.1.0.0, lens, list-t, - hiedb == 0.4.3.*, + hiedb, lsp-types ^>= 2.0.0.1, lsp ^>= 2.0.0.0 , mtl, @@ -150,6 +150,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 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index cfc9796c33..40831564e7 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -48,6 +48,7 @@ import qualified Data.Text as T import Data.Time.Clock import Data.Version import Development.IDE.Core.RuleTypes +import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.Shake hiding (Log, Priority, withHieDb) import qualified Development.IDE.GHC.Compat as Compat @@ -127,6 +128,7 @@ data Log | LogNoneCradleFound FilePath | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log + | LogRules Rules.Log deriving instance Show Log instance Pretty Log where @@ -197,6 +199,7 @@ instance Pretty Log where LogNewComponentCache componentCache -> "New component cache HscEnvEq:" <+> viaShow componentCache LogHieBios log -> pretty log + LogRules log -> pretty log -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -585,7 +588,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 @@ -793,6 +796,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 @@ -800,7 +804,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) @@ -823,7 +827,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/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index c8e384c1b5..1b232a4070 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -13,12 +13,20 @@ 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.PositionMapping import Development.IDE.Core.RuleTypes @@ -31,11 +39,21 @@ import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb import Language.LSP.Protocol.Types (DocumentHighlight (..), - SymbolInformation (..)) - - --- | Eventually this will lookup/generate URIs for files in dependencies, but not in the --- project. Right now, this is just a stub. + SymbolInformation (..), + normalizedFilePathToUri, + uriToNormalizedFilePath) +import Language.LSP.Server (resRootPath) +import System.Directory (createDirectoryIfMissing, + doesFileExist, + getPermissions, + setOwnerExecutable, + setOwnerWritable, + setPermissions) +import System.FilePath ((), (<.>), takeDirectory) + + +-- | Generates URIs for files in dependencies, but not in the +-- project. lookupMod :: HieDbWriter -- ^ access the database -> FilePath -- ^ The `.hie` file we got from the database @@ -43,7 +61,46 @@ 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 + mProjectRoot <- (resRootPath =<<) <$> asks lspEnv + case mProjectRoot of + Nothing -> pure Nothing + Just projectRoot -> do + completionToken <- liftIO $ newEmptyMVar + moduleUri <- writeAndIndexSource projectRoot completionToken + liftIO $ readMVar completionToken + pure $ Just moduleUri + where + writeAndIndexSource :: FilePath -> MVar () -> IdeAction Uri + writeAndIndexSource projectRoot completionToken = do + fileExists <- liftIO $ doesFileExist writeOutPath + unless fileExists $ do + nc <- asks ideNc + liftIO $ do + createDirectoryIfMissing True $ takeDirectory writeOutPath + moduleSource <- hie_hs_src <$> loadHieFile (mkUpdater nc) hieFile + BS.writeFile writeOutPath moduleSource + fileDefaultPermissions <- getPermissions writeOutPath + let filePermissions = fileDefaultPermissions + & setOwnerWritable False + & setOwnerExecutable False + setPermissions writeOutPath filePermissions + liftIO $ atomically $ + unGetTQueue indexQueue $ \withHieDb -> do + withHieDb $ \db -> + HieDb.addSrcFile db hieFile writeOutPath False + putMVar completionToken () + pure $ moduleUri + where + writeOutDir :: FilePath + writeOutDir = projectRoot ".hls" "dependencies" show uid + writeOutFile :: FilePath + writeOutFile = moduleNameSlashes moduleName <.> "hs" + writeOutPath :: FilePath + writeOutPath = writeOutDir writeOutFile + moduleUri :: Uri + moduleUri = AtPoint.toUri writeOutPath + -- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined, @@ -60,16 +117,46 @@ getAtPoint file pos = runMaybeT $ do opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useE GetHieAst file - env <- hscEnv . fst <$> useE GhcSession file - dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) + (mEnv, mDkMap) <- case getSourceFileOrigin file of + FromDependency -> pure (Nothing, Nothing) + FromProject -> do + env <- hscEnv . fst <$> useE GhcSession file + dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) + pure (Just env, Just dkMap) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos' - -toCurrentLocations :: PositionMapping -> [Location] -> [Location] -toCurrentLocations mapping = mapMaybe go + MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf mDkMap mEnv pos' + +-- | For each Loacation, determine if we have the PositionMapping +-- for the correct file. If not, get the correct position mapping +-- and then apply the position mapping to the location. +toCurrentLocations + :: PositionMapping + -> NormalizedFilePath + -> [Location] + -> IdeAction [Location] +toCurrentLocations mapping file = mapMaybeM go where - go (Location uri range) = Location uri <$> toCurrentRange mapping range + go :: Location -> IdeAction (Maybe Location) + go (Location uri range) = + -- The Location we are going to might be in a different + -- file than the one we are calling gotoDefinition from. + -- So we check that the location file matches the file + -- we are in. + if nUri == normalizedFilePathToUri file + -- The Location matches the file, so use the PositionMapping + -- we have. + then pure $ Location uri <$> toCurrentRange mapping range + -- The Location does not match the file, so get the correct + -- PositionMapping and use that instead. + else do + otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do + otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri + useE GetHieAst otherLocationFile + pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping) + where + nUri :: NormalizedUri + nUri = toNormalizedUri uri -- | useE is useful to implement functions that aren’t rules but need shortcircuiting -- e.g. getDefinition. @@ -90,7 +177,8 @@ getDefinition file pos = runMaybeT $ do (HAR _ hf _ _ _, mapping) <- useE GetHieAst file (ImportMap imports, _) <- useE GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) - toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + MaybeT $ Just <$> toCurrentLocations mapping file locations getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getTypeDefinition file pos = runMaybeT $ do @@ -98,7 +186,8 @@ getTypeDefinition file pos = runMaybeT $ do opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useE GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' + locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' + MaybeT $ Just <$> toCurrentLocations mapping file locations highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 3b8ee793a1..c995432482 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -887,23 +887,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 pending <- readTVar indexPending - pure $ case HashMap.lookup srcPath pending of + pure $ case HashMap.lookup hiePath pending of Nothing -> False -- If the hash in the pending list doesn't match the current hash, then skip Just pendingHash -> pendingHash /= hash @@ -911,10 +911,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 @@ -978,7 +976,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) $ @@ -986,7 +984,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 $ @@ -1007,7 +1007,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 diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs new file mode 100644 index 0000000000..0cbbe168a1 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -0,0 +1,116 @@ +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 Development.IDE.Types.Logger (Recorder, WithPriority) +import HieDb (SourceFile(FakeFile), lookupPackage, removeDependencySrcFiles) +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 :: Recorder (WithPriority Log) -> ShakeExtras -> GHC.HscEnv -> IO () +indexDependencyHieFiles recorder se hscEnv = do + dotHlsDirExists <- maybe (pure False) doesDirectoryExist mHlsDir + unless dotHlsDirExists deleteMissingDependencySources + void $ Map.traverseWithKey indexPackageHieFiles packagesWithModules + where + mHlsDir :: Maybe FilePath + mHlsDir = do + projectDir <- resRootPath =<< lspEnv se + pure $ projectDir ".hls" + deleteMissingDependencySources :: IO () + deleteMissingDependencySources = + atomically $ writeTQueue (indexQueue $ hiedbWriter se) $ + \withHieDb -> + withHieDb $ \db -> + removeDependencySrcFiles db + indexPackageHieFiles :: Package -> [GHC.Module] -> IO () + indexPackageHieFiles (Package package) modules = do + let pkgLibDir :: FilePath + pkgLibDir = case GHC.unitLibraryDirs package of + [] -> "" + (libraryDir : _) -> libraryDir + hieDir :: FilePath + hieDir = pkgLibDir "extra-compilation-artifacts" + unit :: GHC.Unit + unit = GHC.RealUnit $ GHC.Definite $ GHC.unitId package + moduleRows <- withHieDb se $ \db -> + lookupPackage db unit + case moduleRows of + [] -> traverse_ (indexModuleHieFile hieDir) modules + _ -> return () + indexModuleHieFile :: FilePath -> GHC.Module -> IO () + indexModuleHieFile hieDir m = do + let hiePath :: NormalizedFilePath + hiePath = toNormalizedFilePath' $ + hieDir GHC.moduleNameSlashes (GHC.moduleName m) <.> "hie" + hieCheck <- checkHieFile recorder se "newHscEnvEqWithImportPaths" hiePath + case hieCheck of + HieFileMissing -> return () + HieAlreadyIndexed -> return () + CouldNotLoadHie _e -> return () + DoIndexing hash hie -> + 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 + $ 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 :: GHC.UnitInfoMap -> Set GHC.UnitId -> Set GHC.UnitId -> Set GHC.UnitId +calculateTransitiveDependencies unitInfoMap allDependencies newDepencencies + | Set.null newDepencencies = allDependencies + | otherwise = calculateTransitiveDependencies unitInfoMap nextAll nextNew + where + nextAll :: Set GHC.UnitId + nextAll = Set.union allDependencies nextNew + 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 + ( filter (isNothing . snd) + $ GHC.unitExposedModules package + ) + ++ GHC.unitHiddenModules package + makeModule :: GHC.ModuleName + -> GHC.Module + makeModule = GHC.mkModule (GHC.unitInfoId package) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index ddb919a424..4af0d41108 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,28 @@ 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 + 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 491f4d4e0c..529db88ed3 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -31,7 +31,7 @@ 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 {-# SOURCE #-} Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.KnownTargets import GHC.Generics (Generic) @@ -340,6 +340,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 109259df7b..257c81ceeb 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, @@ -78,6 +80,7 @@ import Data.Aeson (Result (Success), toJSON) import qualified Data.Aeson.Types as A 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 @@ -129,7 +132,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 @@ -172,8 +175,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 @@ -184,13 +188,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." @@ -570,9 +576,30 @@ 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 + FromDependency -> do + se <- getShakeExtras + mHieFile <- liftIO + $ runIdeAction "GetHieAst" se + $ runMaybeT + $ 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 @@ -647,14 +674,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) let log = (liftIO .) . logWith recorder case res of Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e @@ -836,6 +863,43 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco let !fp = Just $! hiFileFingerPrint x return (fp, (diags, Just x)) +data HieFileCheck + = HieFileMissing + | HieAlreadyIndexed + | CouldNotLoadHie SomeException + | DoIndexing Util.Fingerprint HieFile + +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 + logHieFileMissing :: IO HieFileCheck + logHieFileMissing = do + let log :: Log + log = LogMissingHieFile hieFileLocation + logWith recorder Logger.Debug log + pure HieFileMissing + 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 + 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 @@ -853,31 +917,20 @@ 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 - hash <- 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 - | hash == 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 - -- 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 hash hf - + 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 + HieAlreadyIndexed -> when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ + toJSON $ fromNormalizedFilePath f + CouldNotLoadHie err -> hieFailure $ Just err + 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/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4ba1090087..18576be31c 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, @@ -107,6 +109,7 @@ import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet import Data.IORef +import Data.List (isInfixOf) import Data.List.Extra (foldl', partition, takeEnd) import qualified Data.Map.Strict as Map @@ -165,7 +168,8 @@ 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 Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -1163,11 +1167,19 @@ defineEarlyCutoff' doDiagnostics cmp key file old 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 - (bs, (diags, res)) <- actionCatch - (do v <- action staleV; liftIO $ evaluate $ force v) $ - \(e :: SomeException) -> do - pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - + (bs, (diags, res)) <- 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 + else error $ + "defineEarlyCutoff': Undefined action for dependency source files\n" + ++ show file ++ "\n" + ++ show key ver <- estimateFileVersionUnsafely key res file (bs, res) <- case res of Nothing -> do @@ -1210,6 +1222,16 @@ defineEarlyCutoff' doDiagnostics cmp key file old 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 + | Just Refl <- eqT @k @GetHieAst = True + | Just Refl <- eqT @k @IsFileOfInterest = True + | Just Refl <- eqT @k @GetModificationTime = True + | otherwise = False traceA :: A v -> String traceA (A Failed{}) = "Failed" diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index 4bf7454ab5..327f344517 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, unitInfoId, @@ -273,6 +276,9 @@ preloadClosureUs = State.preloadClosure . unitState preloadClosureUs = const () #endif +unitLibraryDirs :: UnitInfo -> [FilePath] +unitLibraryDirs = fmap ST.unpack . UnitInfo.unitLibraryDirs + unitExposedModules :: UnitInfo -> [(ModuleName, Maybe Module)] unitExposedModules ue = #if MIN_VERSION_ghc(9,0,0) @@ -281,6 +287,9 @@ unitExposedModules ue = Packages.exposedModules ue #endif +unitHiddenModules :: UnitInfo -> [ModuleName] +unitHiddenModules = UnitInfo.unitHiddenModules + unitDepends :: UnitInfo -> [UnitId] #if MIN_VERSION_ghc(9,0,0) unitDepends = State.unitDepends diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 80b956904d..65fa1f69eb 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -61,25 +61,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 $ @@ -146,6 +158,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 64c7e14bd9..c93c9f475b 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -39,7 +39,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 $ Right $ 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 d419710d51..c2a2814cd5 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -53,9 +53,10 @@ descriptor plId = (defaultPluginDescriptor plId) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> documentHighlight ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentReferences (\ide _ params -> references ide params) - <> mkPluginHandler SMethod_WorkspaceSymbol (\ide _ params -> fmap InL <$> wsSymbols ide params), + <> mkPluginHandler SMethod_WorkspaceSymbol (\ide _ params -> fmap InL <$> wsSymbols ide params) - 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 37b0fbcc17..c36150a91a 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -19,6 +19,7 @@ module Development.IDE.Spans.AtPoint ( , defRowToSymbolInfo , getNamesAtPoint , toCurrentLocation + , toUri , rowToLoc , nameToLocation , LookupModule @@ -33,6 +34,7 @@ import Language.LSP.Protocol.Types hiding -- compiler and infrastructure import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Shake (IdeAction) import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Util (printOutputable) @@ -183,26 +185,24 @@ documentHighlight hf rf pos = pure highlights else DocumentHighlightKind_Read gotoTypeDefinition - :: MonadIO m - => WithHieDb - -> LookupModule m + :: WithHieDb + -> LookupModule IdeAction -> IdeOptions -> HieAstResult -> Position - -> MaybeT m [Location] + -> MaybeT IdeAction [Location] gotoTypeDefinition withHieDb lookupModule ideOpts srcSpans pos = lift $ typeLocationsAtPoint withHieDb lookupModule ideOpts pos srcSpans -- | Locate the definition of the name at a given position. gotoDefinition - :: MonadIO m - => WithHieDb - -> LookupModule m + :: WithHieDb + -> LookupModule IdeAction -> IdeOptions -> M.Map ModuleName NormalizedFilePath -> HieASTs a -> Position - -> MaybeT m [Location] + -> MaybeT IdeAction [Location] gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans @@ -210,11 +210,11 @@ gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos atPoint :: IdeOptions -> HieAstResult - -> DocAndKindMap - -> HscEnv + -> Maybe DocAndKindMap + -> Maybe HscEnv -> Position -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo +atPoint IdeOptions{} (HAR _ hf _ _ kind) mDkMap mEnv pos = listToMaybe $ pointCommand hf pos hoverInfo where -- Hover info for values/data hoverInfo ast = (Just range, prettyNames ++ pTypes) @@ -244,22 +244,33 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p prettyName (Right n, dets) = 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" pretty (Just define) (Just pkgName) = Just $ define <> " " <> pkgName <> "\n" prettyName (Left m,_) = printOutputable m - prettyPackageName n = do - m <- nameModule_maybe n - let pid = moduleUnit m - conf <- lookupUnit env pid - let pkgName = T.pack $ unitPackageNameString conf - version = T.pack $ showVersion (unitPackageVersion conf) - pure $ "*(" <> pkgName <> "-" <> version <> ")*" + prettyPackageName n = case mEnv of + Just env -> do + pid <- getUnit n + conf <- lookupUnit env pid + let pkgName = T.pack $ unitPackageNameString conf + version = T.pack $ showVersion (unitPackageVersion conf) + pure $ "*(" <> pkgName <> "-" <> version <> ")*" + Nothing -> do + u <- getUnit n + let pkgStr = takeWhile (/= ':') $ show $ toUnitId u + pure $ "*(" <> T.pack pkgStr <> ")*" + getUnit n = moduleUnit <$> nameModule_maybe n prettyTypes = map (("_ :: "<>) . prettyType) types prettyType t = case kind of @@ -274,14 +285,12 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*" typeLocationsAtPoint - :: forall m - . MonadIO m - => WithHieDb - -> LookupModule m + :: WithHieDb + -> LookupModule IdeAction -> IdeOptions -> Position -> HieAstResult - -> m [Location] + -> IdeAction [Location] typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) = case hieKind of HieFromDisk hf -> @@ -324,15 +333,13 @@ getTypes :: [Type] -> [Name] getTypes ts = concatMap namesInType ts locationsAtPoint - :: forall m a - . MonadIO m - => WithHieDb - -> LookupModule m + :: WithHieDb + -> LookupModule IdeAction -> IdeOptions -> M.Map ModuleName NormalizedFilePath -> Position -> HieASTs a - -> m [Location] + -> IdeAction [Location] locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) zeroPos = Position 0 0 @@ -341,7 +348,7 @@ locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns -- | Given a 'Name' attempt to find the location where it is defined. -nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location]) +nameToLocation :: WithHieDb -> LookupModule IdeAction -> Name -> IdeAction (Maybe [Location]) nameToLocation withHieDb lookupModule name = runMaybeT $ case nameSrcSpan name of sp@(RealSrcSpan rsp _) @@ -377,7 +384,7 @@ nameToLocation withHieDb lookupModule name = runMaybeT $ xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs -defRowToLocation :: Monad m => LookupModule m -> Res DefRow -> MaybeT m Location +defRowToLocation :: LookupModule IdeAction -> Res DefRow -> MaybeT IdeAction Location defRowToLocation lookupModule (row:.info) = do let start = Position (fromIntegral $ defSLine row - 1) (fromIntegral $ defSCol row - 1) end = Position (fromIntegral $ defELine row - 1) (fromIntegral $ defECol row - 1) diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 623e1da691..2800cd2be8 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -22,12 +22,16 @@ 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 Development.IDE.Types.Logger (Recorder, WithPriority) import OpenTelemetry.Eventlog (withSpan) import System.Directory (makeAbsolute) import System.FilePath @@ -59,8 +63,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,12 +72,12 @@ 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 - let dflags = hsc_dflags hscEnv + _ <- async $ indexDependencyHieFiles recorder se hscEnv envUnique <- Unique.newUnique @@ -93,16 +97,10 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do Just otherPkgMod -> otherPkgMod Nothing -> mkModule (unitInfoId pkg) modName ] - - doOne m = do - modIface <- initIfaceLoad hscEnv $ - loadInterface "" m (ImportByUser NotBoot) - return $ case modIface of - Maybes.Failed _r -> Nothing - Maybes.Succeeded mi -> Just mi - modIfaces <- mapMaybeM doOne modules + modIfaces <- mapMaybeM loadModIface modules return $ createExportsMap modIfaces + let dflags = hsc_dflags hscEnv -- similar to envPackageExports, evaluated lazily envVisibleModuleNames <- onceAsync $ fromRight Nothing @@ -112,10 +110,19 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do (evaluate . force . Just $ listVisibleModuleNames hscEnv) return HscEnvEq{..} + where + loadModIface :: Module -> IO (Maybe ModIface) + loadModIface m = do + modIface <- initIfaceLoad hscEnv $ + loadInterface "" m (ImportByUser NotBoot) + return $ case modIface of + Maybes.Failed _r -> Nothing + Maybes.Succeeded mi -> Just mi + -- | 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..681d6331a5 --- /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 diff --git a/ghcide/test/data/dependency/Dependency.hs b/ghcide/test/data/dependency/Dependency.hs new file mode 100644 index 0000000000..3544ca928c --- /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/Main.hs b/ghcide/test/exe/Main.hs index 208871a933..78bacec7a1 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -41,8 +41,10 @@ module Main (main) where +import Data.Bool (bool) import Data.Row import Control.Applicative.Combinators +import Control.Applicative.Combinators as Applicative import Control.Concurrent import Control.Exception (bracket_, catch, finally) @@ -224,6 +226,7 @@ main = do , codeLensesTests , outlineTests , highlightTests + , gotoDependencyDefinitionTests , findDefinitionAndHoverTests , pluginSimpleTests , pluginParsedResultTests @@ -1008,6 +1011,50 @@ checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpecta canonicalizeLocation :: Location -> IO Location canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range +gotoDependencyDefinitionTests :: TestTree +gotoDependencyDefinitionTests = + testGroup "gotoDefinition for dependencies" + [ dependencyTest + ] + where + dependencyTest :: TestTree + dependencyTest = testSessionWithExtraFiles "dependency" "gotoDefinition in async" $ + \dir -> do + doc <- openTestDataDoc (dir "Dependency" <.> "hs") + _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 + findDefinitionAndHoverTests :: TestTree findDefinitionAndHoverTests = let diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index bd35a3312d..79d7bf3323 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 , responseError @@ -73,6 +76,7 @@ import Data.GADT.Compare import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.List (isInfixOf) import Data.List.Extra (find, sortOn) import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map @@ -268,23 +272,44 @@ data PluginDescriptor (ideState :: *) = , 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 '.'. } +data PluginFileType = PluginFileType [SourceFileOrigin] [T.Text] + +data SourceFileOrigin = FromProject | FromDependency deriving Eq + +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. 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) @@ -852,7 +877,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, @@ -872,7 +900,7 @@ defaultCabalPluginDescriptor plId = mempty mempty Nothing - [".cabal"] + (PluginFileType [FromProject] [".cabal"]) newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord) diff --git a/test/functional/Definition.hs b/test/functional/Definition.hs index 24ce49297d..3c32f2cf72 100644 --- a/test/functional/Definition.hs +++ b/test/functional/Definition.hs @@ -7,18 +7,43 @@ import Test.Hls import Test.Hls.Command tests :: TestTree -tests = testGroup "definitions" [ +tests = testGroup "definitions" [symbolTests, moduleTests] - ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/References.hs" $ - testCase "goto's symbols" $ runSession hlsCommand fullCaps "test/testdata" $ do +symbolTests :: TestTree +symbolTests = testGroup "gotoDefinition on symbols" + -- gotoDefinition where the definition is in the same file + [ testCase "gotoDefinition in this file" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "References.hs" "haskell" defs <- getDefinitions doc (Position 7 8) let expRange = Range (Position 4 0) (Position 4 3) liftIO $ defs @?= InL (Definition (InR [Location (doc ^. uri) expRange])) + -- gotoDefinition where the definition is in a different file + , testCase "gotoDefinition in other file" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do + doc <- openDoc "Foo.hs" "haskell" + defs <- getDefinitions doc (Position 4 11) + let expRange = Range (Position 2 0) (Position 2 1) + liftIO $ do + fp <- canonicalizePath "test/testdata/definition/Bar.hs" + defs @?= InL (Definition (InR [Location (filePathToUri fp) expRange])) + + -- gotoDefinition where the definition is in a different file and the + -- definition in the other file is on a line number that is greater + -- than the number of lines in the file we are requesting from + , testCase "gotoDefinition in other file past lines in this file" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do + doc <- openDoc "Foo.hs" "haskell" + defs <- getDefinitions doc (Position 5 13) + let expRange = Range (Position 8 0) (Position 8 1) + liftIO $ do + fp <- canonicalizePath "test/testdata/definition/Bar.hs" + defs @?= InL (Definition (InR [Location (filePathToUri fp) expRange])) + ] + -- ----------------------------------- - , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ +moduleTests :: TestTree +moduleTests = testGroup "gotoDefinition on modules" + [ ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's imported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do doc <- openDoc "Foo.hs" "haskell" defs <- getDefinitions doc (Position 2 8) diff --git a/test/testdata/definition/Bar.hs b/test/testdata/definition/Bar.hs index 02a244cd4d..9ae116114e 100644 --- a/test/testdata/definition/Bar.hs +++ b/test/testdata/definition/Bar.hs @@ -1,3 +1,9 @@ module Bar where a = 42 + +-- These blank lines are here +-- to ensure that b is defined +-- on a line number larger than +-- the number of lines in Foo.hs. +b = 43 diff --git a/test/testdata/definition/Foo.hs b/test/testdata/definition/Foo.hs index 6dfb3ba2e6..ca73e2d375 100644 --- a/test/testdata/definition/Foo.hs +++ b/test/testdata/definition/Foo.hs @@ -1,3 +1,6 @@ module Foo (module Bar) where import Bar + +fortyTwo = a +fortyThree = b diff --git a/test/testdata/definition/hie.yaml b/test/testdata/definition/hie.yaml new file mode 100644 index 0000000000..9adb47d0f3 --- /dev/null +++ b/test/testdata/definition/hie.yaml @@ -0,0 +1,5 @@ +cradle: + direct: + arguments: + - "Foo" + - "Bar"