diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 2.14.0.0 +version: 2.15.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -63,7 +63,7 @@ , edit-distance , enummapset , exceptions - , extra >=1.7.14 + , extra >=1.8 , filepath , fingertree , focus >=1.0.3.2 @@ -74,10 +74,10 @@ , Glob , haddock-library >=1.8 && <1.12 , hashable - , hie-bios ^>= 0.19.0 + , hie-bios ^>= 0.21.0 , hiedb ^>= 0.8.0.0 - , hls-graph == 2.14.0.0 - , hls-plugin-api == 2.14.0.0 + , hls-graph == 2.15.0.0 + , hls-plugin-api == 2.15.0.0 , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens , lens-aeson @@ -142,6 +142,7 @@ Development.IDE.Core.RuleTypes Development.IDE.Core.Service Development.IDE.Core.Shake + Development.IDE.Core.Text Development.IDE.Core.Tracing Development.IDE.Core.UseStale Development.IDE.Core.WorkerThread diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -9,6 +9,7 @@ ,loadSessionWithOptions ,getInitialGhcLibDirDefault ,getHieDbLoc + ,getHieDbLocIn ,retryOnSqliteBusy ,retryOnException ,SessionLoaderPendingBarrierVar(..) @@ -55,7 +56,7 @@ import qualified Development.IDE.Session.Implicit as GhcIde import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq) +import Development.IDE.Types.HscEnvEq (HscEnvEq, hscEnv) import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified HIE.Bios as HieBios @@ -71,7 +72,7 @@ vcat, viaShow, (<+>)) import Ide.Types (Config, SessionLoadingPreferenceConfig (..), - sessionLoading) + componentsLoading) import Language.LSP.Protocol.Message import Language.LSP.Server import System.Directory @@ -380,11 +381,17 @@ getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do + cDir <- IO.getXdgDirectory IO.XdgCache cacheDir + getHieDbLocIn cDir dir + +-- | Like 'getHieDbLoc', but roots the database under @base@ instead of +-- @XDG_CACHE_HOME@. +getHieDbLocIn :: FilePath -> FilePath -> IO FilePath +getHieDbLocIn base dir = do let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb" dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir - cDir <- IO.getXdgDirectory IO.XdgCache cacheDir - createDirectoryIfMissing True cDir - pure (cDir db) + createDirectoryIfMissing True base + pure (base db) -- Note [SessionState and batch load] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -394,6 +401,8 @@ -- - The loader processes files from 'pendingFiles', attempting to load them in batches. -- - (SBL1) If a file is already in 'failedFiles', it is loaded individually (single-file mode). -- - (SBL2) Otherwise, the loader tries to load as many files as possible together (batch mode). +-- Only files owned by the same cradle (the same @hie.yaml@) as the file being +-- loaded are batched together; see 'getExtraFilesToLoad'. -- -- On success: -- - (SBL3) All successfully loaded files are removed from 'pendingFiles' and 'failedFiles', @@ -530,6 +539,11 @@ insertFileMapping state hieYaml ncfp = STM.insert hieYaml ncfp (filesMap state) +-- | Same as 'insertFileMapping', but never overwrites an existing value. +insertFileMappingIfMissing :: SessionState -> Maybe FilePath -> NormalizedFilePath -> STM () +insertFileMappingIfMissing state hieYaml ncfp = + STM.focus (Focus.alter (<|> Just hieYaml)) ncfp (filesMap state) + -- | Remove a file from the pending file set removeFromPending :: SessionState -> FilePath -> STM () removeFromPending state file = @@ -573,18 +587,27 @@ -- -- If the current file is in error loading files, we fallback to single loading mode (empty set) -- Otherwise, we remove error files from pending files and also exclude the current file -getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath] -getExtraFilesToLoad state cfp = do +-- +-- Only files already known to belong to the same cradle as the current file are +-- returned. Handing files owned by a different cradle to a multi-component load +-- makes the build tool fail wholesale — e.g. cabal cannot map the foreign files +-- to any component of this cradle — which poisons the load of the current file. +getExtraFilesToLoad :: SessionState -> Maybe FilePath -> FilePath -> IO [FilePath] +getExtraFilesToLoad state hieYaml cfp = do pendingFiles <- getPendingFiles state errorFiles <- readVar (failedFiles state) old_files <- readVar (loadedFiles state) -- if the file is in error loading files, we fall back to single loading mode - return $ - Set.toList $ - if cfp `Set.member` errorFiles - then Set.empty - -- remove error files from pending files since error loading need to load one by one - else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files + let candidates = + if cfp `Set.member` errorFiles + then Set.empty + -- remove error files from pending files since error loading need to load one by one + else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files + filterM ownedByThisCradle (Set.toList candidates) + where + ownedByThisCradle file = do + owner <- atomically $ STM.lookup (toNormalizedFilePath' file) (filesMap state) + pure $ owner == Just hieYaml -- | We allow users to specify a loading strategy. -- Check whether this config was changed since the last time we have loaded @@ -599,11 +622,11 @@ mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar case mLoadingConfig of Nothing -> do - liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + liftIO $ writeVar biosSessionLoadingVar (Just (componentsLoading clientConfig)) pure False Just loadingConfig -> do - liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) - pure (loadingConfig /= sessionLoading clientConfig) + liftIO $ writeVar biosSessionLoadingVar (Just (componentsLoading clientConfig)) + pure (loadingConfig /= componentsLoading clientConfig) newSessionState :: IO SessionState newSessionState = do @@ -693,14 +716,14 @@ let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps) returnWithVersion $ \file -> do let absFile = toAbsolutePath file - absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile + absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState cradleLoc absFile -- | Given a file, this function will return the HscEnv and the dependencies -- it would look up the cache first, if the cache is not available, it would -- submit a request to the getOptionsLoop to get the options for the file -- and wait until the options are available -lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) -lookupOrWaitCache recorder sessionState absFile = do +lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> (FilePath -> IO (Maybe FilePath)) -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) +lookupOrWaitCache recorder sessionState cradleLoc absFile = do let ncfp = toNormalizedFilePath' absFile cacheResult <- maybeM (return Nothing) @@ -718,8 +741,14 @@ Just r -> return r Nothing -> do -- if not ok, we need to reload the session - atomically $ addToPending sessionState absFile - lookupOrWaitCache recorder sessionState absFile + hieYaml <- cradleLoc absFile + atomically $ do + -- Insert the mapping into filesMap so the cradle is known up-front. + -- This ensures we are able to batch requests belonging to the same + -- cradle. + insertFileMappingIfMissing sessionState hieYaml ncfp + addToPending sessionState absFile + lookupOrWaitCache recorder sessionState cradleLoc absFile checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) checkInCache sessionState ncfp = runMaybeT $ do @@ -933,6 +962,19 @@ liftIO $ modifyVar (hscEnvs sessionState) $ addComponentInfo (cmapWithPrio LogSessionGhc recorder) getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) +{- Note [Modules the build tool has not been told about] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Writing a module and adding it to the cabal file are two steps, so we +constantly see files that exist and are already imported but are not a target +of any component. If we refuse to load such a file it gets no session at all, +and the modules importing it fail to typecheck without reporting anything. + +We treat a file below an import path of a component as a module of that +component, because that is what GHC does: its finder searches the -i +directories and never the target list, and a module missing from the targets is +a warning (-Wmissing-home-modules), not an error. A file below no import path +is still an error, we have no options to compile it with. +-} addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> NormalizedFilePath -> IO ([TargetDetails], HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) addErrorTargetIfUnknown all_target_details hieYaml cfp = do let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') @@ -942,17 +984,61 @@ Just _ -> (all_targets', flags_map') Nothing -> (this_target_details : all_targets', HM.insert cfp this_flags flags_map') where - this_target_details = TargetDetails (TargetFile cfp) this_error_env this_dep_info [cfp] - this_flags = (this_error_env, this_dep_info) - this_error_env = ([this_error], Nothing) - this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) cfp - (T.unlines - [ "No cradle target found. Is this file listed in the targets of your cradle?" - , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" - ]) - Nothing + this_target_details = TargetDetails (TargetFile cfp) this_env this_dep_info [cfp] + this_flags = (this_env, this_dep_info) + -- See Note [Modules the build tool has not been told about] + this_env = case owningComponent all_targets' cfp of + Just env -> (missingHomeModuleWarning env cfp, Just env) + Nothing -> ([noTargetError], Nothing) + noTargetError = + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) cfp + (T.unlines + [ "No cradle target found. Is this file listed in the targets of your cradle?" + , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" + ]) + Nothing pure (all_targets, this_flags_map) +-- | -Wmissing-home-modules. GHC only emits it from the driver, which we do not +-- use, so we emit it ourselves. +missingHomeModuleWarning :: HscEnvEq -> NormalizedFilePath -> [FileDiagnostic] +missingHomeModuleWarning env cfp + | not (wopt Opt_WarnMissingHomeModules dflags) = [] + | otherwise = + [ ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) cfp + (T.unlines [message, "It is being compiled with the options of that component."]) + Nothing + ] + where + dflags = hsc_dflags $ hscEnv env + unit = T.pack $ unitIdString $ homeUnitId_ dflags + message + | gopt Opt_BuildingCabalPackage dflags = + "This module is needed for compilation but not listed in your .cabal file's \ + \other-modules or exposed-modules for '" <> unit <> "'." + | otherwise = + "This module is not listed in the options for '" <> unit + <> "' but needed for compilation." + +-- | The component with an import path the file is below. If several match we +-- take the most specific one, the one giving the shortest relative path. +-- See Note [Modules the build tool has not been told about] +owningComponent :: [TargetDetails] -> NormalizedFilePath -> Maybe HscEnvEq +owningComponent targets cfp = + listToMaybe [ env | (_, env) <- sortOn (length . splitDirectories . fst) candidates ] + where + file = fromNormalizedFilePath cfp + -- makeRelative gives back the file unchanged if it is not below the + -- directory. Both paths are absolute, so this is unambiguous. + candidates = + [ (rel, env) + | td <- targets + , Just env <- [snd (targetEnv td)] + , importPath <- importPaths $ hsc_dflags $ hscEnv env + , let rel = makeRelative (normalise importPath) file + , rel /= file + ] + -- | Populate the knownTargetsVar with all the -- files in the project so that `knownFiles` can learn about them and -- we can generate a complete module graph @@ -1018,8 +1104,8 @@ let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - sessionPref <- asks (sessionLoading . sessionClientConfig) - extraToLoads <- liftIO $ getExtraFilesToLoad sessionState cfp + sessionPref <- asks (componentsLoading . sessionClientConfig) + extraToLoads <- liftIO $ getExtraFilesToLoad sessionState hieYaml cfp -- Start loading the file! eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do @@ -1040,7 +1126,7 @@ -- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file" -- Start off by getting the session options logWith recorder Debug $ LogCradle cradle - cradleRes <- HieBios.getCompilerOptions file loadStyle cradle + cradleRes <- HieBios.getCompilerOptions (TargetWithContext file old_fps) loadStyle cradle case cradleRes of CradleSuccess r -> do -- Now get the GHC lib dir @@ -1061,8 +1147,9 @@ where loadStyle = case loadConfig of - PreferSingleComponentLoading -> LoadFile - PreferMultiComponentLoading -> LoadWithContext old_fps + PreferSingleComponentLoading -> LoadFile + PreferMultiComponentLoading -> LoadFileWithContext + PreferMultiWholeProjectLoading -> LoadUnitsFromCradle -- ---------------------------------------------------------------------------- -- Utilities diff --git a/session-loader/Development/IDE/Session/Ghc.hs b/session-loader/Development/IDE/Session/Ghc.hs --- a/session-loader/Development/IDE/Session/Ghc.hs +++ b/session-loader/Development/IDE/Session/Ghc.hs @@ -150,7 +150,7 @@ -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components -> IO [ [TargetDetails] ] -newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do +newComponentCache recorder exts cfp hsc_env old_cis new_cis = do let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) -- When we have multiple components with the same uid, -- prefer the new one over the old. @@ -172,7 +172,7 @@ #endif closure_err_to_multi_err err = ideErrorWithSource - (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp + (Just "cradle") (Just DiagnosticSeverity_Warning) cfp (T.pack (Compat.printWithoutUniques (singleMessage err))) (Just (fmap GhcDriverMessage err)) multi_errs = map closure_err_to_multi_err closure_errs @@ -198,6 +198,15 @@ Nothing -> pure () Just err -> logWith recorder Error $ LogDLLLoadError err + -- A session representative file of this load. See Note [Session representatives] + -- Not cfp which may be an error target. + let repr = fromMaybe cfp $ listToMaybe + [ loc + | ci <- Map.elems cis + , t <- componentTargets ci + , loc <- targetIdLocations (importPaths (componentDynFlags ci)) exts (targetId t) + ] + forM (Map.elems cis) $ \ci -> do let df = componentDynFlags ci thisEnv <- do @@ -205,7 +214,7 @@ -- above. -- We just need to set the current unit here pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv' - henv <- newHscEnvEq thisEnv + henv <- newHscEnvEq repr thisEnv let targetEnv = (if isBad ci then multi_errs else [], Just henv) targetDepends = componentDependencyInfo ci logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) @@ -280,6 +289,7 @@ Nothing -> compRoot Just wdir -> compRoot wdir let dflags''' = + normaliseImportsPaths $ setWorkingDirectory root $ disableWarningsAsErrors $ -- disabled, generated directly by ghcide instead @@ -296,6 +306,9 @@ dflags'' return (HomeUnitConfig dflags''' targets mHash) +normaliseImportsPaths :: DynFlags -> DynFlags +normaliseImportsPaths dflags = dflags { importPaths = fmap normalise (importPaths dflags)} + addComponentInfo :: MonadUnliftIO m => Recorder (WithPriority Log) -> @@ -450,9 +463,20 @@ -- keeping the path short and clean. getCacheDirsDefault :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs getCacheDirsDefault prefix mFirstHash opts = do - dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix' ++ "-" ++ opts_hash) - return $ CacheDirs dir dir dir + base <- getXdgDirectory XdgCache cacheDir + pure $ cacheDirsUnder base prefix mFirstHash opts + +-- | Like 'getCacheDirsDefault', but roots the cache under @base@ instead of +-- 'XdgCache', so callers can isolate a cache without touching @XDG_CACHE_HOME@. +getCacheDirsIn :: FilePath -> String -> Maybe B.ByteString -> [String] -> CacheDirs +getCacheDirsIn base prefix mFirstHash opts = + cacheDirsUnder (base cacheDir) prefix mFirstHash opts + +-- | The per-component cache folder under @base@. See 'getCacheDirsDefault'. +cacheDirsUnder :: FilePath -> String -> Maybe B.ByteString -> [String] -> CacheDirs +cacheDirsUnder base prefix mFirstHash opts = CacheDirs dir dir dir where + dir = Just (base prefix' ++ "-" ++ opts_hash) -- Create a unique folder per set of different GHC options. prefix' = if isJust mFirstHash then "main" else prefix basectx = case mFirstHash of @@ -487,28 +511,38 @@ targetLocations :: ![NormalizedFilePath] } +-- | Candidate locations of a target, in search order. +targetIdLocations :: [FilePath] -- ^ import paths + -> [String] -- ^ extensions to consider + -> TargetId + -> [NormalizedFilePath] +-- For a target module we consider all the import paths +targetIdLocations is exts (GHC.TargetModule modName) = + [ toNormalizedFilePath' (i moduleNameSlashes modName -<.> ext <> boot) + | ext <- exts + , i <- is + , boot <- ["", "-boot"] + ] +-- For a 'TargetFile' we consider all the possible module names +targetIdLocations _ _ (GHC.TargetFile f _) = [nf, other] + where + nf = toNormalizedFilePath' f + other + | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) + | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") + fromTargetId :: [FilePath] -- ^ import paths -> [String] -- ^ extensions to consider -> TargetId -> IdeResult HscEnvEq -> DependencyInfo -> IO [TargetDetails] --- For a target module we consider all the import paths -fromTargetId is exts (GHC.TargetModule modName) env dep = do - let fps = [i moduleNameSlashes modName -<.> ext <> boot - | ext <- exts - , i <- is - , boot <- ["", "-boot"] - ] - let locs = fmap toNormalizedFilePath' fps - return [TargetDetails (TargetModule modName) env dep locs] --- For a 'TargetFile' we consider all the possible module names -fromTargetId _ _ (GHC.TargetFile f _) env deps = do - let nf = toNormalizedFilePath' f - let other - | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) - | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") - return [TargetDetails (TargetFile nf) env deps [nf, other]] +fromTargetId is exts tid env dep = + return [TargetDetails target env dep (targetIdLocations is exts tid)] + where + target = case tid of + GHC.TargetModule modName -> TargetModule modName + GHC.TargetFile f _ -> TargetFile (toNormalizedFilePath' f) -- ---------------------------------------------------------------------------- -- Backwards compatibility diff --git a/session-loader/Development/IDE/Session/Implicit.hs b/session-loader/Development/IDE/Session/Implicit.hs --- a/session-loader/Development/IDE/Session/Implicit.hs +++ b/session-loader/Development/IDE/Session/Implicit.hs @@ -78,12 +78,12 @@ pkgsWithComps <- liftIO $ catMaybes <$> mapM (nestedPkg fp) pkgs let yaml = fp "stack.yaml" pure $ (,fp) $ case pkgsWithComps of - [] -> Stack (StackType Nothing (Just yaml)) + [] -> Stack (StackType Nothing (Just yaml) Nothing) ps -> StackMulti mempty $ do Package n cs <- ps c <- cs let (prefix, comp) = Implicit.stackComponent n c - pure (prefix, StackType (Just comp) (Just yaml)) + pure (prefix, StackType (Just comp) (Just yaml) Nothing) -- | By default, we generate a simple cabal cradle which is equivalent to the -- following hie.yaml: @@ -95,7 +95,7 @@ -- -- Note, this only works reliable for reasonably modern cabal versions >= 3.2. simpleCabalCradle :: FilePath -> (CradleTree a, FilePath) -simpleCabalCradle fp = (Cabal $ CabalType Nothing Nothing, fp) +simpleCabalCradle fp = (Cabal $ CabalType Nothing Nothing Nothing, fp) cabalExecutable :: MaybeT IO FilePath cabalExecutable = MaybeT $ findExecutable "cabal" diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -18,6 +18,8 @@ , mkHiFileResultNoCompile , generateObjectCode , generateByteCode + , LinkableFingerprint (..) + , mkLinkableFingerprint , generateHieAsts , writeAndIndexHieFile , indexHieFile @@ -40,8 +42,7 @@ ) where import Control.Concurrent.STM.Stats hiding (orElse) -import Control.DeepSeq (NFData (..), - force, rnf) +import qualified Control.DeepSeq as DeepSeq import Control.Exception (evaluate) import Control.Exception.Safe import Control.Lens hiding (List, pre, @@ -67,7 +68,9 @@ import Data.Maybe import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T -import Data.Time (UTCTime (..)) +import Data.Time (Day (ModifiedJulianDay), + UTCTime (..), + picosecondsToDiffTime) import Data.Tuple.Extra (dupe) import Debug.Trace import Development.IDE.Core.FileStore (resetInterfaceStore) @@ -110,12 +113,13 @@ import qualified GHC as G import GHC.Core.Lint.Interactive import GHC.Driver.Config.CoreToStg.Prep +import GHC.Driver.Env (runHsc') +import GHC.Driver.Main (hscDesugar', hscSimplify') import GHC.Iface.Ext.Types (HieASTs) import qualified GHC.Runtime.Loader as Loader import GHC.Tc.Gen.Splice import GHC.Types.Error import GHC.Types.ForeignStubs -import GHC.Types.HpcInfo import GHC.Types.TypeEnv -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -143,6 +147,10 @@ writeHieFile) #endif +#if !MIN_VERSION_ghc(9,11,0) +import GHC.Types.HpcInfo (emptyHpcInfo) +#endif + #if MIN_VERSION_ghc(9,11,0) import qualified Data.List.NonEmpty as NE import Data.Time (getCurrentTime) @@ -156,7 +164,6 @@ import GHC.Unit.Home.PackageTable (hptInternalTableRef, hptInternalTableFromRef) import GHC.Unit.Module.ModIface (IfaceTopEnv(..)) import GHC.Types.Avail (emptyDetOrdAvails) -import GHC.Types.Basic (ImportLevel(..), convImportLevel) #endif #if MIN_VERSION_ghc(9,12,0) @@ -180,7 +187,7 @@ fmap (either (, Nothing) id) $ runExceptT $ do (diag, modu) <- parseFileContents env optPreprocessor filename ms - return (diag, Just modu) + pure (diag, Just modu) -- | Given a package identifier, what packages does it depend on @@ -191,12 +198,12 @@ computePackageDeps env pkg = do case lookupUnit env pkg of Nothing -> - return $ Left + pure $ Left [ ideErrorText (toNormalizedFilePath' noFilePath) (T.pack $ "unknown package: " ++ show pkg) ] - Just pkgInfo -> return $ Right $ unitDepends pkgInfo + Just pkgInfo -> pure $ Right $ unitDepends pkgInfo data TypecheckHelpers = TypecheckHelpers @@ -215,7 +222,7 @@ initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)" (Loader.initializePlugins (hscSetFlags (ms_hspp_opts modSummary) hsc)) case initialized of - Left errs -> return (errs, Nothing) + Left errs -> pure (errs, Nothing) Right hscEnv -> do etcm <- let @@ -225,7 +232,7 @@ catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary'} case etcm of - Left errs -> return (errs, Nothing) + Left errs -> pure (errs, Nothing) Right tcm -> let addReason diag = map (Just (diagnosticReason (errMsgDiagnostic diag)),) $ @@ -234,7 +241,7 @@ diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm deferredError = any fst diags in - return (map snd diags, Just $ tcm{tmrDeferredError = deferredError}) + pure (map snd diags, Just $ tcm{tmrDeferredError = deferredError}) where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id @@ -246,7 +253,7 @@ res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env) splices <- readIORef splice_ref needed_mods <- readIORef dep_ref - return (res, splices, needed_mods) + pure (res, splices, needed_mods) where addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) } @@ -358,7 +365,7 @@ #endif ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb]) - ; return hval } + ; pure hval } -- TODO: support backpack nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule @@ -524,7 +531,7 @@ (tcg_import_decls (tmrTypechecked tcm)) simplified_guts #else - let !partial_iface = force $ mkPartialIface session + let !partial_iface = DeepSeq.force $ mkPartialIface session (cg_binds guts) details ms @@ -550,30 +557,25 @@ {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} #endif - -- Write the core file now - core_file <- do + -- Write the core file now. + core_hash <- do let core_fp = ml_core_file $ ms_location ms core_file = codeGutsToCoreFile iface_hash guts iface_hash = getModuleHash final_iface - core_hash1 <- atomicFileWrite se core_fp $ \fp -> + _ <- atomicFileWrite se core_fp $ \fp -> writeBinCoreFile (hsc_dflags session) fp core_file - -- We want to drop references to guts and read in a serialized, compact version - -- of the core file from disk (as it is deserialised lazily) - -- This is because we don't want to keep the guts in memory for every file in - -- the project as it becomes prohibitively expensive - -- The serialized file however is much more compact and only requires a few - -- hundred megabytes of memory total even in a large project with 1000s of - -- modules - (coreFile, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp - pure $ assert (core_hash1 == core_hash2) - $ Just (coreFile, fingerprintToBS core_hash2) + -- Only keep around a hash of the file and load in the core file from + -- disk when needed. + !hash <- readBinCoreFileHash core_fp + pure $ Just $! fingerprintToBS hash -- Verify core file by roundtrip testing and comparison IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se - case core_file of - Just (core, _) | optVerifyCoreFile -> do + case core_hash of + Just _ | optVerifyCoreFile -> do let core_fp = ml_core_file $ ms_location ms traceIO $ "Verifying " ++ core_fp + (core, _) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = guts mod = ms_mod ms data_tycons = filter isAlgTyCon tycons @@ -633,15 +635,15 @@ panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") diffs) -- ++ [ppr binds , ppr binds'])) _ -> pure () - pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file) + pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_hash) where dflags = hsc_dflags session' source = "compile" catchErrs x = x `catches` - [ Handler $ return . (,Nothing) . diagFromGhcException source dflags + [ Handler $ pure . (,Nothing) . diagFromGhcException source dflags , Handler $ \diag -> - return + pure ( diagFromString source DiagnosticSeverity_Error (noSpan "") ("Error during " ++ T.unpack source ++ show @SomeException diag) @@ -665,36 +667,62 @@ -> TcGblEnv -> IO (IdeResult ModGuts) compileModule (RunSimplifier simplify) session ms tcg = - fmap (either (, Nothing) (second Just)) $ - catchSrcErrors (hsc_dflags session) "compile" $ do - (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do - -- Breakpoints don't survive roundtripping from disk - -- and this trips up the verify-core-files check - -- They may also lead to other problems. - -- We have to setBackend ghciBackend in 9.8 as otherwise - -- non-exported definitions are stripped out. - -- However, setting this means breakpoints are generated. - -- Solution: prevent breakpoing generation by unsetting - -- Opt_InsertBreakpoints - let session' = tweak $ flip hscSetFlags session + catchSrcErrors (hsc_dflags session) compilePhase compileAction + >>= \case Left diags -> pure (diags, Nothing) + Right (diags, modGuts) -> pure (diags, Just modGuts) + where + compilePhase = "compile" + compileAction = do + -- Breakpoints don't survive roundtripping from disk + -- and this trips up the verify-core-files check + -- They may also lead to other problems. + -- We have to setBackend ghciBackend in 9.8 as otherwise + -- non-exported definitions are stripped out. + -- However, setting this means breakpoints are generated. + -- Solution: prevent breakpoing generation by unsetting + -- Opt_InsertBreakpoints + let session' = flip hscSetFlags session #if MIN_VERSION_ghc(9,7,0) - $ flip gopt_unset Opt_InsertBreakpoints - $ setBackend ghciBackend + $ flip gopt_unset Opt_InsertBreakpoints + $ setBackend ghciBackend #endif - $ ms_hspp_opts ms - -- TODO: maybe settings ms_hspp_opts is unnecessary? - -- MP: the flags in ModSummary should be right, if they are wrong then - -- the correct place to fix this is when the ModSummary is created. - desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) tcg - if simplify - then do - plugins <- readIORef (tcg_th_coreplugins tcg) - hscSimplify session' plugins desugar - else pure desugar - return (map snd warnings, desugared_guts) + $ ms_hspp_opts ms + -- TODO: maybe settings ms_hspp_opts is unnecessary? + -- MP: the flags in ModSummary should be right, if they are wrong then + -- the correct place to fix this is when the ModSummary is created. + (desugar, msgs) <- do + runHsc' session' $ do + desugar <- hscDesugar' (ms_location (ms { ms_hspp_opts = hsc_dflags session' })) tcg + if simplify + then do + plugins <- liftIO $ readIORef (tcg_th_coreplugins tcg) + hscSimplify' plugins desugar + else pure desugar + pure (diagFromErrMsgs compilePhase (hsc_dflags session') $ getWarningMessages msgs, desugar) -generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) -generateObjectCode session summary guts = do + +-- | A horrible hack +-- GHC identifies Linkables using their UTCTime (when they were generated) +-- This is insufficient for our needs, we need to identify linkables by a fingerprint containing +-- both the hash of the linkable itself as well as all of all of its dependencies +-- +-- UTCTime has an unbounded integer +-- We can smuggle an arbitary 128 bit fingerprint +-- in the integer +-- +-- This way we can ensure we only keep loaded objects (byte/native) with the correct +-- transitive closure. +-- +-- This is fine because GHC only uses the time for identity +newtype LinkableFingerprint = LinkableFingerprint UTCTime + +mkLinkableFingerprint :: Util.Fingerprint -> LinkableFingerprint +mkLinkableFingerprint (Util.Fingerprint a b) = + LinkableFingerprint $ UTCTime (ModifiedJulianDay 0) $ picosecondsToDiffTime $ + toInteger a * 2 ^ (64 :: Int) + toInteger b + +generateObjectCode :: LinkableFingerprint -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) +generateObjectCode (LinkableFingerprint linkable_fp) session summary guts = do fmap (either (, Nothing) (second Just)) $ catchSrcErrors (hsc_dflags session) "object" $ do let dot_o = ml_obj_file (ms_location summary) @@ -716,19 +744,15 @@ case obj of Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code" Just x -> pure x - -- Need time to be the modification time for recompilation checking - t <- liftIO $ getModificationTime dot_o_fp #if MIN_VERSION_ghc(9,11,0) - let linkable = Linkable t mod (pure $ DotO dot_o_fp ModuleObject) + let linkable = Linkable linkable_fp mod (pure $ DotO dot_o_fp ModuleObject) #else - let linkable = LM t mod [DotO dot_o_fp] + let linkable = LM linkable_fp mod [DotO dot_o_fp] #endif pure (map snd warnings, linkable) -newtype CoreFileTime = CoreFileTime UTCTime - -generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) -generateByteCode (CoreFileTime time) hscEnv summary guts = do +generateByteCode :: LinkableFingerprint -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) +generateByteCode (LinkableFingerprint linkable_fp) hscEnv summary guts = do fmap (either (, Nothing) (second Just)) $ catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do @@ -751,9 +775,9 @@ #endif #if MIN_VERSION_ghc(9,11,0) - let linkable = Linkable time (ms_mod summary) (pure $ BCOs bytecode) + let linkable = Linkable linkable_fp (ms_mod summary) (pure $ BCOs bytecode) #else - let linkable = LM time (ms_mod summary) [BCOs bytecode sptEntries] + let linkable = LM linkable_fp (ms_mod summary) [BCOs bytecode sptEntries] #endif pure (map snd warnings, linkable) @@ -1004,15 +1028,15 @@ atomicFileWrite se targetPath $ \fp -> writeIfaceFile hscEnv fp modIface where - modIface = hirModIface tc - targetPath = ml_hi_file $ ms_location $ hirModSummary tc + modIface = hirModIface (hirIface tc) + targetPath = ml_hi_file $ ms_location $ hirModSummary (hirIface tc) dflags = hsc_dflags hscEnv handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] handleGenerationErrors dflags source action = - action >> return [] `catches` - [ Handler $ return . diagFromGhcException source dflags - , Handler $ \(exception :: SomeException) -> return $ + action >> pure [] `catches` + [ Handler $ pure . diagFromGhcException source dflags + , Handler $ \(exception :: SomeException) -> pure $ diagFromString source DiagnosticSeverity_Error (noSpan "") ("Error during " ++ T.unpack source ++ show exception) @@ -1022,9 +1046,9 @@ handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a) handleGenerationErrors' dflags source action = fmap ([],) action `catches` - [ Handler $ return . (,Nothing) . diagFromGhcException source dflags + [ Handler $ pure . (,Nothing) . diagFromGhcException source dflags , Handler $ \(exception :: SomeException) -> - return + pure ( diagFromString source DiagnosticSeverity_Error (noSpan "") ("Error during " ++ T.unpack source ++ show exception) @@ -1033,6 +1057,21 @@ ) ] +{- Note [Home modules are resolved by HLS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Which file provides a home module is decided by 'GetLocatedImports' in the build +graph. We do not want GHC to try looking for the module on its own, as this can +lead to subtle correctness or performance bugs (at best GHC goes looking in the +filesystem for a while, for a module which we've already established doesn't +exist). + +To prevent GHC's finder from repeating work we've already done in HLS and to +avoid masking bugs in the HLS finding logic, we poison the hook so that GHC can +never succeed in finding home modules by itself. + +Only possible from GHC 9.11, where the finder cache became a set of hooks. +-} + -- Merge the HPTs, module graphs and FinderCaches -- See Note [GhcSessionDeps] in Development.IDE.Core.Rules -- Add the current ModSummary to the graph, along with the @@ -1055,10 +1094,11 @@ if moduleUnit im `elem` hsc_all_home_unit_ids env then pure () else addToFinderCache (hsc_FC env) im val + -- See Note [Home modules are resolved by HLS] , lookupFinderCache = \im -> if moduleUnit im `elem` hsc_all_home_unit_ids env then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of - Nothing -> pure Nothing + Nothing -> pure $ Just $ InstalledNotFound [] (Just $ moduleUnit im) Just fs -> let ml = fromJust $ do id <- lookupPathToId (depPathIdMap dep_info) fs artifactModLocation (idToModLocation (depPathIdMap dep_info) id) @@ -1072,7 +1112,7 @@ } loadModulesHome extraMods hsc_env' #else - return $! loadModulesHome extraMods $ + pure $! loadModulesHome extraMods $ let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in (hscUpdateHUG (const newHug) env){ hsc_mod_graph = mg, @@ -1081,10 +1121,11 @@ if moduleUnit im `elem` hsc_all_home_unit_ids env then pure () else addToFinderCache (hsc_FC env) gwib val + -- See Note [Home modules are resolved by HLS] , lookupFinderCache = \gwib@(GWIB im _) -> if moduleUnit im `elem` hsc_all_home_unit_ids env then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of - Nothing -> pure Nothing + Nothing -> pure $ Just $ InstalledNotFound [] (Just $ moduleUnit im) Just fs -> let ml = fromJust $ do id <- lookupPathToId (depPathIdMap dep_info) fs artifactModLocation (idToModLocation (depPathIdMap dep_info) id) @@ -1103,7 +1144,7 @@ hpt_b <- readIORef . hptInternalTableRef . homeUnitEnv_hpt =<< b hpt_a <- readIORef . hptInternalTableRef . homeUnitEnv_hpt $ a_v result <- hptInternalTableFromRef =<< (newIORef $! mergeUDFM hpt_a hpt_b) - return $! a_v { homeUnitEnv_hpt = result } + pure $! a_v { homeUnitEnv_hpt = result } mergeUDFM = plusUDFM_C combineModules combineModules a b | HsSrcFile <- mi_hsc_src (hm_iface a) = a @@ -1131,7 +1172,7 @@ ifr = InstalledFound (ms_location ms) im curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr newFinderCache <- concatFC curFinderCache (map hsc_FC envs) - return $! loadModulesHome extraMods $ + pure $! loadModulesHome extraMods $ let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in (hscUpdateHUG (const newHug) env){ hsc_FC = newFinderCache, @@ -1207,7 +1248,8 @@ msrImports = implicit_imports ++ imps - rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv) + unitEnv = hsc_unit_env ppEnv + rn_pkg_qual = renameRawPkgQual unitEnv rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) #if MIN_VERSION_ghc(9,13,0) -- In GHC 9.13+, ms_srcimps is just [Located ModuleName] and ms_textual_imps includes ImportLevel @@ -1233,8 +1275,8 @@ -- Force bits that might keep the string buffer and DynFlags alive unnecessarily - liftIO $ evaluate $ rnf srcImports - liftIO $ evaluate $ rnf textualImports + liftIO $ evaluate $ DeepSeq.rnf srcImports + liftIO $ evaluate $ DeepSeq.rnf textualImports modLoc <- liftIO $ if mod == mAIN_NAME @@ -1268,34 +1310,31 @@ , ms_textual_imps = textualImports } - msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary + msrFingerprint <- liftIO $ computeFingerprint opts unitEnv msrImports msrModSummary msrHscEnv <- liftIO $ Loader.initializePlugins (hscSetFlags (ms_hspp_opts msrModSummary) ppEnv) - return ModSummaryResult{..} + pure ModSummaryResult{..} where - -- Compute a fingerprint from the contents of `ModSummary`, + -- Compute a fingerprint from the `msrImports` and the contents of `ModSummary`, -- eliding the timestamps, the preprocessed source and other non relevant fields - computeFingerprint opts ModSummary{..} = do + computeFingerprint opts unitEnv msrImports ModSummary{..} = do fingerPrintImports <- fingerprintFromPut $ do put $ Util.uniq $ moduleNameFS $ moduleName ms_mod -#if MIN_VERSION_ghc(9,13,0) - -- In GHC 9.13+, ms_srcimps is [Located ModuleName] and ms_textual_imps is [(ImportLevel, PkgQual, Located ModuleName)] - forM_ ms_srcimps $ \m -> do - put $ Util.uniq $ moduleNameFS $ unLoc m - forM_ ms_textual_imps $ \(_lvl, mb_p, m) -> do - put $ Util.uniq $ moduleNameFS $ unLoc m - case mb_p of - G.NoPkgQual -> pure () - G.ThisPkg uid -> put $ getKey $ getUnique uid - G.OtherPkg uid -> put $ getKey $ getUnique uid -#else - forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do - put $ Util.uniq $ moduleNameFS $ unLoc m - case mb_p of - G.NoPkgQual -> pure () - G.ThisPkg uid -> put $ getKey $ getUnique uid - G.OtherPkg uid -> put $ getKey $ getUnique uid -#endif - return $! Util.fingerprintFingerprints $ + + forM_ msrImports $ \(L _ decl) -> do + let modName = unLoc $ ideclName decl + pkgQual = renameRawPkgQual unitEnv modName (ideclPkgQual decl) + + put $ Util.uniq $ moduleNameFS modName + put $ ideclSource decl == IsBoot + + case pkgQual of + G.NoPkgQual -> pure () + G.ThisPkg uid -> put $ getKey $ getUnique uid + G.OtherPkg uid -> put $ getKey $ getUnique uid + + put $ Util.uniq . moduleNameFS . unLoc <$> ideclAs decl + + pure $! Util.fingerprintFingerprints $ [ Util.fingerprintString fp , fingerPrintImports , modLocationFingerprint ms_location @@ -1338,7 +1377,7 @@ throwE $ diagFromGhcErrorMessages sourceParser dflags errs let warnings = diagFromGhcErrorMessages sourceParser dflags warns - return (warnings, rdr_module) + pure (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a -- parsed module (or errors) and any parse warnings. Does not run any preprocessors @@ -1503,9 +1542,9 @@ -- can be later turned into a proper linkable data IdeLinkable = GhcLinkable !Linkable | CoreLinkable !UTCTime !CoreFile -instance NFData IdeLinkable where - rnf (GhcLinkable lb) = rnf lb - rnf (CoreLinkable time _) = rnf time +instance DeepSeq.NFData IdeLinkable where + rnf (GhcLinkable lb) = DeepSeq.rnf lb + rnf (CoreLinkable time _) = DeepSeq.rnf time ml_core_file :: ModLocation -> FilePath ml_core_file ml = ml_hi_file ml <.> "core" @@ -1523,7 +1562,7 @@ -> m ([FileDiagnostic], Maybe HiFileResult) loadInterface session ms linkableNeeded RecompilationInfo{..} = do let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session - mb_old_iface = hirModIface . fst <$> old_value + mb_old_iface = hirModIface . hirIface . fst <$> old_value core_file = ml_core_file (ms_location ms) iface_file = ml_hi_file (ms_location ms) @@ -1541,10 +1580,10 @@ read_result <- liftIO $ readIface read_dflags ncu mod iface_file #endif case read_result of - Util.Failed{} -> return Nothing + Util.Failed{} -> pure Nothing -- important to call `shareUsages` here before checkOldIface -- consults `mi_usages` - Util.Succeeded iface -> return $ Just (shareUsages iface) + Util.Succeeded iface -> pure $ Just (shareUsages iface) -- If mb_old_iface is nothing then checkOldIface will load it for us -- given that the source is unmodified @@ -1576,12 +1615,14 @@ Just msg -> do_regenerate msg Nothing | isJust linkableNeeded -> handleErrs $ do - (coreFile@CoreFile{cf_iface_hash}, core_hash) <- liftIO $ + -- Only cf_iface_hash is forced, so the buffer behind the + -- lazy cf_bindings is dropped when this returns. + (CoreFile{cf_iface_hash}, core_hash) <- liftIO $ readBinCoreFile (mkUpdater $ hsc_NC session) core_file if cf_iface_hash == getModuleHash iface - then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (coreFile, fingerprintToBS core_hash))) + then pure ([], Just $ mkHiFileResult ms iface details runtime_deps (Just $! fingerprintToBS core_hash)) else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)") - | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing) + | otherwise -> pure ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing) where handleErrs = flip catches [Handler $ \(e :: IOException) -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")") ,Handler $ \(e :: GhcException) -> case e of @@ -1674,12 +1715,12 @@ #endif Nothing [] -coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo) +coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> LinkableFingerprint -> IO ([FileDiagnostic], Maybe HomeModInfo) coreFileToLinkable linkableType session ms iface details core_file t = do cgi_guts <- coreFileToCgGuts session iface details core_file (warns, lb) <- case linkableType of - BCOLinkable -> fmap (maybe emptyHomeModInfoLinkable justBytecode) <$> generateByteCode (CoreFileTime t) session ms cgi_guts - ObjectLinkable -> fmap (maybe emptyHomeModInfoLinkable justObjects) <$> generateObjectCode session ms cgi_guts + BCOLinkable -> fmap (maybe emptyHomeModInfoLinkable justBytecode) <$> generateByteCode t session ms cgi_guts + ObjectLinkable -> fmap (maybe emptyHomeModInfoLinkable justObjects) <$> generateObjectCode t session ms cgi_guts pure (warns, Just $ HomeModInfo iface details lb) -- TODO wz1000 handle emptyHomeModInfoLinkable -- | Non-interactive, batch version of 'InteractiveEval.getDocs'. @@ -1692,7 +1733,7 @@ getDocsBatch hsc_env _names = do res <- initIfaceLoad hsc_env $ forM _names $ \name -> case nameModule_maybe name of - Nothing -> return (Left $ NameHasNoModule name) + Nothing -> pure (Left $ NameHasNoModule name) Just mod -> do ModIface { mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr @@ -1705,7 +1746,7 @@ else pure (Right ( lookupUniqMap dmap name, lookupWithDefaultUniqMap amap mempty name)) - return $ map (first $ T.unpack . printOutputable) res + pure $ map (first $ T.unpack . printOutputable) res where compiled n = -- TODO: Find a more direct indicator. @@ -1724,17 +1765,17 @@ lookupName hsc_env name = exceptionHandle $ do mb_thing <- liftIO $ lookupType hsc_env name case mb_thing of - x@(Just _) -> return x + x@(Just _) -> pure x Nothing | x@(Just thing) <- wiredInNameTyThing_maybe name -> do when (needWiredInHomeIface thing) (initIfaceLoad hsc_env (loadWiredInHomeIface name)) - return x + pure x | otherwise -> do res <- initIfaceLoad hsc_env $ importDecl name case res of - Util.Succeeded x -> return (Just x) - _ -> return Nothing + Util.Succeeded x -> pure (Just x) + _ -> pure Nothing where exceptionHandle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -6,6 +6,7 @@ , modifyFileExists , getFileExists , watchedGlobs + , allExtensions , GetFileExists(..) , Log(..) ) diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -307,6 +307,18 @@ atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession +{- Note [Unique file watcher registration ids] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We send more than one 'client/registerCapability' for watched files: one for +the global source globs, plus one foreach cradle dependency that the globs +do not already cover, see 'addWatchedFileRule'. These are logically distinct +registrations, so they must not share an id. + +LSP leaves the meaning of a repeated id undefined. emacs' eglot unregisters the +old watches before re-registering, while neovim and vscode accumulate. We derive +the id from the globs to keep them distinct and idempotent, while supporting +potentially de-registering in the future. +-} registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do watchSupported <- isWatchSupported @@ -314,12 +326,11 @@ then do let regParams = LSP.RegistrationParams [toUntypedRegistration registration] - -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't). - -- We could also use something like a random UUID, as some other servers do, but this works for - -- our purposes. - registration = LSP.TRegistration { _id ="globalFileWatches" + -- See Note [Unique file watcher registration ids] + registration = LSP.TRegistration { _id = registrationId , _method = LSP.SMethod_WorkspaceDidChangeWatchedFiles , _registerOptions = Just regOptions} + registrationId = "hls-file-watches:" <> Text.intercalate "," (map Text.pack globs) regOptions = DidChangeWatchedFilesRegistrationOptions { _watchers = watchers } -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind diff --git a/src/Development/IDE/Core/PluginUtils.hs b/src/Development/IDE/Core/PluginUtils.hs --- a/src/Development/IDE/Core/PluginUtils.hs +++ b/src/Development/IDE/Core/PluginUtils.hs @@ -56,7 +56,7 @@ import qualified Development.IDE.Types.Location as Location import qualified Ide.Logger as Logger import Ide.Plugin.Error -import Ide.PluginUtils (rangesOverlap) +import Ide.PluginUtils (asPosition, rangesOverlap) import Ide.Types import qualified Language.LSP.Protocol.Lens as LSP import Language.LSP.Protocol.Message (SMethod (..)) @@ -215,14 +215,26 @@ case mDiags of Nothing -> pure Nothing Just fileDiags -> do - pure $ Just $ filter diagRangeOverlaps fileDiags + pure $ Just $ filter (diagRangeOverlaps range) fileDiags where - diagRangeOverlaps = \fileDiag -> - rangesOverlap range (fileDiag ^. fdLspDiagnosticL . LSP.range) + -- The rationale of how to decide whether a 'Range' overlap with the + -- 'Range' of a diagnostic is explained at + -- https://github.com/haskell/haskell-language-server/pull/5047 + diagRangeOverlaps range fileDiag + | Just c <- asPosition range + -- The client sent us the cursor position, so we check if it + -- overlaps with the **closed** 'Range' of the diagnostic. + = LSP.positionInRange c diagRange || c == diagEnd + | otherwise + -- The client sent us a selection 'Range', so we check if it + -- overlaps with the 'Range' of the diagnostic. + = rangesOverlap range diagRange + where + diagRange@(LSP.Range _ diagEnd) = fileDiag ^. fdLspDiagnosticL . LSP.range -- | Just like 'activeDiagnosticsInRangeMT'. See the docs of 'activeDiagnosticsInRangeMT' for details. -activeDiagnosticsInRange :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> m (Maybe [FileDiagnostic]) -activeDiagnosticsInRange ide nfp range = runMaybeT (activeDiagnosticsInRangeMT ide nfp range) +activeDiagnosticsInRange :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> m [FileDiagnostic] +activeDiagnosticsInRange ide nfp range = concat <$> runMaybeT (activeDiagnosticsInRangeMT ide nfp range) -- Prefer server-side diagnostics if available; they are authoritative. injectServerDiagnostics :: IdeState -> CodeActionParams -> IO CodeActionParams @@ -231,9 +243,7 @@ Nothing -> pure [] Just nfp -> do mDiags <- activeDiagnosticsInRange (shakeExtras ide) nfp _range - case mDiags of - Nothing -> pure [] - Just diags -> pure $ diags ^.. traverse . fdLspDiagnosticL + pure $ mDiags ^.. traverse . fdLspDiagnosticL pure $ params & LSP.context . LSP.diagnostics .~ serverDiags -- ---------------------------------------------------------------------------- diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -17,17 +17,16 @@ ) where import Control.DeepSeq -import qualified Control.Exception as E import Control.Lens import Data.Aeson.Types (Value) import Data.Hashable import qualified Data.Map as M +import Data.Maybe (fromMaybe) 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 @@ -40,7 +39,8 @@ import Data.ByteString (ByteString) import Data.Text.Utf16.Rope.Mixed (Rope) -import Development.IDE.Import.FindImports (ArtifactsLocation) +import Development.IDE.Import.FindImports (ArtifactsLocation, + ModuleToFilenames) import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics @@ -104,6 +104,9 @@ { linkableHomeMod :: !HomeModInfo , linkableHash :: !ByteString -- ^ The hash of the core file + , linkableVersion :: !ByteString + -- ^ Fingerprint of the core file and the versions of all transitive + -- dependencies, identifying the code the linkable links against } instance Show LinkableResult where @@ -180,7 +183,8 @@ tmrModSummary :: TcModuleResult -> ModSummary tmrModSummary = pm_mod_summary . tmrParsed -data HiFileResult = HiFileResult +-- | Everything a module contributes to its dependents' typechecking. +data ModIfaceResult = ModIfaceResult { hirModSummary :: !ModSummary -- Bang patterns here are important to stop the result retaining -- a reference to a typechecked module @@ -191,28 +195,38 @@ -- ^ Fingerprint for the ModIface , hirRuntimeModules :: !(ModuleEnv ByteString) -- ^ same as tmrRuntimeModules - , hirCoreFp :: !(Maybe (CoreFile, ByteString)) - -- ^ If we wrote a core file for this module, then its contents (lazily deserialised) - -- along with its hash } +data HiFileResult = HiFileResult + { hirIface :: !ModIfaceResult + , hirCoreFp :: !(Maybe ByteString) + -- ^ Hash of the core file, if written. + } + +-- | Content-address for a compiled module. This covers both +-- - the module's ABI, see 'hirIfaceFp' +-- - the serialized corefile for linkables, see 'hirCoreFp' +-- Changing either implies dependents of the module need to be updated. hiFileFingerPrint :: HiFileResult -> ByteString -hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> maybe "" snd hirCoreFp +hiFileFingerPrint HiFileResult{..} = hirIfaceFp hirIface <> fromMaybe "" hirCoreFp -mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult +mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe ByteString -> HiFileResult mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp = - E.assert (case hirCoreFp of - Just (CoreFile{cf_iface_hash}, _) -> getModuleHash hirModIface == cf_iface_hash - _ -> True) - HiFileResult{..} + HiFileResult{hirIface = ModIfaceResult{..}, ..} where hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes +instance NFData ModIfaceResult where + rnf = rwhnf + +instance Show ModIfaceResult where + show = show . hirModSummary + instance NFData HiFileResult where rnf = rwhnf instance Show HiFileResult where - show = show . hirModSummary + show = show . hirIface -- | Save the uncompressed AST here, we compress it just before writing to disk data HieAstResult @@ -290,9 +304,15 @@ -- This is an internal rule, use 'GetModIface' instead. type instance RuleResult GetModIfaceFromDiskAndIndex = HiFileResult --- | Get a module interface details, either from an interface file or a typechecked module -type instance RuleResult GetModIface = HiFileResult +-- | Get a module interface details, either from an interface file or a typechecked module. +type instance RuleResult GetModIface = ModIfaceResult +-- | Get a compiled module's interface and the core file hash. +type instance RuleResult GetModArtefacts = HiFileResult + +-- | Get a module's core file. Depend on this when you need generated code. +type instance RuleResult GetCoreFileHash = ByteString + -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. type instance RuleResult GetFileContents = (FileVersion, Maybe Rope) @@ -411,6 +431,8 @@ -- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult +type instance RuleResult GetModulesPaths = ModuleToFilenames + data GetParsedModule = GetParsedModule deriving (Eq, Show, Generic) instance Hashable GetParsedModule @@ -439,6 +461,16 @@ instance Hashable GetModuleGraph instance NFData GetModuleGraph +data GetModArtefacts = GetModArtefacts + deriving (Eq, Show, Generic) +instance Hashable GetModArtefacts +instance NFData GetModArtefacts + +data GetCoreFileHash = GetCoreFileHash + deriving (Eq, Show, Generic) +instance Hashable GetCoreFileHash +instance NFData GetCoreFileHash + data GetModuleGraphTransDepsFingerprints = GetModuleGraphTransDepsFingerprints deriving (Eq, Show, Generic) instance Hashable GetModuleGraphTransDepsFingerprints @@ -522,6 +554,13 @@ deriving (Eq, Show, Generic) instance Hashable GetModSummaryWithoutTimestamps instance NFData GetModSummaryWithoutTimestamps + +-- | Map from module name to paths, from scanning the session's import +-- directories. See Note [Session representatives]. +data GetModulesPaths = GetModulesPaths + deriving (Eq, Show, Generic) +instance Hashable GetModulesPaths +instance NFData GetModulesPaths data GetModSummary = GetModSummary deriving (Eq, Show, Generic) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -66,6 +66,7 @@ import Control.Exception.Safe import Control.Lens ((%~), (&), (.~)) import Control.Monad.Extra +import qualified Control.Monad.Extra as Extra import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.State @@ -86,7 +87,11 @@ import qualified Data.IntMap.Strict as IntMap import Data.IORef import Data.List +#if MIN_VERSION_ghc(9,13,0) import Data.List.Extra (nubOrd, nubOrdOn) +#else +import Data.List.Extra (nubOrdOn) +#endif import qualified Data.Map as M import Data.Maybe import Data.Proxy @@ -94,7 +99,6 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Utf16.Rope.Mixed as Rope import Data.Time (UTCTime (..)) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Tuple.Extra import Data.Typeable (cast) import Development.IDE.Core.Compile @@ -123,6 +127,7 @@ (nest, vcat) import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.GHC.CoreFile (readBinCoreFile) import Development.IDE.GHC.Error import Development.IDE.GHC.Util hiding (modifyDynFlags) @@ -141,11 +146,11 @@ import GHC.Iface.Ext.Utils (generateReferencesMap) import qualified GHC.LanguageExtensions as LangExt #if MIN_VERSION_ghc(9,13,0) -import GHC.Types.PkgQual (PkgQual (NoPkgQual)) import GHC.Types.Basic (ImportLevel (..)) -import GHC.Unit.Types (GenWithIsBoot(..)) +import GHC.Types.PkgQual (PkgQual (NoPkgQual)) import GHC.Unit.Module.Graph (mkModuleEdge) import GHC.Unit.Module.ModNodeKey (mnkModuleName) +import GHC.Unit.Types (GenWithIsBoot (..)) #endif import HIE.Bios.Ghc.Gap (hostIsDynamic) import qualified HieDb @@ -166,7 +171,8 @@ useProperty, usePropertyByPath) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), - PluginId, getVirtualFileFromVFS) + PluginId, + getVirtualFileFromVFS) import qualified Language.LSP.Protocol.Lens as JL import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) import Language.LSP.Protocol.Types (MessageType (MessageType_Info), @@ -179,8 +185,20 @@ import System.Info.Extra (isWindows) +import Data.Char (isUpper) +import qualified Data.HashSet as HS import qualified Data.IntMap as IM +import qualified Data.Map.Strict as Map import GHC.Fingerprint +import System.Directory.Extra (canonicalizePath, + doesDirectoryExist, + listContents) +import System.FilePath (dropExtension, + makeRelative, + normalise, + splitDirectories, + takeExtension, + takeFileName) data Log = LogShake Shake.Log @@ -320,37 +338,26 @@ getLocatedImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file - (KnownTargets targets) <- useNoFile_ GetKnownTargets #if MIN_VERSION_ghc(9,13,0) let imports = [(False, lvl, mbPkgName, modName) | (lvl, mbPkgName, modName) <- ms_textual_imps ms] - ++ [(True, NormalLevel, NoPkgQual, noLoc modName) | L _ modName <- ms_srcimps ms] + ++ [(True, NormalLevel, NoPkgQual, modName) | modName <- ms_srcimps ms] #else let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] #endif env_eq <- use_ GhcSession file let env = hscEnv env_eq - let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env + let hug_dflags = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env + let unit_visibility = Map.fromList $ map mkUnitVisibility hug_dflags let dflags = hsc_dflags env - opt <- getIdeOptions - let getTargetFor modName nfp - | Just (TargetFile nfp') <- HM.lookupKey (TargetFile nfp) targets = do - -- reuse the existing NormalizedFilePath in order to maximize sharing - itExists <- getFileExists nfp' - return $ if itExists then Just nfp' else Nothing - | Just tt <- HM.lookup (TargetModule modName) targets = do - -- reuse the existing NormalizedFilePath in order to maximize sharing - let nfp' = fromMaybe nfp $ HashSet.lookupElement nfp tt - itExists <- getFileExists nfp' - return $ if itExists then Just nfp' else Nothing - | otherwise = do - itExists <- getFileExists nfp - return $ if itExists then Just nfp else Nothing + + moduleMaps <- use_ GetModulesPaths file + #if MIN_VERSION_ghc(9,13,0) (diags, imports') <- fmap unzip $ forM imports $ \(isSource, _lvl, mbPkgName, modName) -> do #else (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do #endif - diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource + diagOrImp <- locateModule moduleMaps (hscSetFlags dflags env) unit_visibility modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path)) @@ -579,13 +586,14 @@ getDocMapRule :: Recorder (WithPriority Log) -> Rules () getDocMapRule recorder = define (cmapWithPrio LogShake recorder) $ \GetDocMap file -> do - -- Stale data for the scenario where a broken module has previously typechecked - -- but we never generated a DocMap for it - (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file - (hscEnv -> hsc, _) <- useWithStale_ GhcSessionDeps file - (HAR{refMap=rf}, _) <- useWithStale_ GetHieAst file - - dkMap <- liftIO $ mkDocMap hsc rf tc + (tmrTypechecked -> tc) <- use_ TypeCheck file + (hscEnv -> hsc) <- use_ GhcSessionDeps file + HAR{refMap=rf} <- use_ GetHieAst file + cfg <- getClientConfigAction + dkMap <- liftIO $ mkDocMap hsc rf tc $ LinkTargets + { linkSource = linkSourceTo cfg + , linkDoc = linkDocTo cfg + } return ([],Just dkMap) -- | Persistent rule to ensure that hover doesn't block on startup @@ -637,7 +645,9 @@ getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do - fs <- toKnownFiles <$> useNoFile_ GetKnownTargets + -- Only the files of the project: a file no component claims has no session to + -- be compiled in. See Note [Files that are not targets] + fs <- toTargetFiles <$> useNoFile_ GetKnownTargets dependencyInfoForFiles (HashSet.toList fs) #if MIN_VERSION_ghc(9,13,0) @@ -656,6 +666,94 @@ _ -> [NormalLevel] #endif +-- See Note [Session representatives] +getModulesPathsRule :: Recorder (WithPriority Log) -> Rules () +getModulesPathsRule recorder = + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModulesPaths file -> + use GhcSession file >>= \case + Nothing -> pure (Nothing, Nothing) + Just env_eq + | file == envRepresentative env_eq -> do + res <- computeModulesPaths env_eq + pure (Just (fingerprintToBS (mtfFingerprint res)), Just res) + | otherwise -> do + res <- use GetModulesPaths (envRepresentative env_eq) + pure (fingerprintToBS . mtfFingerprint <$> res, res) + +{- Note [Session representatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to compute `GetModulesPaths` only once, scanning every import +directory once per component rather than once per file. To do this, +we pick a session representative, that is guaranteed to have a non-error +GhcSession because it is a target location of this load. + +Then when we are asked for the ModulePaths of a file, we delegate to the +session representative instead (the session representative itself computes +the map). +-} + +-- | All the files below a directory. +-- If we cannot list a particular directory, then it doesn't contribute to the search +-- Also handles cyclic directory structures due to symlinks properly +listFilesRecursive :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +listFilesRecursive recurseInto = go [] + where + go ancestors dir = handle (\(_ :: IOException) -> pure []) $ do + canonical <- canonicalizePath dir + if canonical `elem` ancestors then pure [] else do + (dirs, files) <- Extra.partitionM doesDirectoryExist =<< listContents dir + below <- traverse (go (canonical : ancestors)) (filter recurseInto dirs) + pure $ files ++ concat below + +computeModulesPaths :: HscEnvEq -> Action ModuleToFilenames +computeModulesPaths env_eq = do + knownTargets <- useNoFile_ GetKnownTargets + opt <- getIdeOptions + let env = hscEnv env_eq + exts = optExtensions opt + acceptedExtensions = concatMap (\x -> ['.':x, '.':x <> "-boot"]) exts + -- Files known to HLS, whether or not they exist on disk yet + knownPaths = + [ (fromNormalizedFilePath p, p) | p <- HS.toList $ toKnownFiles knownTargets ] + + unit_maps <- forM (hugElts $ hsc_HUG env) $ \(u, hue) -> do + dir_maps <- forM (importPaths $ homeUnitEnv_dflags hue) $ \dir' -> do + let import_dir = normalise dir' + -- makeRelative gives back the path unchanged if it is not below + -- import_dir. Both paths are absolute, so this is unambiguous. + below f = let rel = makeRelative import_dir f + in if rel == f then Nothing else Just rel + toModule rel = mkModuleName $ intercalate "." $ + splitDirectories (dropExtension rel) + accepted f = takeExtension f `elem` acceptedExtensions + recurseInto path = case takeFileName path of + [] -> False + (x:_) -> isUpper x + firstWins = foldl' + (\acc (m, p) -> addToUniqMap_C (\old _ -> old) acc m p) emptyUniqMap + mkMaps fs = + let (boot, normal) = partition (("-boot" `isSuffixOf`) . fst) $ + filter (accepted . fst) fs + in ( firstWins [ (toModule rel, p) | (rel, p) <- normal ] + , HS.fromList (map snd boot) + ) + + scanned <- liftIO $ listFilesRecursive recurseInto import_dir + let (scanNormal, scanBoot) = mkMaps + [ (rel, toNormalizedFilePath' f) | f <- scanned, Just rel <- [below f] ] + (knownNormal, knownBoot) = mkMaps + [ (rel, p) | (f, p) <- knownPaths, Just rel <- [below f] ] + -- Known files win within a directory: they may exist only in the editor + pure (plusUniqMap_C const knownNormal scanNormal, HS.union knownBoot scanBoot) + -- The first import dir providing a module wins, matching GHC's -i order + let combineDirs = foldl' (plusUniqMap_C (\old _ -> old)) emptyUniqMap + pure (u, (combineDirs (map fst dir_maps), HS.unions (map snd dir_maps))) + + let providers u = mapUniqMap (\p -> pure (u, p)) + normal = foldl' (plusUniqMap_C (<>)) emptyUniqMap + [ providers u m | (u, (m, _)) <- unit_maps ] + pure $ mkModuleToFilenames normal (HS.unions [ b | (_, (_, b)) <- unit_maps ]) + dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) dependencyInfoForFiles fs = do (rawDepInfo, bm) <- rawDependencyInformation fs @@ -701,8 +799,15 @@ { getLinkables = unliftIO unlift . uses_ GetLinkable , getModuleGraph = unliftIO unlift $ useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph fp } + -- This 'setFileCacheHook' is neccessary to work correctly + -- with ghc plugins. + -- In particular, with plugins we load objects, and in doing so we consult the fileCacheHook to record the hash of the object. + -- + -- See issue https://github.com/haskell/haskell-language-server/issues/4675 for details + -- and https://github.com/ucsd-progsys/lh-plugin-demo for a reproducer. + hsc_env <- setFileCacheHook hsc addUsageDependencies $ liftIO $ - typecheckModule defer hsc dets pm + typecheckModule defer hsc_env dets pm where addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult) addUsageDependencies a = do @@ -733,7 +838,7 @@ [ B.encode (hash (sessionVersion res)) -- When the session version changes, reload all session -- hsc env sessions - , B.encode (show (sessionLoading config)) + , B.encode (show (componentsLoading config)) -- The loading config affects session loading. -- Invalidate all build nodes. -- Changing the session loading config will increment @@ -797,8 +902,17 @@ -- Fixes the bug in #4631 env = msrHscEnv msr depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps - ifaces <- uses_ GetModIface deps - let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces + needsCode <- uses_ NeedsCompilation deps + let (codeDeps, plainDeps) = partition (isJust . snd) (zip deps needsCode) + ifaces <- (++) <$> uses_ GetModIface (map fst codeDeps) + <*> (map hirIface <$> uses_ GetModArtefacts (map fst plainDeps)) + -- Load .hs-boot before .hs: the HPT is keyed by module name, and + -- GHC's addHomeModInfoToHpt overwrites, so the non-boot must be last. + let inLoadOrder = sortOn (not . isBootHmi) + $ map (\ModIfaceResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces + isBootHmi hmi = case mi_hsc_src (hm_iface hmi) of + HsBootFile -> True + _ -> False de <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file mg <- do if fullModuleGraph @@ -849,7 +963,7 @@ { source_version = ver , old_value = m_old , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} - , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs + , get_linkable_hashes = \fs -> uses_ GetCoreFileHash fs , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f , regenerate = regenerateHiFile session f ms } @@ -877,7 +991,7 @@ se@ShakeExtras{withHieDb} <- getShakeExtras -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db - let ms = hirModSummary x + let ms = hirModSummary (hirIface 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)) @@ -962,31 +1076,40 @@ define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True) getModIfaceRule :: Recorder (WithPriority Log) -> Rules () -getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do - fileOfInterest <- use_ IsFileOfInterest f - res <- case fileOfInterest of - IsFOI status -> do - -- Never load from disk for files of interest - tmr <- use_ TypeCheck f - linkableType <- getLinkableType f - hsc <- hscEnv <$> use_ GhcSessionDeps f - hsc' <- setFileCacheHook hsc - let compile = fmap ([],) $ use GenerateCore f - se <- getShakeExtras - (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr - let fp = hiFileFingerPrint <$> mbHiFile - hiDiags <- case mbHiFile of - Just hiFile - | OnDisk <- status - , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile - _ -> pure [] - return (fp, (diags++hiDiags, mbHiFile)) - NotFOI -> do - hiFile <- use GetModIfaceFromDiskAndIndex f - let fp = hiFileFingerPrint <$> hiFile - return (fp, ([], hiFile)) - - pure res +getModIfaceRule recorder = do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModArtefacts f -> do + fileOfInterest <- use_ IsFileOfInterest f + res <- case fileOfInterest of + IsFOI status -> do + -- Never load from disk for files of interest + tmr <- use_ TypeCheck f + linkableType <- getLinkableType f + hsc <- hscEnv <$> use_ GhcSessionDeps f + hsc' <- setFileCacheHook hsc + let compile = fmap ([],) $ use GenerateCore f + se <- getShakeExtras + (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr + let fp = hiFileFingerPrint <$> mbHiFile + hiDiags <- case mbHiFile of + Just hiFile + | OnDisk <- status + , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile + _ -> pure [] + return (fp, (diags++hiDiags, mbHiFile)) + NotFOI -> do + hiFile <- use GetModIfaceFromDiskAndIndex f + let fp = hiFileFingerPrint <$> hiFile + return (fp, ([], hiFile)) + pure res + -- Variants of `GetModArtefacts`, so dependents can be more precise in what + -- they require from a module. + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModIface file -> do + hir <- fmap hirIface <$> use GetModArtefacts file + return (hirIfaceFp <$> hir, hir) + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetCoreFileHash file -> do + hir <- use GetModArtefacts file + let h = hirCoreFp =<< hir + return (h, h) -- | Count of total times we asked GHC to recompile newtype RebuildCounter = RebuildCounter { getRebuildCountVar :: TVar Int } @@ -1111,35 +1234,79 @@ getLinkableRule :: Recorder (WithPriority Log) -> Rules () getLinkableRule recorder = - defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do - HiFileResult{hirModSummary, hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithOldValue $ \GetLinkable f old_value -> do + ModIfaceResult{hirModSummary, hirModIface, hirModDetails} <- use_ GetModIface f + mbCoreFp <- use GetCoreFileHash f let obj_file = ml_obj_file (ms_location hirModSummary) core_file = ml_core_file (ms_location hirModSummary) #if MIN_VERSION_ghc(9,11,0) mkLinkable t mod l = Linkable t mod (pure l) + setLinkableTime t (Linkable _ mod l) = Linkable t mod l dotO o = DotO o ModuleObject + keepLinkables t mod = + [ mkLinkable t mod (DotA "dummy") + , mkLinkable t mod (CoreBindings (error "keepLinkables: bytecode forced")) + ] #else mkLinkable t mod l = LM t mod [l] + setLinkableTime t (LM _ mod l) = LM t mod l dotO = DotO + -- An empty part list is treated as bytecode by isObjectLinkable + keepLinkables t mod = [mkLinkable t mod (DotA "dummy"), LM t mod []] #endif - case hirCoreFp of + case mbCoreFp of Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f - Just (bin_core, fileHash) -> do + Just fileHash -> do session <- use_ GhcSessionDeps f + -- The fast BCO path below reuses the old bytecode and never forces + -- this, so this serialised buffer isn't retained. + let readCore = readBinCoreFile (mkUpdater $ hsc_NC $ hscEnv session) core_file linkableType <- getLinkableType f >>= \case Nothing -> error $ "called GetLinkable for a file which doesn't need compilation: " ++ show f Just t -> pure t - -- Can't use `GetModificationTime` rule because the core file was possibly written in this - -- very session, so the results aren't reliable - core_t <- liftIO $ getModTime core_file + -- We need to depend on the linkables for all dependencies, so that + -- whenever a dependeny is relinked/reloaded, we unload the current linkable, because + -- the old version of the current linkable references the old dependency + -- + -- We get transitivity via induction + imports <- use_ GetLocatedImports f + let dep_files = [ artifactFilePath loc | (_, Just loc) <- imports, not (isBootLocation loc) ] + dep_comps <- uses_ NeedsCompilation dep_files + dep_versions <- map linkableVersion <$> uses_ GetLinkable [ d | (d, Just _) <- zip dep_files dep_comps ] + -- We compute a hash/identity for this linkable based on its hash + hash of dependencies + -- transitive dependencies are included by induction + version <- liftIO $ fingerprintFromByteString $ BS.concat (fileHash : dep_versions) + + -- GHC identifies linkables by UTCTime, we want to identify them by hash + -- Smuggle the hash into the UTCTime. + -- + -- Fine because GHC only checks the UTCTime for equality + let vfp@(LinkableFingerprint linkable_fp) = mkLinkableFingerprint version + let m_old_lr = case old_value of + Shake.Succeeded _ v -> Just v + Shake.Stale _ _ v -> Just v + Shake.Failed _ -> Nothing (warns, hmi) <- case linkableType of + -- Bytecode is a function of the core file alone, so if our core file + -- is unchanged we can reuse the old bytecode. Only its identity + -- changed, and it is relinked when it is next loaded. + BCOLinkable + | Just old_lr <- m_old_lr + , linkableHash old_lr == fileHash + , Just bc <- homeModInfoByteCode (linkableHomeMod old_lr) + -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justBytecode $ setLinkableTime linkable_fp bc)) -- Bytecode needs to be regenerated from the core file - BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t) + BCOLinkable -> liftIO $ do + (bin_core, _) <- readCore + coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core vfp -- Object code can be read from the disk ObjectLinkable -> do -- object file is up to date if it is newer than the core file -- Can't use a rule like 'GetModificationTime' or 'GetFileExists' because 'coreFileToLinkable' will write the object file, and -- thus bump its modification time, forcing this rule to be rerun every time. + -- Can't use `GetModificationTime` for the core file either, because it was + -- possibly written in this very session, so the results aren't reliable + core_t <- liftIO $ getModTime core_file exists <- liftIO $ doesFileExist obj_file mobj_time <- liftIO $ if exists @@ -1147,8 +1314,10 @@ else pure Nothing case mobj_time of Just obj_t - | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ mkLinkable (posixSecondsToUTCTime obj_t) (ms_mod hirModSummary) (dotO obj_file))) - _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (error "object doesn't have time") + | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ mkLinkable linkable_fp (ms_mod hirModSummary) (dotO obj_file))) + _ -> liftIO $ do + (bin_core, _) <- readCore + coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core vfp -- Record the linkable so we know not to unload it, and unload old versions whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi)) #if MIN_VERSION_ghc(9,11,0) @@ -1169,11 +1338,14 @@ --just before returning it to be loaded. This has a substantial effect on recompile --times as the number of loaded modules and splices increases. -- - --We use a dummy DotA linkable part to fake a NativeCode linkable. - --The unload function doesn't care about the exact linkable parts. - unload (hscEnv session) (map (\(mod', time') -> mkLinkable time' mod' (DotA "dummy")) $ moduleEnvToList to_keep) + --The keep list is split into native code and bytecode halves and loaded + --linkables only match entries of their own kind, hence one entry of each + --per module. unload only cares about the module and time, not the + --contents, therefore the dummies. + unload (hscEnv session) (concatMap (\(mod', time') -> keepLinkables time' mod') $ moduleEnvToList to_keep) return (to_keep, ()) - return (fileHash <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash)) + let versionBS = fingerprintToBS version + return (versionBS <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash <*> pure versionBS)) -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) @@ -1275,6 +1447,7 @@ getModIfaceRule recorder getModSummaryRule templateHaskellWarning recorder getModuleGraphRule recorder + getModulesPathsRule recorder getFileHashRule recorder knownFilesRule recorder getClientSettingsRule recorder diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -4,6 +4,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} @@ -24,7 +25,8 @@ module Development.IDE.Core.Shake( IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, - KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets, + KnownTargets(..), Target(..), toKnownFiles, toTargetFiles, unionKnownTargets, + mkKnownTargets, mkExtraKnownFiles, tombstoneKnownFiles, IdeRule, IdeResult, RestartQueue, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, @@ -53,6 +55,7 @@ HLS.getClientConfig, getPluginConfigAction, knownTargets, + updateKnownTargets, ideLogger, actionLogger, getVirtualFile, @@ -86,6 +89,9 @@ import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Extra hiding (bracket_) +#if MIN_VERSION_ghc(9,10,0) +import Control.Exception.Context (displayExceptionContext) +#endif import Control.Lens ((%~), (&), (?~)) import Control.Monad.Extra import Control.Monad.IO.Class @@ -108,8 +114,8 @@ import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.List.Extra (foldl', partition, - takeEnd) +import qualified Data.List as List +import Data.List.Extra (partition, takeEnd) import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.SortedList as SL @@ -223,10 +229,9 @@ hsep [ "Finished:" <+> pretty (actionName delayedAct) , "Took:" <+> pretty (showDuration seconds) ] - LogBuildSessionFinish e -> - vcat - [ "Finished build session" - , pretty (fmap displayException e) ] + LogBuildSessionFinish e -> case e of + Nothing -> "Finished build session" + Just e -> "Finished build session:" <+> prettyBuildSessionFinishException e LogDiagsDiffButNoLspEnv fileDiagnostics -> "updateFileDiagnostics published different from new diagnostics - file diagnostics:" <+> pretty (showDiagnosticsColored fileDiagnostics) @@ -452,7 +457,9 @@ Just env -> do config <- liftIO $ LSP.runLspT env HLS.getClientConfig return x{optCheckProject = pure $ checkProject config, - optCheckParents = pure $ checkParents config + optCheckParents = pure $ checkParents config, + optLinkSourceTo = linkSourceTo config, + optLinkDocTo = linkDocTo config } getIdeOptionsIO :: ShakeExtras -> IO IdeOptions @@ -640,6 +647,28 @@ ShakeExtras{knownTargetsVar} <- getShakeExtras liftIO $ readTVarIO knownTargetsVar +-- | Record files that appeared and disappeared, returning the keys to +-- invalidate. Must be called from the restart thread, +-- see Note [Serializing runs in separate thread]. +updateKnownTargets + :: ShakeExtras + -> [NormalizedFilePath] -- ^ appeared + -> [NormalizedFilePath] -- ^ disappeared + -> IO [Key] +updateKnownTargets ShakeExtras{knownTargetsVar} added removed + | null added && null removed = pure [] + | otherwise = atomically $ do + known <- readTVar knownTargetsVar + -- Registering a file the session loader already knows about would + -- rebuild everything derived from the targets for no gain. + -- See Note [Files that are not targets] + let addedSet = HSet.fromList added `HSet.difference` toKnownFiles (unhashed known) + known' = flip mapHashed known $ + tombstoneKnownFiles (HSet.fromList removed) addedSet + . unionKnownTargets (mkExtraKnownFiles addedSet) + writeTVar knownTargetsVar known' + pure [toNoFileKey GetKnownTargets | known /= known'] + -- | Seq the result stored in the Shake value. This only -- evaluates the value to WHNF not NF. We take care of the latter -- elsewhere and doing it twice is expensive. @@ -816,7 +845,7 @@ keys <- ioActionBetweenShakeSession -- it is every important to update the dirty keys after we enter the critical section -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> List.foldl' (flip insertKeySet) x keys res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras @@ -909,8 +938,9 @@ return $ do let exception = case res of - Left e -> Just e - _ -> Nothing + Left (fromException -> Just AsyncCancelled) -> Nothing + Left e -> Just e + _ -> Nothing logWith recorder Debug $ LogBuildSessionFinish exception -- Do the work in a background thread @@ -1196,7 +1226,11 @@ } | RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v)) --- | Define a new Rule with early cutoff +-- | Define a rule that can rerun without dirtying its dependents. +-- +-- A rerun normally prompts every dependent to rerun. Early cutoff content +-- addresses the result, so hls-graph reruns dependents only when the returned +-- fingerprint has changed. defineEarlyCutoff :: IdeRule k v => Recorder (WithPriority Log) @@ -1280,7 +1314,7 @@ (mbBs, (diags, mbRes)) <- actionCatch (do v <- action staleV; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do - pure (Nothing, ([ideErrorText file (T.pack $ show (key, file) ++ show e) | not $ isBadDependency e],Nothing)) + pure (Nothing, ([ideErrorText file (prettyRuleAbortedByException key file e) | not $ isBadDependency e],Nothing)) ver <- estimateFileVersionUnsafely key mbRes file (bs, res) <- case mbRes of @@ -1324,6 +1358,37 @@ -- * creating a dependency: If everything depends on GetModificationTime, we lose early cutoff -- * creating bogus "file does not exists" diagnostics | otherwise = useWithoutDependency (GetModificationTime_ False) fp + + prettyRuleAbortedByException key file e = T.pack $ unlines $ + [ "Rule execution aborted due to exception" + , "" + , "Rule: " <> show key + , "Target: " <> fromNormalizedFilePath file + , "Message: " <> show e + ] <> + [ unlines + [ "Context:" + , ctx + ] + | Just ctx <- [displayExcContext e] + ] + +displayExcContext :: SomeException -> Maybe String +displayExcContext (SomeException _exc) = +#if MIN_VERSION_ghc(9,10,0) + case displayExceptionContext ?exceptionContext of + "" -> Nothing + dc -> Just dc +#else + Just $ displayException (SomeException _exc) +#endif + +prettyBuildSessionFinishException :: SomeException -> Doc ann +prettyBuildSessionFinishException exc = case fromException exc of + Nothing -> case displayExcContext exc of + Nothing -> pretty (displayException exc) + Just ctx -> pretty ctx + Just AsyncCancelled -> viaShow AsyncCancelled -- We don't want to see the stack trace for a cancelled build session -- Note [Housekeeping rule cache and dirty key outside of hls-graph] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/src/Development/IDE/Core/Text.hs b/src/Development/IDE/Core/Text.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/Text.hs @@ -0,0 +1,19 @@ +module Development.IDE.Core.Text + ( takeLineRange + , lineAt + ) where + +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Text.Utf16.Rope.Mixed (Rope) +import qualified Data.Text.Utf16.Rope.Mixed as Rope + +-- | The lines of @rope@ over the 0-based inclusive line range @[from, to]@. +takeLineRange :: Word -> Word -> Rope -> [Text] +takeLineRange from to rope + | to < from = [] + | otherwise = Rope.lines $ fst $ Rope.splitAtLine (to - from + 1) $ snd $ Rope.splitAtLine from rope + +-- | The 0-based line @n@ of @rope@, if it has one. +lineAt :: Word -> Rope -> Maybe Text +lineAt n = listToMaybe . takeLineRange n n diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs --- a/src/Development/IDE/GHC/Compat/Core.hs +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -334,6 +334,7 @@ module GHC.Tc.Instance.Family, module GHC.Tc.Module, + module GHC.Tc.TyCl.Class, module GHC.Tc.Types, module GHC.Tc.Types.Evidence, module GHC.Tc.Utils.Env, @@ -445,6 +446,7 @@ import qualified GHC.Runtime.Interpreter as GHCi import GHC.Tc.Instance.Family import GHC.Tc.Module +import GHC.Tc.TyCl.Class import GHC.Tc.Types import GHC.Tc.Types.Evidence hiding ((<.>)) import GHC.Tc.Utils.Env @@ -565,17 +567,16 @@ import GHC.Hs (SrcSpanAnn') #endif +-- | Like GHC's, but never adds the boot suffix to the output paths itself. +-- GHC only started doing that in 9.13, so callers that want it apply +-- 'addBootSuffixLocnOut' on all versions. mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation #if MIN_VERSION_ghc(9,13,0) mkHomeModLocation df mn f = let (basename, ext) = FP.splitExtension f osBasename = unsafeEncodeUtf basename osExt = unsafeEncodeUtf ext - hscSrc = case ext of - ".hs-boot" -> HsBootFile - ".hsig" -> HsigFile - _ -> HsSrcFile - in pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn osBasename osExt hscSrc + in pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn osBasename osExt HsSrcFile #elif MIN_VERSION_ghc(9,11,0) mkHomeModLocation df mn f = let osf = unsafeEncodeUtf f diff --git a/src/Development/IDE/GHC/Compat/Error.hs b/src/Development/IDE/GHC/Compat/Error.hs --- a/src/Development/IDE/GHC/Compat/Error.hs +++ b/src/Development/IDE/GHC/Compat/Error.hs @@ -26,12 +26,14 @@ _TcRnMessageWithCtx, _GhcPsMessage, _GhcDsMessage, + _DsMessage, _GhcDriverMessage, _ReportHoleError, _TcRnIllegalWildcardInType, _TcRnPartialTypeSignatures, _TcRnMissingSignature, _TcRnSolverReport, + _TcRnUnusedTopBind, _TcRnMessageWithInfo, _TypeHole, _ConstraintHole, @@ -40,9 +42,11 @@ _MismatchMessage, _TypeEqMismatchActual, _TypeEqMismatchExpected, + _CouldNotDeducePred, ) where import Control.Lens +import qualified Data.List.NonEmpty as NE import Development.IDE.GHC.Compat (Type) import GHC.Driver.Errors.Types import GHC.HsToCore.Errors.Types @@ -77,11 +81,27 @@ GhcDsMessage dsMsg -> Just dsMsg _ -> Nothing) +_DsMessage :: Fold GhcMessage DsMessage +_DsMessage = prism' GhcDsMessage $ \case + GhcDsMessage dsmsg -> Just dsmsg + _ -> Nothing + _GhcDriverMessage :: Prism' GhcMessage DriverMessage _GhcDriverMessage = prism' GhcDriverMessage (\case GhcDriverMessage driverMsg -> Just driverMsg _ -> Nothing) +-- | Focus an unused top-level binding warning (@-Wunused-top-binds@). Structured +-- provenance for this only exists from GHC 9.8 (GHC #20115). +_TcRnUnusedTopBind :: Fold GhcMessage () +#if MIN_VERSION_ghc(9,8,0) +_TcRnUnusedTopBind = _TcRnMessage . folding (\case + TcRnUnusedName _ UnusedNameTopDecl -> Just () + _ -> Nothing) +#else +_TcRnUnusedTopBind = ignored +#endif + -- | Some 'TcRnMessage's are nested in other constructors for additional context. -- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'. -- However, in some occasions you don't need the additional context and you just want @@ -115,6 +135,16 @@ _MismatchMessage focus (Mismatch msg t a c) = (\msg' -> Mismatch msg' t a c) <$> focus msg _MismatchMessage focus (CannotUnifyVariable msg a) = flip CannotUnifyVariable a <$> focus msg _MismatchMessage _ report = pure report + +-- | Focus the missing constraint predicate for a @"Could not deduce ..."@ or +-- @"No instance for ..."@ error. +_CouldNotDeducePred :: Fold TcSolverReportMsg Type +_CouldNotDeducePred = folding $ \report -> case report of + CannotResolveInstance{cannotResolve_item = i} -> Just (errorItemPred i) + UnboundImplicitParams items -> Just (errorItemPred (NE.head items)) + _ -> case report ^? _MismatchMessage of + Just CouldNotDeduce{cnd_wanted = w} -> Just (errorItemPred (NE.head w)) + _ -> Nothing -- | Focus 'teq_mismatch_expected' from 'TypeEqMismatch'. _TypeEqMismatchExpected :: Traversal' MismatchMsg Type diff --git a/src/Development/IDE/GHC/Compat/Logger.hs b/src/Development/IDE/GHC/Compat/Logger.hs --- a/src/Development/IDE/GHC/Compat/Logger.hs +++ b/src/Development/IDE/GHC/Compat/Logger.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} --- | Compat module for GHC 9.2 Logger infrastructure. +-- | Compat module for logger infrastructure. module Development.IDE.GHC.Compat.Logger ( putLogHook, Logger.pushLogHook, diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -100,8 +100,6 @@ sty = mkUserStyle unqual AllTheWay doc' = pprWithUnitState emptyUnitState doc - - formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e = showSDoc dflags (pprNoLocMsgEnvelope e) diff --git a/src/Development/IDE/GHC/CoreFile.hs b/src/Development/IDE/GHC/CoreFile.hs --- a/src/Development/IDE/GHC/CoreFile.hs +++ b/src/Development/IDE/GHC/CoreFile.hs @@ -8,6 +8,7 @@ , codeGutsToCoreFile , typecheckCoreFile , readBinCoreFile + , readBinCoreFileHash , writeBinCoreFile , getImplicitBinds ) where @@ -54,8 +55,12 @@ readBinCoreFile name_cache fat_hi_path = do bh <- readBinMem fat_hi_path file <- getWithUserData name_cache bh - !fp <- Util.getFileHash fat_hi_path + !fp <- readBinCoreFileHash fat_hi_path return (file, fp) + +-- The fingerprint of a core file. +readBinCoreFileHash :: FilePath -> IO Fingerprint +readBinCoreFileHash = Util.getFileHash -- | Write a core file writeBinCoreFile :: DynFlags -> FilePath -> CoreFile -> IO Fingerprint diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -28,6 +28,7 @@ disableWarningsAsErrors, printOutputable, printOutputableOneLine, + printOutputableQualified, getExtensions, getExtensionsSet, stripOccNamePrefix, @@ -270,6 +271,10 @@ printOutputableOneLine :: Outputable a => a -> T.Text printOutputableOneLine = printOutputable' printWithoutUniquesOneLine + +printOutputableQualified :: Outputable a => PrintUnqualified -> a -> T.Text +printOutputableQualified ctx = + printOutputable' (printSDocQualifiedUnsafe ctx . ppr) printOutputable' :: Outputable a => (a -> String) -> a -> T.Text printOutputable' print = diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -53,7 +53,8 @@ warnings <- newVar [] let newAction :: DynFlags -> LogActionCompat newAction dynFlags logFlags wr _ loc prUnqual msg = do - let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) + let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) + $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) modifyVar_ warnings $ return . (wr_d:) newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env) res <- action $ \env -> putLogHook (newLogger env) env diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -53,7 +53,8 @@ import Development.IDE.GHC.Compat.Util (Fingerprint) import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Orphans () -import Development.IDE.Import.FindImports (ArtifactsLocation (..)) +import Development.IDE.Import.FindImports (ArtifactsLocation (..), + isBootLocation) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Generics (Generic) @@ -273,7 +274,25 @@ foldr (\(p, cs) res -> let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs)) in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges - reverseModuleMap = mkModuleEnv $ map (\(i,sm) -> (showableModule sm, FilePathId i)) $ IntMap.toList rawModuleMap + -- Map 'Module' to 'FilePathId'. A 'Module' does not distinguish boot + -- from non-boot, so a real source file and its hs-boot share the same + -- key. We list boot entries first and non-boot entries second so that + -- 'mkModuleEnv' (right-biased on duplicates) makes the non-boot entry + -- win: callers like the 'GetLinkable' rule (via 'lookupModuleFile') + -- need the non-boot file because hs-boot files don't have linkables. + -- + -- XXX: It's unclear whether this code can be called in a situation + -- where a module ONLY has a boot module. If that situation + -- can't occur, the snippet below can be simplified to simply + -- filter all boot entries. + (bootEntries, srcEntries) = partitionEithers + [ if isBootLocation al + then Left (showableModule sm, FilePathId i) + else Right (showableModule sm, FilePathId i) + | (i, sm) <- IntMap.toList rawModuleMap + , Just al <- [IntMap.lookup i (idToPathMap rawPathIdMap)] + ] + reverseModuleMap = mkModuleEnv (bootEntries ++ srcEntries) -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows: @@ -347,11 +366,11 @@ return $ map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty)) where go :: Int -> IntSet -> IntSet - go k i = + go k visited = let outwards = IntMap.findWithDefault IntSet.empty k depReverseModuleDeps - res = IntSet.union i outwards - new = IntSet.difference i outwards - in IntSet.foldr go res new + visited' = IntSet.union visited outwards + new = IntSet.difference outwards visited + in IntSet.foldr go visited' new -- | Immediate reverse dependencies of a file immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath] diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -1,36 +1,47 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NamedFieldPuns #-} module Development.IDE.Import.FindImports ( locateModule - , locateModuleFile , Import(..) , ArtifactsLocation(..) , modSummaryToArtifactsLocation , isBootLocation - , mkImportDirs + , ModuleToFilenames(..) + , mkModuleToFilenames + , mkUnitVisibility ) where import Control.DeepSeq -import Control.Monad.Extra import Control.Monad.IO.Class -import Data.List (find, isSuffixOf) -import Data.Maybe +import qualified Data.HashSet as HS +import Data.List (intercalate, isSuffixOf, + sort, sortOn) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import qualified Data.Set as S import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Error as ErrUtils import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location +import GHC.Fingerprint +import GHC.Generics import GHC.Types.PkgQual -import GHC.Unit.State -import System.FilePath +import GHC.Unit #if MIN_VERSION_ghc(9,11,0) -import GHC.Driver.DynFlags +import GHC.Driver.DynFlags (ReexportedModule (..), + hiddenModules) +#else +import GHC.Driver.Session (hiddenModules) #endif data Import @@ -41,7 +52,8 @@ data ArtifactsLocation = ArtifactsLocation { artifactFilePath :: !NormalizedFilePath , artifactModLocation :: !(Maybe ModLocation) - , artifactIsSource :: !Bool -- ^ True if a module is a source input + , artifactIsSource :: !Bool -- ^ 'True' for a real Haskell source file ('HsSrcFile'); + -- 'False' for a boot ('HsBootFile') or signature ('HsigFile') file. , artifactModule :: !(Maybe Module) } deriving Show @@ -65,99 +77,161 @@ Just modSum -> isSource (ms_hsc_src modSum) mbMod = ms_mod <$> ms +-- | For each module name, the units that provide it and the exact location +-- where the unit has it. +-- see 'locateModuleFile' for how we decide which unit an import actually +-- resolves to. +data ModuleToFilenames = ModuleToFilenames { + -- | Modules and the unit, source pairs they correspond to + moduleMap :: UniqMap ModuleName (NonEmpty (UnitId, NormalizedFilePath)), + -- | Boot files we know exist. If you want to check if a boot file exists, + -- check this field for precisely the -boot file corresponding to the non-boot + -- file you have already resolved. + bootFiles :: HS.HashSet NormalizedFilePath, + -- | Fingerprint of the two, for early cutoff + mtfFingerprint :: !Fingerprint +} + deriving Generic + +-- | The fingerprint is strict and computing it forces the map and the set, so +-- there is nothing left to force. Deep forcing here would traverse them again +-- for every file of the session. +instance NFData ModuleToFilenames where + rnf = rwhnf + +instance Show ModuleToFilenames where + show mtf = "ModuleToFilenames " ++ show (mtfFingerprint mtf) + +mkModuleToFilenames + :: UniqMap ModuleName (NonEmpty (UnitId, NormalizedFilePath)) + -> HS.HashSet NormalizedFilePath + -> ModuleToFilenames +mkModuleToFilenames normal boots = + ModuleToFilenames normal boots (fingerprintFingerprints [fpMap normal, fpSet boots]) + where + fpMap m = fingerprintFingerprints + [ fingerprintString $ intercalate "\0" $ + moduleNameString mn : + concat [ [unitIdString u, fromNormalizedFilePath p] | (u, p) <- NE.toList provs ] + | (mn, provs) <- sortOn (moduleNameString . fst) (nonDetEltsUFM (getUniqMap m)) + ] + fpSet s = fingerprintString $ intercalate "\0" $ + sort $ map fromNormalizedFilePath $ HS.toList s + data LocateResult = LocateNotFound - | LocateFoundReexport UnitId + | LocateFoundReexport UnitId ModuleName + -- ^ The unit reexporting the module, and the name it has there | LocateFoundFile UnitId NormalizedFilePath --- | locate a module in the file system. Where we go from *daml to Haskell -locateModuleFile :: MonadIO m - => [(UnitId, [FilePath], S.Set ModuleName)] - -> [String] - -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) - -> Bool - -> ModuleName - -> m LocateResult -locateModuleFile import_dirss exts targetFor isSource modName = do - let candidates import_dirs = - [ toNormalizedFilePath' (prefix moduleNameSlashes modName <.> maybeBoot ext) - | prefix <- import_dirs , ext <- exts] - mf <- firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs, _) <- import_dirss]) - case mf of - Nothing -> - case find (\(_ , _, reexports) -> S.member modName reexports) import_dirss of - Just (uid,_,_) -> pure $ LocateFoundReexport uid - Nothing -> pure LocateNotFound - Just (uid,file) -> pure $ LocateFoundFile uid file - where - go (uid, candidate) = fmap ((uid,) <$>) $ targetFor modName candidate - maybeBoot ext - | isSource = ext ++ "-boot" - | otherwise = ext +-- | What a home unit exposes to the units depending on it. +data UnitVisibility = UnitVisibility + { uvReexports :: Map ModuleName ModuleName + -- ^ The name we import it under, and the name it has in the unit it is + -- reexported from + , uvHidden :: S.Set ModuleName + } --- | This function is used to map a package name to a set of import paths. --- It only returns Just for unit-ids which are possible to import into the --- current module. In particular, it will return Nothing for 'main' components --- as they can never be imported into another package. -mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, ([FilePath], S.Set ModuleName)) +-- | What a home unit exposes, from its flags. +mkUnitVisibility :: (UnitId, DynFlags) -> (UnitId, UnitVisibility) +mkUnitVisibility (i, flags) = (i, UnitVisibility reexports (hiddenModules flags)) + where #if MIN_VERSION_ghc(9,11,0) -mkImportDirs _env (i, flags) = Just (i, (importPaths flags, S.fromList $ map reexportTo $ reexportedModules flags)) + -- Earlier entries win, as in 'GHC.Driver.Config.Finder.initFinderOpts' + reexports = Map.fromList + [ (reexportTo r, reexportFrom r) | r <- reverse (reexportedModules flags) ] #else -mkImportDirs _env (i, flags) = Just (i, (importPaths flags, reexportedModules flags)) + reexports = Map.fromSet id (reexportedModules flags) #endif +-- | Locate a module in the file system. +-- +-- We go through the units in the given order and do exactly what GHC's finder +-- does: if the unit reexports the module we start again from that unit, if it +-- hides the module we skip it, and otherwise it provides the module if it has +-- a file for it. A unit that is not in the list is not visible to the importer. +locateModuleFile + :: ModuleToFilenames + -> ModuleName + -> [(UnitId, Maybe UnitVisibility)] + -- ^ Units to search, in priority order. 'Nothing' for the importing unit, + -- whose own reexports and hidden modules do not apply to it. + -> LocateResult +locateModuleFile ModuleToFilenames{moduleMap} modName = go + where + providers = maybe [] NE.toList $ lookupUniqMap moduleMap modName + + go [] = LocateNotFound + go ((uid, mbVisibility) : units) + | Just vis <- mbVisibility + , Just realName <- Map.lookup modName (uvReexports vis) + = LocateFoundReexport uid realName + | Just vis <- mbVisibility + , modName `S.member` uvHidden vis + = go units + | Just file <- lookup uid providers + = LocateFoundFile uid file + | otherwise + = go units + -- | locate a module in either the file system or the package database. Where we go from *daml to -- Haskell locateModule :: MonadIO m - => HscEnv - -> [(UnitId, DynFlags)] -- ^ Import directories - -> [String] -- ^ File extensions - -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate + => ModuleToFilenames + -> HscEnv + -> Map UnitId UnitVisibility -- ^ What each home unit exposes -> Located ModuleName -- ^ Module name -> PkgQual -- ^ Package name -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import) -locateModule env comp_info exts targetFor modName mbPkgName isSource = do +locateModule moduleMaps env unit_visibility modName mbPkgName isSource = do case mbPkgName of -- 'ThisPkg' just means some home module, not the current unit + -- A home unit qualifier is not a package, so the package database is not + -- consulted when the module is not in that unit ThisPkg uid - | Just (dirs, reexports) <- lookup uid import_paths - -> lookupLocal uid dirs reexports - | otherwise -> return $ Left $ notFoundErr env modName $ LookupNotFound [] + | uid == homeUnitId_ dflags -> lookupIn moduleNotFound [(uid, Nothing)] + | Just vis <- Map.lookup uid unit_visibility -> lookupIn moduleNotFound [(uid, Just vis)] + | otherwise -> moduleNotFound -- if a package name is given we only go look for a package OtherPkg uid - | Just (dirs, reexports) <- lookup uid import_paths - -> lookupLocal uid dirs reexports + | Just vis <- Map.lookup uid unit_visibility -> lookupIn lookupInPackageDB [(uid, Just vis)] | otherwise -> lookupInPackageDB - NoPkgQual -> do - - -- Reexports for current unit have to be empty because they only apply to other units depending on the - -- current unit. If we set the reexports to be the actual reexports then we risk looping forever trying - -- to find the module from the perspective of the current unit. - mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags, S.empty) : other_imports) exts targetFor isSource $ unLoc modName - case mbFile of - LocateNotFound -> lookupInPackageDB - -- Lookup again with the perspective of the unit reexporting the file - LocateFoundReexport uid -> locateModule (hscSetActiveUnitId uid env) comp_info exts targetFor modName noPkgQual isSource - LocateFoundFile uid file -> toModLocation uid file + NoPkgQual -> lookupIn lookupInPackageDB searchUnits where dflags = hsc_dflags env - import_paths = mapMaybe (mkImportDirs env) comp_info - other_imports = - -- Instead of bringing all the units into scope, only bring into scope the units - -- this one depends on. - -- This way if you have multiple units with the same module names, we won't get confused - -- For example if unit a imports module M from unit B, when there is also a module M in unit C, - -- and unit a only depends on unit b, without this logic there is the potential to get confused - -- about which module unit a imports. - -- Without multi-component support it is hard to recontruct the dependency environment so - -- unit a will have both unit b and unit c in scope. -#if MIN_VERSION_ghc(9,11,0) - map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, S.fromList $ map reexportTo $ reexportedModules this_df)) hpt_deps -#else - map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, reexportedModules this_df)) hpt_deps -#endif + + moduleNotFound = return $ Left $ notFoundErr env modName $ LookupNotFound [] + + lookupIn onNotFound units = + case locateModuleFile moduleMaps (unLoc modName) units of + LocateNotFound -> onNotFound + -- Look again from the perspective of the unit reexporting the module, + -- under the name it has there + LocateFoundReexport uid realName -> + locateModule moduleMaps (hscSetActiveUnitId uid env) unit_visibility + (const realName <$> modName) noPkgQual isSource + LocateFoundFile uid file + -- The search only ever finds source files. A SOURCE import takes the + -- boot file next to the source file we found, and fails if there is + -- none, we do not go looking anywhere else. + | isSource -> maybe moduleNotFound (toModLocation uid) (bootFile file) + | otherwise -> toModLocation uid file + + bootFile file + | boot `HS.member` bootFiles moduleMaps = Just boot + | otherwise = Nothing + where boot = toNormalizedFilePath' $ fromNormalizedFilePath file <> "-boot" + + -- The units an unqualified import may come from: the current unit first, + -- then its dependencies, in the given order, which decides who wins when + -- several provide the module. + -- The current unit's own reexports and hidden modules do not apply to it, + -- which also stops the reexport search from looping. + searchUnits = (homeUnitId_ dflags, Nothing) : + [ (uid, Map.lookup uid unit_visibility) | uid <- hpt_deps ] + ue = hsc_unit_env env units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue hpt_deps :: [UnitId] @@ -166,15 +240,8 @@ toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes - return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just genMod) - - lookupLocal uid dirs reexports = do - mbFile <- locateModuleFile [(uid, dirs, reexports)] exts targetFor isSource $ unLoc modName - case mbFile of - LocateNotFound -> return $ Left $ notFoundErr env modName $ LookupNotFound [] - -- Lookup again with the perspective of the unit reexporting the file - LocateFoundReexport uid' -> locateModule (hscSetActiveUnitId uid' env) comp_info exts targetFor modName noPkgQual isSource - LocateFoundFile uid' file -> toModLocation uid' file + loc' = if isSource then addBootSuffixLocnOut loc else loc + return $ Right $ FileImport $ ArtifactsLocation file (Just loc') (not isSource) (Just genMod) lookupInPackageDB = do case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -21,7 +21,8 @@ import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as S import qualified Data.Text as Text -import Development.IDE.Core.FileExists (modifyFileExists, +import Development.IDE.Core.FileExists (allExtensions, + modifyFileExists, watchedGlobs) import Development.IDE.Core.FileStore (registerFileWatches, resetFileStore, @@ -37,6 +38,8 @@ import Ide.Logger import Ide.Types import Numeric.Natural +import System.Directory (doesFileExist) +import System.FilePath (takeExtension) data Log = LogShake Shake.Log @@ -71,8 +74,11 @@ whenUriFile _uri $ \file -> do -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ - addFileOfInterest ide file Modified{firstOpen=True} + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ do + -- An unsaved file is not on disk, so the session loader never saw + -- it. Register it so imports of it can be resolved. + ks <- updateKnownTargets (shakeExtras ide) [file] [] + (<> ks) <$> addFileOfInterest ide file Modified{firstOpen=True} logWith recorder Debug $ LogOpenedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ @@ -94,9 +100,13 @@ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do let msg = "Closed text document: " <> getUri _uri + -- A file that was only ever open in the editor stops existing + -- when it is closed + onDisk <- doesFileExist (fromNormalizedFilePath file) setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do scheduleGarbageCollection ide - deleteFileOfInterest ide file + ks <- updateKnownTargets (shakeExtras ide) [] [file | not onDisk] + (<> ks) <$> deleteFileOfInterest ide file logWith recorder Debug $ LogClosedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $ @@ -115,10 +125,17 @@ unless (null fileEvents') $ do let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) + exts <- allExtensions <$> getIdeOptionsIO (shakeExtras ide) + let sourceFiles c = + [ nfp | (nfp, c') <- fileEvents', c' == c + , takeExtension (fromNormalizedFilePath nfp) `elem` map ('.':) exts ] setSomethingModified (VFSModified vfs) ide msg $ do ks1 <- resetFileStore ide fileEvents' ks2 <- modifyFileExists ide fileEvents' - return (ks1 <> ks2) + ks3 <- updateKnownTargets (shakeExtras ide) + (sourceFiles FileChangeType_Created) + (sourceFiles FileChangeType_Deleted) + return (ks1 <> ks2 <> ks3) , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -111,6 +111,7 @@ PluginDescriptor (PluginDescriptor, pluginCli), PluginId (PluginId), ipMap, pluginId) +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Numeric.Natural (Natural) import Options.Applicative hiding (action) @@ -300,7 +301,29 @@ let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin - options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands } + options = + argsLspOptions + { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands + , LSP.optWorkspaceWillRenameFileOperationRegistrationOptions = fileModificationOptions + , LSP.optWorkspaceDidRenameFileOperationRegistrationOptions = fileModificationOptions + , LSP.optWorkspaceWillDeleteFileOperationRegistrationOptions = fileModificationOptions + , LSP.optWorkspaceDidDeleteFileOperationRegistrationOptions = fileModificationOptions + , LSP.optWorkspaceWillCreateFileOperationRegistrationOptions = fileModificationOptions + , LSP.optWorkspaceDidCreateFileOperationRegistrationOptions = fileModificationOptions + } + fileModificationOptions = + Just $ + LSP.FileOperationRegistrationOptions + [ LSP.FileOperationFilter + { _scheme = Just "file" + , _pattern = + LSP.FileOperationPattern + { _glob = "**/*.hs" + , _matches = Just LSP.FileOperationPatternKind_File + , _options = Nothing + } + } + ] argsParseConfig = getConfigFromNotification argsHlsPlugins rules = do argsRules diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -56,6 +56,8 @@ import qualified Ide.Plugin.Config as Config +import Development.IDE.Types.Options (LinkTargets (..), + linkTargets) import qualified GHC.LanguageExtensions as LangExt data Log = LogShake Shake.Log deriving Show @@ -136,7 +138,9 @@ Nothing -> (mempty, mempty) doc <- case lookupNameEnv dm name of Just doc -> pure $ spanDocToMarkdown doc - Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name + Nothing -> liftIO $ do + ltgts <- linkTargets <$> getIdeOptionsIO (shakeExtras ide) + spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) ltgts name typ <- case lookupNameEnv km name of _ | not needType -> pure Nothing Just ty -> pure (safeTyThingType True ty) diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -40,6 +40,7 @@ import Data.Ord (Down (Down)) import qualified Data.Set as Set import Development.IDE.Core.PositionMapping +import Development.IDE.Core.Text (lineAt) import Development.IDE.GHC.Compat hiding (isQual, ppr) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util @@ -876,8 +877,7 @@ lastMaybe = headMaybe . reverse -- grab the entire line the cursor is at - curLine <- headMaybe $ Rope.lines - $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext + curLine <- lineAt (fromIntegral l) ropetext let beforePos = T.take (fromIntegral c) curLine -- the word getting typed, after previous space and before cursor curWord <- diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -25,7 +25,8 @@ ) where -import GHC.Data.FastString (lengthFS) +import GHC.Data.FastString (LexicalFastString (..), + lengthFS) import qualified GHC.Utils.Outputable as O import Development.IDE.GHC.Error @@ -50,7 +51,6 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe -import Data.Coerce (coerce) import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as M import Data.Maybe @@ -669,18 +669,8 @@ pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] pointCommand hf pos k = - M.elems $ flip M.mapMaybeWithKey (getAsts hf) $ \fs ast -> - -- Since GHC 9.2: - -- getAsts :: Map HiePath (HieAst a) - -- type HiePath = LexicalFastString - -- - -- but before: - -- getAsts :: Map HiePath (HieAst a) - -- type HiePath = FastString - -- - -- 'coerce' here to avoid an additional function for maintaining - -- backwards compatibility. - case selectSmallestContaining (sp $ coerce fs) ast of + M.elems $ flip M.mapMaybeWithKey (getAsts hf) $ \(LexicalFastString fs) ast -> + case selectSmallestContaining (sp fs) ast of Nothing -> Nothing Just ast' -> Just $ k ast' where diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -22,6 +22,7 @@ import Data.Maybe import qualified Data.Set as S import qualified Data.Text as T +import Data.Version (showVersion) import Development.IDE.Core.Compile import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat @@ -29,8 +30,12 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Spans.Common +import Development.IDE.Types.Options (LinkTargets (..)) import GHC.Iface.Ext.Utils (RefMap) -import Language.LSP.Protocol.Types (filePathToUri, getUri) +import GHC.Plugins (GenericUnitInfo (unitPackageName)) +import Ide.Types (OptLinkTo (..)) +import Language.LSP.Protocol.Types (Uri (..), filePathToUri, + getUri) import Prelude hiding (mod) import System.Directory import System.FilePath @@ -40,8 +45,9 @@ :: HscEnv -> RefMap a -> TcGblEnv + -> LinkTargets -> IO DocAndTyThingMap -mkDocMap env rm this_mod = +mkDocMap env rm this_mod linkTgts = do (Just Docs{docs_decls = UniqMap this_docs, docs_args = UniqMap this_arg_docs}) <- extractDocs (hsc_dflags env) this_mod d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names @@ -52,7 +58,7 @@ getDocs n nameMap | maybe True (mod ==) $ nameModule_maybe n = pure nameMap -- we already have the docs in this_docs, or they do not exist | otherwise = do - (doc, _argDoc) <- getDocumentationTryGhc env n + (doc, _argDoc) <- getDocumentationTryGhc env linkTgts n pure $ extendNameEnv nameMap n doc getType n nameMap | Nothing <- lookupNameEnv nameMap n @@ -62,7 +68,7 @@ getArgDocs n nameMap | maybe True (mod ==) $ nameModule_maybe n = pure nameMap | otherwise = do - (_doc, argDoc) <- getDocumentationTryGhc env n + (_doc, argDoc) <- getDocumentationTryGhc env linkTgts n pure $ extendNameEnv nameMap n argDoc names = rights $ S.toList idents idents = M.keysSet rm @@ -72,13 +78,13 @@ lookupKind env = fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env -getDocumentationTryGhc :: HscEnv -> Name -> IO (SpanDoc, IntMap SpanDoc) -getDocumentationTryGhc env n = - (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env [n]) +getDocumentationTryGhc :: HscEnv -> LinkTargets -> Name -> IO (SpanDoc, IntMap SpanDoc) +getDocumentationTryGhc env l2h n = + (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env l2h [n]) `catch` (\(_ :: IOEnvFailure) -> pure (emptySpanDoc, mempty)) -getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)] -getDocumentationsTryGhc env names = do +getDocumentationsTryGhc :: HscEnv -> LinkTargets -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)] +getDocumentationsTryGhc env linkTgts names = do resOr <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names case resOr of Left _ -> return [] @@ -95,10 +101,20 @@ (docFu, srcFu) <- case nameModule_maybe name of Just mod -> liftIO $ do - doc <- toFileUriText $ lookupDocHtmlForModule env mod - src <- toFileUriText $ lookupSrcHtmlForModule env mod - return (doc, src) + doc <- lookupDocHtmlForModule env mod + src <- lookupSrcHtmlForModule env mod + -- If found, the local files are used as hints for the hackage links, this helps with symbols defined in an internal module but re-exported by another. + let + LinkTargets{linkDoc,linkSource} = linkTgts + doc_link = case linkDoc of + LinkToHackage -> toHackageDocUriText env mod (takeFileName <$> doc) + LinkToLocal -> toFileUriText doc + src_link = case linkSource of + LinkToHackage -> toHackageSrcUriText env mod (takeFileName <$> src) + LinkToLocal -> toFileUriText src + pure (doc_link, src_link) Nothing -> pure (Nothing, Nothing) + let docUri = (<> "#" <> selector <> printOutputable name) <$> docFu srcUri = (<> "#" <> printOutputable name) <$> srcFu selector @@ -106,7 +122,21 @@ | otherwise = "t:" return $ SpanDocUris docUri srcUri - toFileUriText = (fmap . fmap) (getUri . filePathToUri) + toFileUriText = fmap (getUri . filePathToUri) + toHackageUriText subdir sep env mod hint = do + ui <- lookupUnit env (moduleUnit mod) + let htmlFile = case hint of + Nothing -> T.intercalate sep (map T.pack $ moduleNameChunks mod) <> ".html" + Just foundFile -> T.replace "-" sep $ T.pack foundFile + pure $! + mconcat $ + [ "https://hackage.haskell.org/package/" + , printOutputable (unitPackageName ui), "-", T.pack $ showVersion (unitPackageVersion ui), "/" + , subdir , "/" + , htmlFile + ] + toHackageDocUriText mod = toHackageUriText "docs" "-" mod + toHackageSrcUriText mod = toHackageUriText "docs/src" "." mod getDocumentation :: HasSrcSpan name @@ -146,9 +176,12 @@ -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. mns = do - chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m + chunks <- (reverse . drop1 . inits) $ moduleNameChunks m -- The file might use "." or "-" as separator map (`intercalate` chunks) [".", "-"] + +moduleNameChunks :: Module -> [String] +moduleNameChunks m = splitOn "." $ (moduleNameString . moduleName) m lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath] lookupHtmls df ui = diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -164,7 +164,7 @@ in ideErrorFromLspDiag lspDiagnostic fdFilePath origMsg --- | Defines whether a particular diagnostic should be reported +-- | Defines whether a particular diagnostic should be reported -- back to the user. -- -- One important use case is "missing signature" code lenses, diff --git a/src/Development/IDE/Types/HscEnvEq.hs b/src/Development/IDE/Types/HscEnvEq.hs --- a/src/Development/IDE/Types/HscEnvEq.hs +++ b/src/Development/IDE/Types/HscEnvEq.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module Development.IDE.Types.HscEnvEq ( HscEnvEq, - hscEnv, newHscEnvEq, + hscEnv, newHscEnvEq, envRepresentative, updateHscEnvEq, envPackageExports, envVisibleModuleNames, @@ -12,6 +12,7 @@ import Control.Concurrent.Strict (modifyVar, newVar) import Control.DeepSeq (force, rwhnf) import Control.Exception (evaluate, mask, throwIO) +import qualified Control.Exception as Exc import Control.Monad.Extra (eitherM, join, mapMaybeM) import Data.Either (fromRight) import Data.IORef @@ -23,6 +24,7 @@ import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import Development.IDE.Types.Location (NormalizedFilePath) import GHC.Driver.Env (hsc_all_home_unit_ids) import OpenTelemetry.Eventlog (withSpan) @@ -39,6 +41,8 @@ -- 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 + , envRepresentative :: !NormalizedFilePath + -- ^ See Note [Session representatives] } updateHscEnvEq :: HscEnvEq -> HscEnv -> IO HscEnvEq @@ -47,8 +51,8 @@ update <$> Unique.newUnique -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: HscEnv -> IO HscEnvEq -newHscEnvEq hscEnv' = do +newHscEnvEq :: NormalizedFilePath -> HscEnv -> IO HscEnvEq +newHscEnvEq envRepresentative hscEnv' = do mod_cache <- newIORef emptyInstalledModuleEnv -- This finder cache is for things which are outside of things which are tracked @@ -56,14 +60,14 @@ #if MIN_VERSION_ghc(9,11,0) let hscEnv = hscEnv' { hsc_FC = FinderCache - { flushFinderCaches = \_ -> error "GHC should never call flushFinderCaches outside the driver" + { flushFinderCaches = \_ -> throwIO $ Exc.ErrorCall "flushFinderCaches: GHC should never call flushFinderCaches outside the driver" #if MIN_VERSION_ghc(9,13,0) , addToFinderCache = \im val -> do #else , addToFinderCache = \(GWIB im _) val -> do #endif if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv' - then error "tried to add home module to FC" + then throwIO $ Exc.ErrorCall "addToFinderCache: tried to add home module to FC" else atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleEnv c im val, ()) #if MIN_VERSION_ghc(9,13,0) , lookupFinderCache = \im -> do @@ -71,9 +75,9 @@ , lookupFinderCache = \(GWIB im _) -> do #endif if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv' - then error ("tried to lookup home module from FC" ++ showSDocUnsafe (ppr (im, hsc_all_home_unit_ids hscEnv'))) + then throwIO $ Exc.ErrorCall ("lookupFinderCache: tried to lookup home module from FC: " ++ showSDocUnsafe (ppr (im, hsc_all_home_unit_ids hscEnv'))) else lookupInstalledModuleEnv <$> readIORef mod_cache <*> pure im - , lookupFileCache = \fp -> error ("not used by HLS" ++ fp) + , lookupFileCache = \fp -> throwIO $ Exc.ErrorCall ("lookupFileCache: Called without using setFileCacheHook for target: " ++ fp) } } @@ -128,9 +132,9 @@ a == b = envUnique a == envUnique b instance NFData HscEnvEq where - rnf (HscEnvEq a b _ _) = + rnf (HscEnvEq a b _ _ e) = -- deliberately skip the package exports map and visible module names - rnf (Unique.hashUnique a) `seq` rwhnf b + rnf (Unique.hashUnique a) `seq` rwhnf b `seq` rnf e instance Hashable HscEnvEq where hashWithSalt s = hashWithSalt s . envUnique diff --git a/src/Development/IDE/Types/KnownTargets.hs b/src/Development/IDE/Types/KnownTargets.hs --- a/src/Development/IDE/Types/KnownTargets.hs +++ b/src/Development/IDE/Types/KnownTargets.hs @@ -3,9 +3,12 @@ module Development.IDE.Types.KnownTargets ( KnownTargets(..) , emptyKnownTargets , mkKnownTargets + , mkExtraKnownFiles , unionKnownTargets + , tombstoneKnownFiles , Target(..) - , toKnownFiles) where + , toKnownFiles + , toTargetFiles) where import Control.DeepSeq import Data.Hashable @@ -18,34 +21,96 @@ import Development.IDE.Types.Location import GHC.Generics --- | A mapping of module name to known files -newtype KnownTargets = KnownTargets - { targetMap :: (HashMap Target (HashSet NormalizedFilePath)) } +-- | What HLS knows about the files of the workspace +data KnownTargets = KnownTargets + { targetMap :: !(HashMap Target (HashSet NormalizedFilePath)) + -- ^ What the session loader discovered: the modules the project is made of + , knownExtra :: !(HashSet NormalizedFilePath) + -- ^ Files reported present by the client that no target declares. See + -- Note [Files that are not targets] + , knownGone :: !(HashSet NormalizedFilePath) + -- ^ Files reported gone by the client. See Note [Tombstones] + } deriving Show +{- Note [Files that are not targets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A workspace often has source files that belong to no session/component like test +fixtures and scratch files. The client reports them like any other and we have +to record them, so that we can maintain an accurate view of the filesystem state +based off which we can run and rerun rules, particularly the ones that resolve +imports like 'GetModulesPaths' and 'GetLocatedImports'. +They are not project modules though, so they are kept apart from the targets. +'toKnownFiles' includes these files, but 'toTargetFiles' does not, because a +file without a component has no session to be compiled in. +-} + +{- Note [Tombstones] +~~~~~~~~~~~~~~~~~~~~ +'targetMap' is only ever added to: 'extendKnownTargets' unions into it and the +session loader never removes anything. So a file that disappears cannot be +expressed by deleting an entry. Often there is no entry to delete, and deleting +one that is not there leaves 'KnownTargets' equal to what it was, hash and all, +so the early cutoff on 'GetKnownTargets' fires and nothing reruns: the deletion +would be invisible. + +Recording the deletion always changes the value, so the rules reading it rerun. +'GetModulesPaths' has to, or an import keeps resolving to a file that is gone, +since 'toKnownFiles' is what tells it about files the file system scan cannot +see. 'GetModuleGraph' has to, or a deleted target stays a root of the graph. + +Both 'toKnownFiles' and 'toTargetFiles' hide tombstoned files, which also covers +a target rediscovered by a later cradle load: 'extendKnownTargets' adds the +candidate locations of a 'TargetFile' without checking they exist. A file that +comes back clears its tombstone. +-} + unionKnownTargets :: KnownTargets -> KnownTargets -> KnownTargets -unionKnownTargets (KnownTargets tm) (KnownTargets tm') = - KnownTargets (HMap.unionWith (<>) tm tm') +unionKnownTargets (KnownTargets tm extra gone) (KnownTargets tm' extra' gone') = + KnownTargets (HMap.unionWith (<>) tm tm') (extra <> extra') (gone <> gone') mkKnownTargets :: [(Target, HashSet NormalizedFilePath)] -> KnownTargets -mkKnownTargets vs = KnownTargets (HMap.fromList vs) +mkKnownTargets vs = KnownTargets (HMap.fromList vs) HSet.empty HSet.empty +-- | See Note [Files that are not targets] +mkExtraKnownFiles :: HashSet NormalizedFilePath -> KnownTargets +mkExtraKnownFiles fs = KnownTargets HMap.empty fs HSet.empty + +-- | Record files as gone, and files that came back as present again. +tombstoneKnownFiles + :: HashSet NormalizedFilePath -- ^ gone + -> HashSet NormalizedFilePath -- ^ back + -> KnownTargets -> KnownTargets +tombstoneKnownFiles gone back kt = + kt { knownGone = (knownGone kt `HSet.union` gone) `HSet.difference` back } + instance NFData KnownTargets where - rnf (KnownTargets tm) = rnf tm `seq` () + rnf (KnownTargets tm extra gone) = rnf tm `seq` rnf extra `seq` rnf gone `seq` () instance Eq KnownTargets where k1 == k2 = targetMap k1 == targetMap k2 + && knownExtra k1 == knownExtra k2 + && knownGone k1 == knownGone k2 instance Hashable KnownTargets where - hashWithSalt s (KnownTargets hm) = hashWithSalt s hm + hashWithSalt s (KnownTargets hm extra gone) = + hashWithSalt (hashWithSalt (hashWithSalt s hm) (HSet.toList extra)) (HSet.toList gone) emptyKnownTargets :: KnownTargets -emptyKnownTargets = KnownTargets HMap.empty +emptyKnownTargets = KnownTargets HMap.empty HSet.empty HSet.empty data Target = TargetModule ModuleName | TargetFile NormalizedFilePath deriving ( Eq, Ord, Generic, Show ) deriving anyclass (Hashable, NFData) +-- | Every file that is there, as far as we have been told. toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath -toKnownFiles = HSet.unions . HMap.elems . targetMap +toKnownFiles kt = (targets `HSet.union` knownExtra kt) `HSet.difference` knownGone kt + where targets = HSet.unions (HMap.elems (targetMap kt)) + +-- | The files of the project, as declared by the session loader. +-- See Note [Files that are not targets] +toTargetFiles :: KnownTargets -> HashSet NormalizedFilePath +toTargetFiles kt = + HSet.unions (HMap.elems (targetMap kt)) `HSet.difference` knownGone kt diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -16,6 +16,8 @@ , IdeGhcSession(..) , OptHaddockParse(..) , ProgressReportingStyle(..) + , LinkTargets(..) + , linkTargets ) where import Control.Lens @@ -26,7 +28,8 @@ import Development.IDE.Graph import Development.IDE.Types.Diagnostics import Ide.Plugin.Config -import Ide.Types (DynFlagsModifications) +import Ide.Types (DynFlagsModifications, + OptLinkTo (..)) import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.Protocol.Types as LSP @@ -85,8 +88,23 @@ -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed , optVerifyCoreFile :: Bool -- ^ Verify core files after serialization + , optLinkSourceTo :: OptLinkTo + -- ^ `Source` link to Hackage or local sources. + , optLinkDocTo :: OptLinkTo + -- ^ `Documentation` link to Hackage or local docs. } +data LinkTargets = LinkTargets + { linkSource :: !OptLinkTo + , linkDoc :: !OptLinkTo + } + +linkTargets :: IdeOptions -> LinkTargets +linkTargets IdeOptions{..} = LinkTargets + { linkSource = optLinkSourceTo + , linkDoc = optLinkDocTo + } + data OptHaddockParse = HaddockParse | NoHaddockParse deriving (Eq,Ord,Show,Enum) @@ -138,6 +156,8 @@ ,optRunSubset = True ,optVerifyCoreFile = False ,optMaxDirtyAge = 100 + ,optLinkSourceTo = LinkToLocal + ,optLinkDocTo = LinkToLocal } defaultSkipProgress :: Typeable a => a -> Bool @@ -150,6 +170,9 @@ -- don't do progress for GetModificationTime as there are lot of redundant nodes -- (for the interface files) _ | Just GetModificationTime_{} <- cast key -> True + -- don't do progress for these, counted via GetModArtefacts instead + _ | Just GetModIface <- cast key -> True + _ | Just GetCoreFileHash <- cast key -> True _ -> False