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.11.0.0 +version: 2.12.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -14,7 +14,7 @@ https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC ==9.10.1 || ==9.8.2 || ==9.6.5 || ==9.4.8 +tested-with: GHC == {9.12.2, 9.10.1, 9.8.4, 9.6.7} extra-source-files: CHANGELOG.md README.md @@ -57,7 +57,7 @@ , deepseq , dependent-map , dependent-sum - , Diff ^>=0.5 + , Diff ^>=0.5 || ^>=1.0.0 , directory , dlist , enummapset @@ -73,11 +73,10 @@ , Glob , haddock-library >=1.8 && <1.12 , hashable - , hie-bios ^>=0.15.0 - , hie-compat ^>=0.3.0.0 - , hiedb ^>= 0.6.0.2 - , hls-graph == 2.11.0.0 - , hls-plugin-api == 2.11.0.0 + , hie-bios ^>=0.17.0 + , hiedb ^>= 0.7.0.0 + , hls-graph == 2.12.0.0 + , hls-plugin-api == 2.12.0.0 , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens , lens-aeson 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 @@ -67,6 +67,7 @@ import Development.IDE.Types.Options import GHC.ResponseFile import qualified HIE.Bios as HieBios +import qualified HIE.Bios.Cradle.Utils as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios @@ -223,7 +224,7 @@ -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String -hiedbDataVersion = "1" +hiedbDataVersion = "2" data CacheDirs = CacheDirs { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} @@ -451,6 +452,7 @@ IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject , optExtensions + , optHaddockParse } <- getIdeOptions -- populate the knownTargetsVar with all the @@ -495,9 +497,9 @@ packageSetup (hieYaml, cfp, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir - newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir + newTargetDfs <- evalGhcEnv hscEnv $ setOptions optHaddockParse cfp opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps + dep_info <- getDependencyInfo (fmap toAbsolutePath deps) -- Now lookup to see whether we are combining with an existing HscEnv -- or making a new one. The lookup returns the HscEnv and a list of -- information about other components loaded into the HscEnv @@ -798,7 +800,7 @@ -- Moved back to implementation in GHC. checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages] checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue -#elif MIN_VERSION_ghc(9,3,0) +#else -- This function checks the important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -- GHC had an implementation of this function, but it was horribly inefficient @@ -888,11 +890,7 @@ ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp (T.pack (Compat.printWithoutUniques (singleMessage err))) -#if MIN_VERSION_ghc(9,5,0) (Just (fmap GhcDriverMessage err)) -#else - Nothing -#endif multi_errs = map closure_err_to_multi_err closure_errs bad_units = OS.fromList $ concat $ do x <- map errMsgDiagnostic closure_errs @@ -960,6 +958,8 @@ expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst ``` +and many more. + To mitigate this, we set the cache directory for each component dependent on the components of the current `HscEnv`, additionally to the component options of the respective components. @@ -1111,12 +1111,13 @@ -- | Throws if package flags are unsatisfiable setOptions :: GhcMonad m - => NormalizedFilePath + => OptHaddockParse + -> NormalizedFilePath -> ComponentOptions -> DynFlags -> FilePath -- ^ root dir, see Note [Root Directory] -> m (NonEmpty (DynFlags, [GHC.Target])) -setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do +setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) case NE.nonEmpty units of Just us -> initMulti us @@ -1146,7 +1147,10 @@ initMulti unitArgFiles = forM unitArgFiles $ \f -> do args <- liftIO $ expandResponse [f] - initOne args + -- The reponse files may contain arguments like "+RTS", + -- and hie-bios doesn't expand the response files of @-unit@ arguments. + -- Thus, we need to do the stripping here. + initOne $ HieBios.removeRTS $ HieBios.removeVerbosityOpts args initOne this_opts = do (dflags', targets') <- addCmdOpts this_opts dflags let dflags'' = @@ -1177,6 +1181,7 @@ dontWriteHieFiles $ setIgnoreInterfacePragmas $ setBytecodeLinkerOptions $ + enableOptHaddock haddockOpt $ disableOptimisation $ Compat.setUpTypedHoles $ makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory @@ -1189,6 +1194,14 @@ disableOptimisation :: DynFlags -> DynFlags disableOptimisation df = updOptLevel 0 df + +-- | We always compile with '-haddock' unless explicitly disabled. +-- +-- This avoids inconsistencies when doing recompilation checking which was +-- observed in https://github.com/haskell/haskell-language-server/issues/4511 +enableOptHaddock :: OptHaddockParse -> DynFlags -> DynFlags +enableOptHaddock HaddockParse d = gopt_set d Opt_Haddock +enableOptHaddock NoHaddockParse d = d setHiDir :: FilePath -> DynFlags -> DynFlags setHiDir f d = diff --git a/src/Development/IDE/Core/Actions.hs b/src/Development/IDE/Core/Actions.hs --- a/src/Development/IDE/Core/Actions.hs +++ b/src/Development/IDE/Core/Actions.hs @@ -28,6 +28,7 @@ import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location +import GHC.Iface.Ext.Types (Identifier) import qualified HieDb import Language.LSP.Protocol.Types (DocumentHighlight (..), SymbolInformation (..), @@ -62,7 +63,7 @@ (hf, mapping) <- useWithStaleFastMT GetHieAst file env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file - dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file) + dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' 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 @@ -39,79 +39,78 @@ , setNonHomeFCHook ) where -import Control.Concurrent.STM.Stats hiding (orElse) -import Control.DeepSeq (NFData (..), force, - rnf) -import Control.Exception (evaluate) +import Control.Concurrent.STM.Stats hiding (orElse) +import Control.DeepSeq (NFData (..), + force, rnf) +import Control.Exception (evaluate) import Control.Exception.Safe -import Control.Lens hiding (List, pre, - (<.>)) +import Control.Lens hiding (List, pre, + (<.>)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Except -import qualified Control.Monad.Trans.State.Strict as S -import Data.Aeson (toJSON) -import Data.Bifunctor (first, second) +import qualified Control.Monad.Trans.State.Strict as S +import Data.Aeson (toJSON) +import Data.Bifunctor (first, second) import Data.Binary -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Data.Coerce -import qualified Data.DList as DL +import qualified Data.DList as DL import Data.Functor import Data.Generics.Aliases import Data.Generics.Schemes -import qualified Data.HashMap.Strict as HashMap -import Data.IntMap (IntMap) +import qualified Data.HashMap.Strict as HashMap +import Data.IntMap (IntMap) import Data.IORef import Data.List.Extra -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map import Data.Maybe -import Data.Proxy (Proxy (Proxy)) -import qualified Data.Text as T -import Data.Time (UTCTime (..), getCurrentTime) -import Data.Tuple.Extra (dupe) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Text as T +import Data.Time (UTCTime (..)) +import Data.Tuple.Extra (dupe) import Debug.Trace -import Development.IDE.Core.FileStore (resetInterfaceStore) +import Development.IDE.Core.FileStore (resetInterfaceStore) import Development.IDE.Core.Preprocessor -import Development.IDE.Core.ProgressReporting (progressUpdate) +import Development.IDE.Core.ProgressReporting (progressUpdate) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake -import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.GHC.Compat hiding (assert, - loadInterface, - parseHeader, - parseModule, - tcRnModule, - writeHieFile) -import qualified Development.IDE.GHC.Compat as Compat -import qualified Development.IDE.GHC.Compat as GHC -import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.Core.Tracing (withTrace) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat.Driver (hscTypecheckRenameWithDiagnostics) +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.CoreFile import Development.IDE.GHC.Error -import Development.IDE.GHC.Orphans () +import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util import Development.IDE.GHC.Warnings +import Development.IDE.Import.DependencyInformation import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options -import GHC (ForeignHValue, - GetDocsFailure (..), - parsedSource, ModLocation (..)) -import qualified GHC.LanguageExtensions as LangExt +import GHC (ForeignHValue, + GetDocsFailure (..), + ModLocation (..), + parsedSource) +import qualified GHC.LanguageExtensions as LangExt import GHC.Serialized -import HieDb hiding (withHieDb) -import qualified Language.LSP.Protocol.Message as LSP -import Language.LSP.Protocol.Types (DiagnosticTag (..)) -import qualified Language.LSP.Server as LSP -import Prelude hiding (mod) +import HieDb hiding (withHieDb) +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types (DiagnosticTag (..)) +import qualified Language.LSP.Server as LSP +import Prelude hiding (mod) import System.Directory import System.FilePath -import System.IO.Extra (fixIO, - newTempFileWithin) +import System.IO.Extra (fixIO, + newTempFileWithin) -import qualified Data.Set as Set -import qualified GHC as G -import qualified GHC.Runtime.Loader as Loader +import qualified Data.Set as Set +import qualified GHC as G +import GHC.Core.Lint.Interactive +import GHC.Driver.Config.CoreToStg.Prep +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 @@ -120,25 +119,40 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - -#if MIN_VERSION_ghc(9,5,0) -import GHC.Core.Lint.Interactive -import GHC.Driver.Config.CoreToStg.Prep -#endif - #if MIN_VERSION_ghc(9,7,0) -import Data.Foldable (toList) +import Data.Foldable (toList) import GHC.Unit.Module.Warnings #else -import Development.IDE.Core.FileStore (shareFilePath) +import Development.IDE.Core.FileStore (shareFilePath) #endif -import Development.IDE.GHC.Compat.Driver (hscTypecheckRenameWithDiagnostics) +#if MIN_VERSION_ghc(9,10,0) +import Development.IDE.GHC.Compat hiding (assert, + loadInterface, + parseHeader, + parseModule, + tcRnModule, + writeHieFile) +#else +import Development.IDE.GHC.Compat hiding + (loadInterface, + parseHeader, + parseModule, + tcRnModule, + writeHieFile) +#endif -import Development.IDE.Import.DependencyInformation -import GHC.Driver.Env ( hsc_all_home_unit_ids ) -import Development.IDE.Import.FindImports +#if MIN_VERSION_ghc(9,11,0) +import qualified Data.List.NonEmpty as NE +import Data.Time (getCurrentTime) +import GHC.Driver.Env (hsc_all_home_unit_ids) +import GHC.Iface.Ext.Types (NameEntityInfo) +#endif +#if MIN_VERSION_ghc(9,12,0) +import Development.IDE.Import.FindImports +#endif + --Simple constants to make sure the source is consistently named sourceTypecheck :: T.Text sourceTypecheck = "typecheck" @@ -176,7 +190,7 @@ data TypecheckHelpers = TypecheckHelpers - { getLinkables :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files + { getLinkables :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files , getModuleGraph :: IO DependencyInformation } @@ -470,9 +484,7 @@ pure (details, guts) let !partial_iface = force $ mkPartialIface session -#if MIN_VERSION_ghc(9,5,0) (cg_binds guts) -#endif details ms #if MIN_VERSION_ghc(9,11,0) @@ -481,9 +493,7 @@ simplified_guts final_iface' <- mkFullIface session partial_iface Nothing -#if MIN_VERSION_ghc(9,4,2) Nothing -#endif #if MIN_VERSION_ghc(9,11,0) NoStubs [] #endif @@ -524,17 +534,9 @@ mod = ms_mod ms data_tycons = filter isDataTyCon tycons CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core - -#if MIN_VERSION_ghc(9,5,0) cp_cfg <- initCorePrepConfig session -#endif - let corePrep = corePrepPgm -#if MIN_VERSION_ghc(9,5,0) (hsc_logger session) cp_cfg (initCorePrepPgmConfig (hsc_dflags session) (interactiveInScope $ hsc_IC session)) -#else - session -#endif mod (ms_location ms) -- Run corePrep first as we want to test the final version of the program that will @@ -647,11 +649,7 @@ (Just dot_o) $ hsc_dflags env' session' = hscSetFlags newFlags session -#if MIN_VERSION_ghc(9,4,2) (outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts -#else - (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts -#endif (ms_location summary) fp obj <- compileFile session' driverNoStop (outputFilename, Just (As False)) @@ -673,22 +671,31 @@ generateByteCode (CoreFileTime time) hscEnv summary guts = do fmap (either (, Nothing) (second Just)) $ catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do + #if MIN_VERSION_ghc(9,11,0) (warnings, (_, bytecode)) <- + withWarnings "bytecode" $ \_tweak -> do + let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv) + -- TODO: maybe settings ms_hspp_opts is unnecessary? + summary' = summary { ms_hspp_opts = hsc_dflags session } + hscInteractive session (mkCgInteractiveGuts guts) + (ms_location summary') #else (warnings, (_, bytecode, sptEntries)) <- -#endif withWarnings "bytecode" $ \_tweak -> do let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv) -- TODO: maybe settings ms_hspp_opts is unnecessary? summary' = summary { ms_hspp_opts = hsc_dflags session } hscInteractive session (mkCgInteractiveGuts guts) (ms_location summary') +#endif + #if MIN_VERSION_ghc(9,11,0) let linkable = Linkable time (ms_mod summary) (pure $ BCOs bytecode) #else let linkable = LM time (ms_mod summary) [BCOs bytecode sptEntries] #endif + pure (map snd warnings, linkable) demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule @@ -821,7 +828,7 @@ pure $ Just $ #if MIN_VERSION_ghc(9,11,0) hie_asts (tcg_type_env ts) -#elif MIN_VERSION_ghc(9,3,0) +#else hie_asts #endif where @@ -966,12 +973,12 @@ ) ] - -- 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 -- HomeModInfo's of all direct dependencies (by induction hypothesis all -- transitive dependencies will be contained in envs) +#if MIN_VERSION_ghc(9,11,0) mergeEnvs :: HscEnv -> ModuleGraph -> DependencyInformation @@ -980,7 +987,6 @@ -> [HscEnv] -> IO HscEnv mergeEnvs env mg dep_info ms extraMods envs = do -#if MIN_VERSION_ghc(9,11,0) return $! loadModulesHome extraMods $ let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in (hscUpdateHUG (const newHug) env){ @@ -1011,7 +1017,15 @@ | HsSrcFile <- mi_hsc_src (hm_iface a) = a | otherwise = b -#elif MIN_VERSION_ghc(9,3,0) +#else +mergeEnvs :: HscEnv + -> ModuleGraph + -> DependencyInformation + -> ModSummary + -> [HomeModInfo] + -> [HscEnv] + -> IO HscEnv +mergeEnvs env mg _dep_info ms extraMods envs = do let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms)) ifr = InstalledFound (ms_location ms) im curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr @@ -1173,11 +1187,7 @@ => DynFlags -- ^ flags to use -> FilePath -- ^ the filename (for source locations) -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported) -#if MIN_VERSION_ghc(9,5,0) -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located (HsModule GhcPs)) -#else - -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located HsModule) -#endif parseHeader dflags filename contents = do let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of @@ -1439,7 +1449,7 @@ | not (mi_used_th iface) = emptyModuleEnv | otherwise = parseRuntimeDeps (md_anns details) -- Peform the fine grained recompilation check for TH - maybe_recomp <- checkLinkableDependencies session get_linkable_hashes get_module_graph runtime_deps + maybe_recomp <- checkLinkableDependencies get_linkable_hashes get_module_graph runtime_deps case maybe_recomp of Just msg -> do_regenerate msg Nothing @@ -1476,8 +1486,8 @@ -- the runtime dependencies of the module, to check if any of them are out of date -- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH -- See Note [Recompilation avoidance in the presence of TH] -checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> m DependencyInformation -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired) -checkLinkableDependencies hsc_env get_linkable_hashes get_module_graph runtime_deps = do +checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> m DependencyInformation -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired) +checkLinkableDependencies get_linkable_hashes get_module_graph runtime_deps = do graph <- get_module_graph let go (mod, hash) = (,hash) <$> lookupModuleFile mod graph hs_files = mapM go (moduleEnvToList runtime_deps) @@ -1523,16 +1533,12 @@ -- Implicit binds aren't saved, so we need to regenerate them ourselves. let _implicit_binds = concatMap getImplicitBinds tyCons -- only used if GHC < 9.6 tyCons = typeEnvTyCons (md_types details) -#if MIN_VERSION_ghc(9,5,0) -- In GHC 9.6, the implicit binds are tidied and part of core_binds pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty #if !MIN_VERSION_ghc(9,11,0) (emptyHpcInfo False) #endif Nothing [] -#else - pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] -#endif coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo) coreFileToLinkable linkableType session ms iface details core_file t = do @@ -1637,7 +1643,7 @@ with negative if clauses coming before positive if clauses of the same version. (If you think about which GHC version a clause activates for this should make sense `!MIN_VERSION_GHC(9,0,0)` refers to 8.10 and lower which is - a earlier version than `MIN_VERSION_GHC(9,0,0)` which refers to versions 9.0 + an earlier version than `MIN_VERSION_GHC(9,0,0)` which refers to versions 9.0 and later). In addition there should be a space before and after each CPP clause. 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 @@ -78,7 +78,6 @@ import System.IO.Error import System.IO.Unsafe - data Log = LogCouldNotIdentifyReverseDeps !NormalizedFilePath | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) @@ -147,6 +146,29 @@ then return (Nothing, ([], Nothing)) else return (Nothing, ([diag], Nothing)) + +getPhysicalModificationTimeRule :: Recorder (WithPriority Log) -> Rules () +getPhysicalModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetPhysicalModificationTime file -> + getPhysicalModificationTimeImpl file + +getPhysicalModificationTimeImpl + :: NormalizedFilePath + -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) +getPhysicalModificationTimeImpl file = do + let file' = fromNormalizedFilePath file + let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) + + alwaysRerun + + liftIO $ fmap wrap (getModTime file') + `catch` \(e :: IOException) -> do + let err | isDoesNotExistError e = "File does not exist: " ++ file' + | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e + diag = ideErrorText file (T.pack err) + if isDoesNotExistError e + then return (Nothing, ([], Nothing)) + else return (Nothing, ([diag], Nothing)) + -- | Interface files cannot be watched, since they live outside the workspace. -- But interface files are private, in that only HLS writes them. -- So we implement watching ourselves, and bypass the need for alwaysRerun. @@ -170,7 +192,11 @@ case c of LSP.FileChangeType_Changed -- already checked elsewhere | not $ HM.member nfp fois - -> atomically $ deleteValue (shakeExtras ideState) GetModificationTime nfp + -> + atomically $ do + ks <- deleteValue (shakeExtras ideState) GetModificationTime nfp + vs <- deleteValue (shakeExtras ideState) GetPhysicalModificationTime nfp + pure $ ks ++ vs _ -> pure [] @@ -233,6 +259,7 @@ fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () fileStoreRules recorder isWatched = do getModificationTimeRule recorder + getPhysicalModificationTimeRule recorder getFileContentsRule recorder addWatchedFileRule recorder isWatched @@ -264,7 +291,7 @@ typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () typecheckParentsAction recorder nfp = do - revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph + revs <- transitiveReverseDependencies nfp <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph nfp case revs of Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -29,7 +29,6 @@ import Control.Concurrent.STM.Stats (atomically, modifyTVar') import Data.Aeson (toJSON) -import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import Data.Maybe (catMaybes) import Development.IDE.Core.ProgressReporting 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 @@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} @@ -34,6 +35,9 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.KnownTargets import GHC.Generics (Generic) +import GHC.Iface.Ext.Types (HieASTs, + TypeIndex) +import GHC.Iface.Ext.Utils (RefMap) import Data.ByteString (ByteString) import Data.Text.Utf16.Rope.Mixed (Rope) @@ -74,6 +78,12 @@ type instance RuleResult GetModuleGraph = DependencyInformation +-- | it only compute the fingerprint of the module graph for a file and its dependencies +-- we need this to trigger recompilation when the sub module graph for a file changes +type instance RuleResult GetModuleGraphTransDepsFingerprints = Fingerprint +type instance RuleResult GetModuleGraphTransReverseDepsFingerprints = Fingerprint +type instance RuleResult GetModuleGraphImmediateReverseDepsFingerprints = Fingerprint + data GetKnownTargets = GetKnownTargets deriving (Show, Generic, Eq, Ord) instance Hashable GetKnownTargets @@ -243,9 +253,15 @@ -- | A IntervalMap telling us what is in scope at each point type instance RuleResult GetBindings = Bindings -data DocAndTyThingMap = DKMap {getDocMap :: !DocMap, getTyThingMap :: !TyThingMap} +data DocAndTyThingMap = DKMap + { getDocMap :: !DocMap + -- ^ Docs for declarations: functions, data types, instances, methods, etc + , getTyThingMap :: !TyThingMap + , getArgDocMap :: !ArgDocMap + -- ^ Docs for arguments, e.g., function arguments and method arguments + } instance NFData DocAndTyThingMap where - rnf (DKMap a b) = rwhnf a `seq` rwhnf b + rnf (DKMap a b c) = rwhnf a `seq` rwhnf b `seq` rwhnf c instance Show DocAndTyThingMap where show = const "docmap" @@ -310,6 +326,13 @@ instance NFData GetModificationTime +data GetPhysicalModificationTime = GetPhysicalModificationTime + deriving (Generic, Show, Eq) + deriving anyclass (Hashable, NFData) + +-- | Get the modification time of a file on disk, ignoring any version in the VFS. +type instance RuleResult GetPhysicalModificationTime = FileVersion + pattern GetModificationTime :: GetModificationTime pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} @@ -416,6 +439,21 @@ deriving (Eq, Show, Generic) instance Hashable GetModuleGraph instance NFData GetModuleGraph + +data GetModuleGraphTransDepsFingerprints = GetModuleGraphTransDepsFingerprints + deriving (Eq, Show, Generic) +instance Hashable GetModuleGraphTransDepsFingerprints +instance NFData GetModuleGraphTransDepsFingerprints + +data GetModuleGraphTransReverseDepsFingerprints = GetModuleGraphTransReverseDepsFingerprints + deriving (Eq, Show, Generic) +instance Hashable GetModuleGraphTransReverseDepsFingerprints +instance NFData GetModuleGraphTransReverseDepsFingerprints + +data GetModuleGraphImmediateReverseDepsFingerprints = GetModuleGraphImmediateReverseDepsFingerprints + deriving (Eq, Show, Generic) +instance Hashable GetModuleGraphImmediateReverseDepsFingerprints +instance NFData GetModuleGraphImmediateReverseDepsFingerprints data ReportImportCycles = ReportImportCycles 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 @@ -138,6 +138,8 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Development.IDE.Types.Shake as Shake +import GHC.Iface.Ext.Types (HieASTs (..)) +import GHC.Iface.Ext.Utils (generateReferencesMap) import qualified GHC.LanguageExtensions as LangExt import HIE.Bios.Ghc.Gap (hostIsDynamic) import qualified HieDb @@ -159,10 +161,10 @@ usePropertyByPath) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), PluginId) +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), ShowMessageParams (ShowMessageParams)) -import qualified Language.LSP.Protocol.Lens as JL import Language.LSP.Server (LspT) import qualified Language.LSP.Server as LSP import Language.LSP.VFS @@ -174,8 +176,6 @@ import qualified Data.IntMap as IM import GHC.Fingerprint -import GHC.Driver.Env (hsc_all_home_unit_ids) - data Log = LogShake Shake.Log | LogReindexingHieFile !NormalizedFilePath @@ -183,6 +183,7 @@ | LogLoadingHieFileFail !FilePath !SomeException | LogLoadingHieFileSuccess !FilePath | LogTypecheckedFOI !NormalizedFilePath + | LogDependencies !NormalizedFilePath [FilePath] deriving Show instance Pretty Log where @@ -207,6 +208,11 @@ <+> "the HLS version being used, the plugins enabled, and if possible the codebase and file which" <+> "triggered this warning." ] + LogDependencies nfp deps -> + vcat + [ "Add dependency" <+> pretty (fromNormalizedFilePath nfp) + , nest 2 $ pretty deps + ] templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries" @@ -262,12 +268,10 @@ let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } reset_ms pm = pm { pm_mod_summary = ms' } - -- We still parse with Haddocks whether Opt_Haddock is True or False to collect information - -- but we no longer need to parse with and without Haddocks separately for above GHC90. - liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms) + liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file ms -withOptHaddock :: ModSummary -> ModSummary -withOptHaddock = withOption Opt_Haddock +withoutOptHaddock :: ModSummary -> ModSummary +withoutOptHaddock = withoutOption Opt_Haddock withOption :: GeneralFlag -> ModSummary -> ModSummary withOption opt ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) opt} @@ -286,7 +290,7 @@ ModSummaryResult{msrModSummary = ms, msrHscEnv = hsc} <- use_ GetModSummary file opt <- getIdeOptions - let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms + let ms' = withoutOptHaddock $ withOption Opt_KeepRawTokenStream ms modify_dflags <- getModifyDynFlags dynFlagsModifyParser let ms'' = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } reset_ms pm = pm { pm_mod_summary = ms' } @@ -472,7 +476,7 @@ reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () reportImportCyclesRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do - DependencyInformation{..} <- useNoFile_ GetModuleGraph + DependencyInformation{..} <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file case pathToId depPathIdMap file of -- The header of the file does not parse, so it can't be part of any import cycles. Nothing -> pure [] @@ -514,7 +518,7 @@ (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) Just vf -> pure (virtualFileText vf, Just $ virtualFileVersion vf) - let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res + let refmap = generateReferencesMap . getAsts . Compat.hie_asts $ res del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) @@ -542,8 +546,8 @@ liftIO $ writeAndIndexHieFile hsc se modSummary f exports asts source _ -> pure [] - let refmap = Compat.generateReferencesMap . Compat.getAsts <$> masts - typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts + let refmap = generateReferencesMap . getAsts <$> masts + typemap = AtPoint.computeTypeReferences . getAsts <$> masts pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) getImportMapRule :: Recorder (WithPriority Log) -> Rules () @@ -578,7 +582,7 @@ -- | Persistent rule to ensure that hover doesn't block on startup persistentDocMapRule :: Rules () -persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) +persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty mempty, idDelta, Nothing) readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile readHieFileForSrcFromDisk recorder file = do @@ -608,7 +612,7 @@ -- very expensive. when (foi == NotFOI) $ logWith recorder Logger.Warning $ LogTypecheckedFOI file - typeCheckRuleDefinition hsc pm + typeCheckRuleDefinition hsc pm file knownFilesRule :: Recorder (WithPriority Log) -> Rules () knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetKnownTargets -> do @@ -643,7 +647,10 @@ go (Just ms) _ = Just $ ModuleNode [] ms go _ _ = Nothing mg = mkModuleGraph mns - pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg) + let shallowFingers = IntMap.fromList $ foldr' (\(i, m) acc -> case m of + Just x -> (getFilePathId i,msrFingerprint x):acc + Nothing -> acc) [] $ zip _all_ids msrs + pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg shallowFingers) -- This is factored out so it can be directly called from the GetModIface -- rule. Directly calling this rule means that on the initial load we can @@ -652,14 +659,15 @@ typeCheckRuleDefinition :: HscEnv -> ParsedModule + -> NormalizedFilePath -> Action (IdeResult TcModuleResult) -typeCheckRuleDefinition hsc pm = do +typeCheckRuleDefinition hsc pm fp = do IdeOptions { optDefer = defer } <- getIdeOptions unlift <- askUnliftIO let dets = TypecheckHelpers { getLinkables = unliftIO unlift . uses_ GetLinkable - , getModuleGraph = unliftIO unlift $ useNoFile_ GetModuleGraph + , getModuleGraph = unliftIO unlift $ useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph fp } addUsageDependencies $ liftIO $ typecheckModule defer hsc dets pm @@ -713,7 +721,8 @@ let nfp = toNormalizedFilePath' fp itExists <- getFileExists nfp when itExists $ void $ do - use_ GetModificationTime nfp + use_ GetPhysicalModificationTime nfp + logWith recorder Logger.Info $ LogDependencies file deps mapM_ addDependency deps let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) @@ -756,9 +765,10 @@ depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps ifaces <- uses_ GetModIface deps let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces + de <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file mg <- do if fullModuleGraph - then depModuleGraph <$> useNoFile_ GetModuleGraph + then return $ depModuleGraph de else do let mgs = map hsc_mod_graph depSessions -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph @@ -771,7 +781,6 @@ nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs) liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes return $ mkModuleGraph module_graph_nodes - de <- useNoFile_ GetModuleGraph session' <- liftIO $ mergeEnvs hsc mg de ms inLoadOrder depSessions -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new @@ -801,7 +810,7 @@ , old_value = m_old , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs - , get_module_graph = useNoFile_ GetModuleGraph + , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f , regenerate = regenerateHiFile session f ms } hsc_env' <- setFileCacheHook (hscEnv session) @@ -970,14 +979,14 @@ hsc <- setFileCacheHook (hscEnv sess) opt <- getIdeOptions - -- Embed haddocks in the interface file - (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms) + -- By default, we parse with `-haddock` unless 'OptHaddockParse' is overwritten. + (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms case mb_pm of Nothing -> return (diags, Nothing) Just pm -> do -- Invoke typechecking directly to update it without incurring a dependency -- on the parsed module and the typecheck rules - (diags', mtmr) <- typeCheckRuleDefinition hsc pm + (diags', mtmr) <- typeCheckRuleDefinition hsc pm f case mtmr of Nothing -> pure (diags', Nothing) Just tmr -> do @@ -1135,7 +1144,7 @@ | "boot" `isSuffixOf` fromNormalizedFilePath file = pure (Just $ encodeLinkableType Nothing, Just Nothing) needsCompilationRule file = do - graph <- useNoFile GetModuleGraph + graph <- useWithSeparateFingerprintRule GetModuleGraphImmediateReverseDepsFingerprints GetModuleGraph file res <- case graph of -- Treat as False if some reverse dependency header fails to parse Nothing -> pure Nothing @@ -1247,6 +1256,19 @@ persistentDocMapRule persistentImportMapRule getLinkableRule recorder + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphTransDepsFingerprints file -> do + di <- useNoFile_ GetModuleGraph + let finger = lookupFingerprint file di (depTransDepsFingerprints di) + return (fingerprintToBS <$> finger, ([], finger)) + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphTransReverseDepsFingerprints file -> do + di <- useNoFile_ GetModuleGraph + let finger = lookupFingerprint file di (depTransReverseDepsFingerprints di) + return (fingerprintToBS <$> finger, ([], finger)) + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphImmediateReverseDepsFingerprints file -> do + di <- useNoFile_ GetModuleGraph + let finger = lookupFingerprint file di (depImmediateReverseDepsFingerprints di) + return (fingerprintToBS <$> finger, ([], finger)) + -- | Get HieFile for haskell file on NormalizedFilePath getHieFile :: NormalizedFilePath -> Action (Maybe HieFile) 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 @@ -31,6 +31,8 @@ shakeEnqueue, newSession, use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction, + useWithSeparateFingerprintRule, + useWithSeparateFingerprintRule_, FastResult(..), use_, useNoFile_, uses_, useWithStale, usesWithStale, @@ -1147,6 +1149,23 @@ -- return the most recent successfully computed value regardless of -- whether the rule succeeded or not. traverse (lastValue key) files + +-- we use separate fingerprint rules to trigger the rebuild of the rule +useWithSeparateFingerprintRule + :: (IdeRule k v, IdeRule k1 Fingerprint) + => k1 -> k -> NormalizedFilePath -> Action (Maybe v) +useWithSeparateFingerprintRule fingerKey key file = do + _ <- use fingerKey file + useWithoutDependency key emptyFilePath + +-- we use separate fingerprint rules to trigger the rebuild of the rule +useWithSeparateFingerprintRule_ + :: (IdeRule k v, IdeRule k1 Fingerprint) + => k1 -> k -> NormalizedFilePath -> Action v +useWithSeparateFingerprintRule_ fingerKey key file = do + useWithSeparateFingerprintRule fingerKey key file >>= \case + Just v -> return v + Nothing -> liftIO $ throwIO $ BadDependency (show key) useWithoutDependency :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe v) diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -19,17 +19,11 @@ import Development.IDE.GHC.Compat.Util import GHC import GHC.Settings +import qualified GHC.SysTools.Cpp as Pipeline -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,5,0) -import qualified GHC.Driver.Pipeline.Execute as Pipeline -#endif -#if MIN_VERSION_ghc(9,5,0) -import qualified GHC.SysTools.Cpp as Pipeline -#endif - #if MIN_VERSION_ghc(9,10,2) import qualified GHC.SysTools.Tasks as Pipeline #endif @@ -49,13 +43,12 @@ doCpp :: HscEnv -> FilePath -> FilePath -> IO () doCpp env input_fn output_fn = - -- See GHC commit a2f53ac8d968723417baadfab5be36a020ea6850 - -- this function/Pipeline.doCpp previously had a raw parameter - -- always set to True that corresponded to these settings - -#if MIN_VERSION_ghc(9,5,0) + -- See GHC commit a2f53ac8d968723417baadfab5be36a020ea6850 + -- this function/Pipeline.doCpp previously had a raw parameter + -- always set to True that corresponded to these settings let cpp_opts = Pipeline.CppOpts { cppLinePragmas = True + #if MIN_VERSION_ghc(9,10,2) , sourceCodePreprocessor = Pipeline.SCPHsCpp #elif MIN_VERSION_ghc(9,10,0) @@ -63,10 +56,8 @@ #else , cppUseCc = False #endif + } in -#else - let cpp_opts = True in -#endif Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) cpp_opts input_fn output_fn diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -45,8 +45,6 @@ readHieFile, setHieDir, dontWriteHieFiles, - module Compat.HieTypes, - module Compat.HieUtils, -- * Compat modules module Development.IDE.GHC.Compat.Core, module Development.IDE.GHC.Compat.Env, @@ -102,9 +100,7 @@ Dependencies(dep_direct_mods), NameCacheUpdater, -#if MIN_VERSION_ghc(9,5,0) XModulePs(..), -#endif #if !MIN_VERSION_ghc(9,7,0) liftZonkM, @@ -114,14 +110,8 @@ #if MIN_VERSION_ghc(9,7,0) tcInitTidyEnv, #endif - ) where -import Compat.HieAst (enrichHie) -import Compat.HieBin -import Compat.HieTypes hiding - (nodeAnnotations) -import qualified Compat.HieTypes as GHC (nodeAnnotations) -import Compat.HieUtils + ) where import Control.Applicative ((<|>)) import qualified Data.ByteString as BS import Data.Coerce (coerce) @@ -148,12 +138,18 @@ import GHC.CoreToStg.Prep (corePrepPgm) import qualified GHC.CoreToStg.Prep as GHC import GHC.Driver.Hooks (hscCompileCoreExprHook) +import GHC.Iface.Ext.Types hiding + (nodeAnnotations) +import qualified GHC.Iface.Ext.Types as GHC (nodeAnnotations) +import GHC.Iface.Ext.Utils import GHC.ByteCode.Asm (bcoFreeNames) import GHC.Core import GHC.Data.FastString import GHC.Data.StringBuffer import GHC.Driver.Session hiding (ExposePackage) +import GHC.Iface.Ext.Ast (enrichHie) +import GHC.Iface.Ext.Binary import GHC.Iface.Make (mkIfaceExports) import GHC.SysTools.Tasks (runPp, runUnlit) import GHC.Types.Annotations (AnnTarget (ModuleTarget), @@ -167,8 +163,13 @@ import GHC.Builtin.Uniques import GHC.ByteCode.Types +import GHC.Core.Lint.Interactive (interactiveInScope) import GHC.CoreToStg import GHC.Data.Maybe +import GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr) +import GHC.Driver.Config.Core.Opt.Simplify (initSimplifyExprOpts) +import GHC.Driver.Config.CoreToStg (initCoreToStgOpts) +import GHC.Driver.Config.CoreToStg.Prep (initCorePrepConfig) import GHC.Driver.Config.Stg.Pipeline import GHC.Driver.Env as Env import GHC.Iface.Env @@ -188,18 +189,6 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,5,0) -import GHC.Core.Lint (lintInteractiveExpr) -#endif - -#if MIN_VERSION_ghc(9,5,0) -import GHC.Core.Lint.Interactive (interactiveInScope) -import GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr) -import GHC.Driver.Config.Core.Opt.Simplify (initSimplifyExprOpts) -import GHC.Driver.Config.CoreToStg (initCoreToStgOpts) -import GHC.Driver.Config.CoreToStg.Prep (initCorePrepConfig) -#endif - #if MIN_VERSION_ghc(9,7,0) import GHC.Tc.Zonk.TcType (tcInitTidyEnv) #endif @@ -230,11 +219,7 @@ binding for the stg2stg step) -} let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") (mkPseudoUniqueE 0) -#if MIN_VERSION_ghc(9,5,0) ManyTy -#else - Many -#endif (exprType prepd_expr) (stg_binds, prov_map, collected_ccs) <- myCoreToStg logger @@ -258,27 +243,17 @@ let (stg_binds, denv, cost_centre_info) = {-# SCC "Core2Stg" #-} coreToStg -#if MIN_VERSION_ghc(9,5,0) (initCoreToStgOpts dflags) -#else - dflags -#endif this_mod ml prepd_binds #if MIN_VERSION_ghc(9,8,0) (unzip -> (stg_binds2,_),_) -#elif MIN_VERSION_ghc(9,4,2) - (stg_binds2,_) #else - stg_binds2 + (stg_binds2,_) #endif <- {-# SCC "Stg2Stg" #-} stg2stg logger -#if MIN_VERSION_ghc(9,5,0) (interactiveInScope ictxt) -#else - ictxt -#endif (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds return (stg_binds2, denv, cost_centre_info) @@ -293,42 +268,21 @@ getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr -#if MIN_VERSION_ghc(9,5,0) simplifyExpr _ env = GHC.simplifyExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) (ue_eps (Development.IDE.GHC.Compat.Env.hsc_unit_env env)) (initSimplifyExprOpts (hsc_dflags env) (hsc_IC env)) -#else -simplifyExpr _ = GHC.simplifyExpr -#endif corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr -#if MIN_VERSION_ghc(9,5,0) corePrepExpr _ env expr = do cfg <- initCorePrepConfig env GHC.corePrepExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) cfg expr -#else -corePrepExpr _ = GHC.corePrepExpr -#endif renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg) renderMessages msgs = -#if MIN_VERSION_ghc(9,5,0) let renderMsgs extractor = (fmap . fmap) GhcPsMessage . getMessages $ extractor msgs in (renderMsgs psWarnings, renderMsgs psErrors) -#else - let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs - in (renderMsgs psWarnings, renderMsgs psErrors) -#endif -#if MIN_VERSION_ghc(9,5,0) pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope GhcMessage)) -> ParseResult a -#else -pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a -#endif pattern PFailedWithErrorMessages msgs -#if MIN_VERSION_ghc(9,5,0) <- PFailed (const . fmap (fmap GhcPsMessage) . getMessages . getPsErrorMessages -> msgs) -#else - <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs) -#endif {-# COMPLETE POk, PFailedWithErrorMessages #-} hieExportNames :: HieFile -> [(SrcSpan, Name)] @@ -453,8 +407,7 @@ generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo data GhcVersion - = GHC94 - | GHC96 + = GHC96 | GHC98 | GHC910 | GHC912 @@ -470,10 +423,8 @@ ghcVersion = GHC910 #elif MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) ghcVersion = GHC98 -#elif MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +#else ghcVersion = GHC96 -#elif MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) -ghcVersion = GHC94 #endif simpleNodeInfoCompat :: FastStringCompat -> FastStringCompat -> NodeInfo a @@ -510,14 +461,8 @@ recDotDot :: HsRecFields (GhcPass p) arg -> Maybe Int recDotDot x = -#if MIN_VERSION_ghc(9,5,0) unRecFieldsDotDot <$> -#endif unLoc <$> rec_dotdot x -#if MIN_VERSION_ghc(9,5,0) -extract_cons (NewTypeCon x) = [x] +extract_cons (NewTypeCon x) = [x] extract_cons (DataTypeCons _ xs) = xs -#else -extract_cons = id -#endif 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 @@ -225,6 +225,7 @@ SrcLoc.noSrcSpan, SrcLoc.noSrcLoc, SrcLoc.noLoc, + SrcLoc.srcSpanToRealSrcSpan, mapLoc, -- * Finder FindResult(..), @@ -374,27 +375,13 @@ module GHC.Unit.Finder.Types, module GHC.Unit.Env, module GHC.Driver.Phases, -#if !MIN_VERSION_ghc(9,4,0) - pattern HsFieldBind, - hfbAnn, - hfbLHS, - hfbRHS, - hfbPun, -#endif -#if !MIN_VERSION_ghc_boot_th(9,4,1) - Extension(.., NamedFieldPuns), -#else Extension(..), -#endif mkCgInteractiveGuts, justBytecode, justObjects, emptyHomeModInfoLinkable, homeModInfoByteCode, homeModInfoObject, -#if !MIN_VERSION_ghc(9,5,0) - field_label, -#endif groupOrigin, isVisibleFunArg, #if MIN_VERSION_ghc(9,8,0) @@ -629,21 +616,11 @@ #endif isVisibleFunArg :: Development.IDE.GHC.Compat.Core.FunTyFlag -> Bool -#if __GLASGOW_HASKELL__ >= 906 isVisibleFunArg = TypesVar.isVisibleFunArg type FunTyFlag = TypesVar.FunTyFlag -#else -isVisibleFunArg VisArg = True -isVisibleFunArg _ = False -type FunTyFlag = TypesVar.AnonArgFlag -#endif pattern FunTy :: Development.IDE.GHC.Compat.Core.FunTyFlag -> Type -> Type -> Type pattern FunTy af arg res <- TyCoRep.FunTy {ft_af = af, ft_arg = arg, ft_res = res} - --- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) --- type HasSrcSpan x = () :: Constraint - class HasSrcSpan a where getLoc :: a -> SrcSpan @@ -749,11 +726,7 @@ mkIfaceTc :: HscEnv -> GHC.SafeHaskellMode -> ModDetails -> ModSummary -> Maybe CoreProgram -> TcGblEnv -> IO ModIface mkIfaceTc hscEnv shm md _ms _mcp = -#if MIN_VERSION_ghc(9,5,0) GHC.mkIfaceTc hscEnv shm md _ms _mcp -- mcp::Maybe CoreProgram is only used in GHC >= 9.6 -#else - GHC.mkIfaceTc hscEnv shm md _ms -- ms::ModSummary is only used in GHC >= 9.4 -#endif mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc session = GHC.mkBootModDetailsTc @@ -767,50 +740,10 @@ driverNoStop :: StopPhase driverNoStop = NoStop - -#if !MIN_VERSION_ghc(9,4,0) -pattern HsFieldBind :: XHsRecField id -> id -> arg -> Bool -> HsRecField' id arg -pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- HsRecField hfbAnn (SrcLoc.unLoc -> hfbLHS) hfbRHS hfbPun where - HsFieldBind ann lhs rhs pun = HsRecField ann (SrcLoc.noLoc lhs) rhs pun -#endif - -#if !MIN_VERSION_ghc_boot_th(9,4,1) -pattern NamedFieldPuns :: Extension -pattern NamedFieldPuns = RecordPuns -#endif - groupOrigin :: MatchGroup GhcRn body -> Origin -#if MIN_VERSION_ghc(9,5,0) mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b mapLoc = fmap groupOrigin = mg_ext -#else -mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b -mapLoc = SrcLoc.mapLoc -groupOrigin = mg_origin -#endif - - -#if !MIN_VERSION_ghc(9,5,0) -mkCgInteractiveGuts :: CgGuts -> CgGuts -mkCgInteractiveGuts = id - -emptyHomeModInfoLinkable :: Maybe Linkable -emptyHomeModInfoLinkable = Nothing - -justBytecode :: Linkable -> Maybe Linkable -justBytecode = Just - -justObjects :: Linkable -> Maybe Linkable -justObjects = Just - -homeModInfoByteCode, homeModInfoObject :: HomeModInfo -> Maybe Linkable -homeModInfoByteCode = hm_linkable -homeModInfoObject = hm_linkable - -field_label :: a -> a -field_label = id -#endif mkSimpleTarget :: DynFlags -> FilePath -> Target mkSimpleTarget df fp = Target (TargetFile fp Nothing) True (homeUnitId_ df) Nothing diff --git a/src/Development/IDE/GHC/Compat/Driver.hs b/src/Development/IDE/GHC/Compat/Driver.hs --- a/src/Development/IDE/GHC/Compat/Driver.hs +++ b/src/Development/IDE/GHC/Compat/Driver.hs @@ -79,11 +79,7 @@ tc_result0 <- tcRnModule' mod_summary keep_rn' hpm if hsc_src == HsigFile then -#if MIN_VERSION_ghc(9,5,0) do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary -#else - do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary -#endif ioMsgMaybe $ hoistTcRnMessage $ tcRnMergeSignatures hsc_env hpm tc_result0 iface else return tc_result0 @@ -135,7 +131,6 @@ -- ============================================================================ -- DO NOT EDIT - Refer to top of file -- ============================================================================ -#if MIN_VERSION_ghc(9,5,0) hscSimpleIface :: HscEnv -> Maybe CoreProgram -> TcGblEnv @@ -143,13 +138,5 @@ -> IO (ModIface, ModDetails) hscSimpleIface hsc_env mb_core_program tc_result summary = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary -#else -hscSimpleIface :: HscEnv - -> TcGblEnv - -> ModSummary - -> IO (ModIface, ModDetails) -hscSimpleIface hsc_env tc_result summary - = runHsc hsc_env $ hscSimpleIface' tc_result summary -#endif #endif diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs --- a/src/Development/IDE/GHC/Compat/Env.hs +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -105,22 +105,14 @@ setBytecodeLinkerOptions :: DynFlags -> DynFlags setBytecodeLinkerOptions df = df { ghcLink = LinkInMemory -#if MIN_VERSION_ghc(9,5,0) , backend = noBackend -#else - , backend = NoBackend -#endif , ghcMode = CompManager } setInterpreterLinkerOptions :: DynFlags -> DynFlags setInterpreterLinkerOptions df = df { ghcLink = LinkInMemory -#if MIN_VERSION_ghc(9,5,0) , backend = interpreterBackend -#else - , backend = Interpreter -#endif , ghcMode = CompManager } 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 @@ -8,6 +8,7 @@ -- * Error messages for the typechecking and renamer phase TcRnMessage (..), TcRnMessageDetailed (..), + Hole(..), stripTcRnMessageContext, -- * Parsing error message PsMessage(..), @@ -17,21 +18,52 @@ DriverMessage (..), -- * General Diagnostics Diagnostic(..), - -- * Prisms for error selection + -- * GHC Hints + GhcHint (SuggestExtension), + LanguageExtensionHint (..), + -- * Prisms and lenses for error selection _TcRnMessage, + _TcRnMessageWithCtx, _GhcPsMessage, _GhcDsMessage, _GhcDriverMessage, + _ReportHoleError, + _TcRnIllegalWildcardInType, + _TcRnPartialTypeSignatures, + _TcRnMissingSignature, + _TcRnSolverReport, + _TcRnMessageWithInfo, + _TypeHole, + _ConstraintHole, + reportContextL, + reportContentL, + _MismatchMessage, + _TypeEqMismatchActual, + _TypeEqMismatchExpected, ) where import Control.Lens +import Development.IDE.GHC.Compat (Type) import GHC.Driver.Errors.Types import GHC.HsToCore.Errors.Types import GHC.Tc.Errors.Types +import GHC.Tc.Types.Constraint (Hole (..), HoleSort) import GHC.Types.Error -_TcRnMessage :: Prism' GhcMessage TcRnMessage -_TcRnMessage = prism' GhcTcRnMessage (\case +-- | Some 'TcRnMessage's are nested in other constructors for additional context. +-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'. +-- However, in most occasions you don't need the additional context and you just want +-- the error message. @'_TcRnMessage'@ recursively unwraps these constructors, +-- until there are no more constructors with additional context. +-- +-- Use @'_TcRnMessageWithCtx'@ if you need the additional context. You can always +-- strip it later using @'stripTcRnMessageContext'@. +-- +_TcRnMessage :: Fold GhcMessage TcRnMessage +_TcRnMessage = _TcRnMessageWithCtx . to stripTcRnMessageContext + +_TcRnMessageWithCtx :: Prism' GhcMessage TcRnMessage +_TcRnMessageWithCtx = prism' GhcTcRnMessage (\case GhcTcRnMessage tcRnMsg -> Just tcRnMsg _ -> Nothing) @@ -66,3 +98,42 @@ msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } ) + +makePrisms ''TcRnMessage + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''SolverReportWithCtxt + +makePrisms ''TcSolverReportMsg + +makePrisms ''HoleSort + +-- | Focus 'MismatchMsg' from 'TcSolverReportMsg'. Currently, 'MismatchMsg' can be +-- extracted from 'CannotUnifyVariable' and 'Mismatch' constructors. +_MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg +_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 'teq_mismatch_expected' from 'TypeEqMismatch'. +_TypeEqMismatchExpected :: Traversal' MismatchMsg Type +#if MIN_VERSION_ghc(9,10,2) +_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ expected _ _ _) = + (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected +#else +_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ _ expected _ _ _) = + (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected +#endif +_TypeEqMismatchExpected _ mismatch = pure mismatch + +-- | Focus 'teq_mismatch_actual' from 'TypeEqMismatch'. +_TypeEqMismatchActual :: Traversal' MismatchMsg Type +#if MIN_VERSION_ghc(9,10,2) +_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ actual _ _) = + (\actual' -> mismatch { teq_mismatch_actual = actual' }) <$> focus actual +#else +_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ _ actual _ _) = + (\actual' -> mismatch { teq_mismatch_expected = actual' }) <$> focus actual +#endif +_TypeEqMismatchActual _ mismatch = pure mismatch diff --git a/src/Development/IDE/GHC/Compat/Iface.hs b/src/Development/IDE/GHC/Compat/Iface.hs --- a/src/Development/IDE/GHC/Compat/Iface.hs +++ b/src/Development/IDE/GHC/Compat/Iface.hs @@ -23,7 +23,7 @@ writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () #if MIN_VERSION_ghc(9,11,0) writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) (Iface.flagsToIfCompression $ hsc_dflags env) fp iface -#elif MIN_VERSION_ghc(9,3,0) +#else writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface #endif 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 @@ -28,10 +28,8 @@ logActionCompat :: LogActionCompat -> LogAction #if MIN_VERSION_ghc(9,7,0) logActionCompat logAction logFlags (MCDiagnostic severity (ResolvedDiagnosticReason wr) _) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify -#elif MIN_VERSION_ghc(9,5,0) -logActionCompat logAction logFlags (MCDiagnostic severity wr _) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify #else -logActionCompat logAction logFlags (MCDiagnostic severity wr) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify +logActionCompat logAction logFlags (MCDiagnostic severity wr _) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify #endif logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify 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 @@ -9,6 +9,7 @@ ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate, printSDocQualifiedUnsafe, printWithoutUniques, + printWithoutUniquesOneLine, mkPrintUnqualifiedDefault, PrintUnqualified, defaultUserStyle, @@ -16,19 +17,18 @@ -- * Parser errors PsWarning, PsError, -#if MIN_VERSION_ghc(9,5,0) defaultDiagnosticOpts, GhcMessage, DriverMessage, Messages, initDiagOpts, pprMessages, -#endif DiagnosticReason(..), renderDiagnosticMessageWithHints, pprMsgEnvelopeBagWithLoc, Error.getMessages, renderWithContext, + showSDocOneLine, defaultSDocContext, errMsgDiagnostic, unDecorated, @@ -51,6 +51,7 @@ import Data.Maybe import GHC.Driver.Config.Diagnostic import GHC.Driver.Env +import GHC.Driver.Errors.Types (DriverMessage, GhcMessage) import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Parser.Errors.Types @@ -66,25 +67,25 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,5,0) -import GHC.Driver.Errors.Types (DriverMessage, GhcMessage) -#endif - #if MIN_VERSION_ghc(9,7,0) import GHC.Types.Error (defaultDiagnosticOpts) #endif -#if MIN_VERSION_ghc(9,5,0) type PrintUnqualified = NamePprCtx -#endif -- | A compatible function to print `Outputable` instances -- without unique symbols. -- -- It print with a user-friendly style like: `a_a4ME` as `a`. printWithoutUniques :: Outputable a => a -> String -printWithoutUniques = - renderWithContext (defaultSDocContext +printWithoutUniques = printWithoutUniques' renderWithContext + +printWithoutUniquesOneLine :: Outputable a => a -> String +printWithoutUniquesOneLine = printWithoutUniques' showSDocOneLine + +printWithoutUniques' :: Outputable a => (SDocContext -> SDoc -> String) -> a -> String +printWithoutUniques' showSDoc = + showSDoc (defaultSDocContext { sdocStyle = defaultUserStyle , sdocSuppressUniques = True @@ -118,33 +119,19 @@ -#if MIN_VERSION_ghc(9,5,0) type ErrMsg = MsgEnvelope GhcMessage type WarnMsg = MsgEnvelope GhcMessage -#else -type ErrMsg = MsgEnvelope DecoratedSDoc -type WarnMsg = MsgEnvelope DecoratedSDoc -#endif mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified -#if MIN_VERSION_ghc(9,5,0) mkPrintUnqualifiedDefault env = mkNamePprCtx ptc (hsc_unit_env env) where ptc = initPromotionTickContext (hsc_dflags env) -#else -mkPrintUnqualifiedDefault env = - -- GHC 9.2 version - -- mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified - mkPrintUnqualified (hsc_unit_env env) -#endif renderDiagnosticMessageWithHints :: forall a. Diagnostic a => a -> DecoratedSDoc renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc (diagnosticMessage -#if MIN_VERSION_ghc(9,5,0) (defaultDiagnosticOpts @a) -#endif a) (mkDecorated $ map ppr $ diagnosticHints a) mkWarnMsg :: DynFlags -> Maybe DiagnosticReason -> b -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -49,11 +49,7 @@ initParserState = Lexer.initParserState -#if MIN_VERSION_ghc(9,5,0) pattern HsParsedModule :: Located (HsModule GhcPs) -> [FilePath] -> GHC.HsParsedModule -#else -pattern HsParsedModule :: Located HsModule -> [FilePath] -> GHC.HsParsedModule -#endif pattern HsParsedModule { hpm_module , hpm_src_files 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 @@ -10,22 +10,17 @@ , readBinCoreFile , writeBinCoreFile , getImplicitBinds - , occNamePrefixes) where + ) where import Control.Monad -import Control.Monad.IO.Class -import Data.Foldable import Data.IORef -import Data.List (isPrefixOf) import Data.Maybe -import qualified Data.Text as T import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util import GHC.Core import GHC.CoreToIface import GHC.Fingerprint import GHC.Iface.Binary -import GHC.Iface.Env #if MIN_VERSION_ghc(9,11,0) import qualified GHC.Iface.Load as Iface #endif @@ -43,38 +38,11 @@ data CoreFile = CoreFile - { cf_bindings :: [TopIfaceBinding IfaceId] + { cf_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -- ^ The actual core file bindings, deserialized lazily , cf_iface_hash :: !Fingerprint } --- | Like IfaceBinding, but lets us serialize internal names as well -data TopIfaceBinding v - = TopIfaceNonRec v IfaceExpr - | TopIfaceRec [(v, IfaceExpr)] - deriving (Functor, Foldable, Traversable) - --- | GHC doesn't export 'tcIdDetails', 'tcIfaceInfo', or 'tcIfaceType', --- but it does export 'tcIfaceDecl' --- so we use `IfaceDecl` as a container for all of these --- invariant: 'IfaceId' is always a 'IfaceId' constructor -type IfaceId = IfaceDecl - -instance Binary (TopIfaceBinding IfaceId) where - put_ bh (TopIfaceNonRec d e) = do - putByte bh 0 - put_ bh d - put_ bh e - put_ bh (TopIfaceRec vs) = do - putByte bh 1 - put_ bh vs - get bh = do - t <- getByte bh - case t of - 0 -> TopIfaceNonRec <$> get bh <*> get bh - 1 -> TopIfaceRec <$> get bh - _ -> error "Binary TopIfaceBinding" - instance Binary CoreFile where put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp get bh = CoreFile <$> lazyGet bh <*> get bh @@ -118,21 +86,8 @@ :: Fingerprint -- ^ Hash of the interface this was generated from -> CgGuts -> CoreFile -#if MIN_VERSION_ghc(9,5,0) -- In GHC 9.6, implicit binds are tidied and part of core binds -codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) cg_binds) hash -#else -codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) $ filter isNotImplictBind cg_binds) hash - --- | Implicit binds can be generated from the interface and are not tidied, --- so we must filter them out -isNotImplictBind :: CoreBind -> Bool -isNotImplictBind bind = not . all isImplicitId $ bindBindings bind - -bindBindings :: CoreBind -> [Var] -bindBindings (NonRec b _) = [b] -bindBindings (Rec bnds) = map fst bnds -#endif +codeGutsToCoreFile hash CgGuts{..} = CoreFile (map toIfaceTopBind cg_binds) hash getImplicitBinds :: TyCon -> [CoreBind] getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc @@ -156,111 +111,7 @@ Nothing -> error "get_dfn: no unfolding template" Just x -> x -toIfaceTopBndr1 :: Module -> Id -> IfaceId -toIfaceTopBndr1 mod identifier - = IfaceId (mangleDeclName mod $ getName identifier) - (toIfaceType (idType identifier)) - (toIfaceIdDetails (idDetails identifier)) - (toIfaceIdInfo (idInfo identifier)) - -toIfaceTopBind1 :: Module -> Bind Id -> TopIfaceBinding IfaceId -toIfaceTopBind1 mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr1 mod b) (toIfaceExpr r) -toIfaceTopBind1 mod (Rec prs) = TopIfaceRec [(toIfaceTopBndr1 mod b, toIfaceExpr r) | (b,r) <- prs] - typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram typecheckCoreFile this_mod type_var (CoreFile prepd_binding _) = initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do - tcTopIfaceBindings1 type_var prepd_binding - --- | Internal names can't be serialized, so we mange them --- to an external name and restore at deserialization time --- This is necessary because we rely on stuffing TopIfaceBindings into --- a IfaceId because we don't have access to 'tcIfaceType' etc.. -mangleDeclName :: Module -> Name -> Name -mangleDeclName mod name - | isExternalName name = name - | otherwise = mkExternalName (nameUnique name) (mangleModule mod) (nameOccName name) (nameSrcSpan name) - --- | Mangle the module name too to avoid conflicts -mangleModule :: Module -> Module -mangleModule mod = mkModule (moduleUnit mod) (mkModuleName $ "GHCIDEINTERNAL" ++ moduleNameString (moduleName mod)) - -isGhcideModule :: Module -> Bool -isGhcideModule mod = "GHCIDEINTERNAL" `isPrefixOf` (moduleNameString $ moduleName mod) - --- Is this a fake external name that we need to make into an internal name? -isGhcideName :: Name -> Bool -isGhcideName = isGhcideModule . nameModule - -tcTopIfaceBindings1 :: IORef TypeEnv -> [TopIfaceBinding IfaceId] - -> IfL [CoreBind] -tcTopIfaceBindings1 ty_var ver_decls - = do - int <- mapM (traverse tcIfaceId) ver_decls - let all_ids = concatMap toList int - liftIO $ modifyIORef ty_var (flip extendTypeEnvList $ map AnId all_ids) - extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int - -tcIfaceId :: IfaceId -> IfL Id -tcIfaceId = fmap getIfaceId . tcIfaceDecl False <=< unmangle_decl_name - where - unmangle_decl_name ifid@IfaceId{ ifName = name } - -- Check if the name is mangled - | isGhcideName name = do - name' <- newIfaceName (mkVarOcc $ getOccString name) - pure $ ifid{ ifName = name' } - | otherwise = pure ifid - unmangle_decl_name _ifid = error "tcIfaceId: got non IfaceId: " - -- invariant: 'IfaceId' is always a 'IfaceId' constructor - getIfaceId (AnId identifier) = identifier - getIfaceId _ = error "tcIfaceId: got non Id" - -tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind -tc_iface_bindings (TopIfaceNonRec v e) = do - e' <- tcIfaceExpr e - pure $ NonRec v e' -tc_iface_bindings (TopIfaceRec vs) = do - vs' <- traverse (\(v, e) -> (v,) <$> tcIfaceExpr e) vs - pure $ Rec vs' - --- | Prefixes that can occur in a GHC OccName -occNamePrefixes :: [T.Text] -occNamePrefixes = - [ - -- long ones - "$con2tag_" - , "$tag2con_" - , "$maxtag_" - - -- four chars - , "$sel:" - , "$tc'" - - -- three chars - , "$dm" - , "$co" - , "$tc" - , "$cp" - , "$fx" - - -- two chars - , "$W" - , "$w" - , "$m" - , "$b" - , "$c" - , "$d" - , "$i" - , "$s" - , "$f" - , "$r" - , "C:" - , "N:" - , "D:" - , "$p" - , "$L" - , "$f" - , "$t" - , "$c" - , "$m" - ] + tcTopIfaceBindings type_var prepd_binding diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -78,15 +78,9 @@ -- The function signature changes based on the GHC version. -- While this is not desirable, it avoids more CPP statements in code -- that implements actual logic. -#if MIN_VERSION_ghc(9,5,0) diagFromGhcErrorMessages :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic] diagFromGhcErrorMessages sourceParser dflags errs = diagFromErrMsgs sourceParser dflags errs -#else -diagFromGhcErrorMessages :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope Compat.DecoratedSDoc) -> [FileDiagnostic] -diagFromGhcErrorMessages sourceParser dflags errs = - diagFromSDocErrMsgs sourceParser dflags errs -#endif diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic] diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . Compat.bagToList diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -7,9 +7,7 @@ -- | Orphan instances for GHC. -- Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where -import Development.IDE.GHC.Compat hiding - (DuplicateRecordFields, - FieldSelectors) +import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import Control.DeepSeq @@ -24,19 +22,16 @@ import GHC.Data.Bag import GHC.Data.FastString import qualified GHC.Data.StringBuffer as SB +import GHC.Iface.Ext.Types import GHC.Parser.Annotation -import GHC.Types.FieldLabel (DuplicateRecordFields (DuplicateRecordFields, NoDuplicateRecordFields), - FieldSelectors (FieldSelectors, NoFieldSelectors)) import GHC.Types.PkgQual import GHC.Types.SrcLoc -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,5,0) import GHC.Unit.Home.ModInfo import GHC.Unit.Module.Location (ModLocation (..)) import GHC.Unit.Module.WholeCoreBindings -#endif -- Orphan instance for Shake.hs -- https://hub.darcs.net/ross/transformers/issue/86 @@ -68,13 +63,10 @@ rnf (DotA f) = rnf f rnf (DotDLL f) = rnf f rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b -#if MIN_VERSION_ghc(9,5,0) rnf (CoreBindings wcb) = rnf wcb rnf (LoadedBCOs us) = rnf us #endif -#endif -#if MIN_VERSION_ghc(9,5,0) instance NFData WholeCoreBindings where #if MIN_VERSION_ghc(9,11,0) rnf (WholeCoreBindings bs m ml f) = rnf bs `seq` rnf m `seq` rnf ml `seq` rnf f @@ -88,7 +80,6 @@ #else rnf (ModLocation mf f1 f2 f3 f4 f5) = rnf mf `seq` rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 #endif -#endif instance Show PackageFlag where show = unpack . printOutputable instance Show InteractiveImport where show = unpack . printOutputable @@ -103,12 +94,6 @@ instance Show Module where show = moduleNameString . moduleName - -#if !MIN_VERSION_ghc(9,5,0) -instance (NFData l, NFData e) => NFData (GenLocated l e) where - rnf (L l e) = rnf l `seq` rnf e -#endif - instance Show ModSummary where show = show . ms_mod @@ -191,11 +176,6 @@ instance Show a => Show (Bag a) where show = show . bagToList -#if !MIN_VERSION_ghc(9,5,0) -instance NFData HsDocString where - rnf = rwhnf -#endif - instance Show ModGuts where show _ = "modguts" instance NFData ModGuts where @@ -204,11 +184,7 @@ instance NFData (ImportDecl GhcPs) where rnf = rwhnf -#if MIN_VERSION_ghc(9,5,0) instance (NFData (HsModule a)) where -#else -instance (NFData HsModule) where -#endif rnf = rwhnf instance Show OccName where show = unpack . printOutputable @@ -239,10 +215,8 @@ instance NFData NodeKey where rnf = rwhnf -#if MIN_VERSION_ghc(9,5,0) instance NFData HomeModLinkable where rnf = rwhnf -#endif instance NFData (HsExpr (GhcPass Renamed)) where rnf = rwhnf @@ -261,16 +235,3 @@ instance NFData (UniqFM Name [Name]) where rnf (ufmToIntMap -> m) = rnf m - -#if !MIN_VERSION_ghc(9,5,0) -instance NFData DuplicateRecordFields where - rnf DuplicateRecordFields = () - rnf NoDuplicateRecordFields = () - -instance NFData FieldSelectors where - rnf FieldSelectors = () - rnf NoFieldSelectors = () - -instance NFData FieldLabel where - rnf (FieldLabel a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d -#endif 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 @@ -27,7 +27,9 @@ dontWriteHieFiles, disableWarningsAsErrors, printOutputable, - getExtensions + printOutputableOneLine, + getExtensions, + stripOccNamePrefix, ) where import Control.Concurrent @@ -62,6 +64,7 @@ import Ide.PluginUtils (unescape) import System.FilePath +import Data.Monoid (First (..)) import GHC.Data.EnumSet import GHC.Data.FastString import GHC.Data.StringBuffer @@ -262,12 +265,70 @@ -- 1. print with a user-friendly style: `a_a4ME` as `a`. -- 2. unescape escape sequences of printable unicode characters within a pair of double quotes printOutputable :: Outputable a => a -> T.Text -printOutputable = +printOutputable = printOutputable' printWithoutUniques + +printOutputableOneLine :: Outputable a => a -> T.Text +printOutputableOneLine = printOutputable' printWithoutUniquesOneLine + +printOutputable' :: Outputable a => (a -> String) -> a -> T.Text +printOutputable' print = -- IfaceTyLit from GHC.Iface.Type implements Outputable with 'show'. -- Showing a String escapes non-ascii printable characters. We unescape it here. -- More discussion at https://github.com/haskell/haskell-language-server/issues/3115. - unescape . T.pack . printWithoutUniques + unescape . T.pack . print {-# INLINE printOutputable #-} getExtensions :: ParsedModule -> [Extension] getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary + +-- | When e.g. DuplicateRecordFields is enabled, compiler generates +-- names like "$sel:accessor:One" and "$sel:accessor:Two" to +-- disambiguate record selectors +-- https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation +stripOccNamePrefix :: T.Text -> T.Text +stripOccNamePrefix name = T.takeWhile (/=':') $ fromMaybe name $ + getFirst $ foldMap (First . (`T.stripPrefix` name)) + occNamePrefixes + +-- | Prefixes that can occur in a GHC OccName +occNamePrefixes :: [T.Text] +occNamePrefixes = + [ + -- long ones + "$con2tag_" + , "$tag2con_" + , "$maxtag_" + + -- four chars + , "$sel:" + , "$tc'" + + -- three chars + , "$dm" + , "$co" + , "$tc" + , "$cp" + , "$fx" + + -- two chars + , "$W" + , "$w" + , "$m" + , "$b" + , "$c" + , "$d" + , "$i" + , "$s" + , "$f" + , "$r" + , "C:" + , "N:" + , "D:" + , "$p" + , "$L" + , "$f" + , "$t" + , "$c" + , "$m" + ] + 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 @@ -29,6 +29,7 @@ , lookupModuleFile , BootIdMap , insertBootId + , lookupFingerprint ) where import Control.DeepSeq @@ -49,6 +50,8 @@ import Data.Maybe import Data.Tuple.Extra hiding (first, second) import Development.IDE.GHC.Compat +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.Types.Diagnostics @@ -136,23 +139,35 @@ data DependencyInformation = DependencyInformation - { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) + { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) -- ^ Nodes that cannot be processed correctly. - , depModules :: !(FilePathIdMap ShowableModule) - , depModuleDeps :: !(FilePathIdMap FilePathIdSet) + , depModules :: !(FilePathIdMap ShowableModule) + , depModuleDeps :: !(FilePathIdMap FilePathIdSet) -- ^ For a non-error node, this contains the set of module immediate dependencies -- in the same package. - , depReverseModuleDeps :: !(IntMap IntSet) + , depReverseModuleDeps :: !(IntMap IntSet) -- ^ Contains a reverse mapping from a module to all those that immediately depend on it. - , depPathIdMap :: !PathIdMap + , depPathIdMap :: !PathIdMap -- ^ Map from FilePath to FilePathId - , depBootMap :: !BootIdMap + , depBootMap :: !BootIdMap -- ^ Map from hs-boot file to the corresponding hs file - , depModuleFiles :: !(ShowableModuleEnv FilePathId) + , depModuleFiles :: !(ShowableModuleEnv FilePathId) -- ^ Map from Module to the corresponding non-boot hs file - , depModuleGraph :: !ModuleGraph + , depModuleGraph :: !ModuleGraph + , depTransDepsFingerprints :: !(FilePathIdMap Fingerprint) + -- ^ Map from Module to fingerprint of the transitive dependencies of the module. + , depTransReverseDepsFingerprints :: !(FilePathIdMap Fingerprint) + -- ^ Map from FilePathId to the fingerprint of the transitive reverse dependencies of the module. + , depImmediateReverseDepsFingerprints :: !(FilePathIdMap Fingerprint) + -- ^ Map from FilePathId to the fingerprint of the immediate reverse dependencies of the module. } deriving (Show, Generic) +lookupFingerprint :: NormalizedFilePath -> DependencyInformation -> FilePathIdMap Fingerprint -> Maybe Fingerprint +lookupFingerprint fileId DependencyInformation {..} depFingerprintMap = + do + FilePathId cur_id <- lookupPathToId depPathIdMap fileId + IntMap.lookup cur_id depFingerprintMap + newtype ShowableModule = ShowableModule {showableModule :: Module} deriving NFData @@ -228,8 +243,8 @@ SuccessNode _ <> ErrorNode errs = ErrorNode errs SuccessNode a <> SuccessNode _ = SuccessNode a -processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> DependencyInformation -processDependencyInformation RawDependencyInformation{..} rawBootMap mg = +processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> FilePathIdMap Fingerprint -> DependencyInformation +processDependencyInformation RawDependencyInformation{..} rawBootMap mg shallowFingerMap = DependencyInformation { depErrorNodes = IntMap.fromList errorNodes , depModuleDeps = moduleDeps @@ -239,6 +254,9 @@ , depBootMap = rawBootMap , depModuleFiles = ShowableModuleEnv reverseModuleMap , depModuleGraph = mg + , depTransDepsFingerprints = buildTransDepsFingerprintMap moduleDeps shallowFingerMap + , depTransReverseDepsFingerprints = buildTransDepsFingerprintMap reverseModuleDeps shallowFingerMap + , depImmediateReverseDepsFingerprints = buildImmediateDepsFingerprintMap reverseModuleDeps shallowFingerMap } where resultGraph = buildResultGraph rawImports (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph @@ -398,3 +416,44 @@ instance Show NamedModuleDep where show NamedModuleDep{..} = show nmdFilePath + + +buildImmediateDepsFingerprintMap :: FilePathIdMap FilePathIdSet -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint +buildImmediateDepsFingerprintMap modulesDeps shallowFingers = + IntMap.fromList + $ map + ( \k -> + ( k, + Util.fingerprintFingerprints $ + map + (shallowFingers IntMap.!) + (k : IntSet.toList (IntMap.findWithDefault IntSet.empty k modulesDeps)) + ) + ) + $ IntMap.keys shallowFingers + +-- | Build a map from file path to its full fingerprint. +-- The fingerprint is depend on both the fingerprints of the file and all its dependencies. +-- This is used to determine if a file has changed and needs to be reloaded. +buildTransDepsFingerprintMap :: FilePathIdMap FilePathIdSet -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint +buildTransDepsFingerprintMap modulesDeps shallowFingers = go keys IntMap.empty + where + keys = IntMap.keys shallowFingers + go :: [IntSet.Key] -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint + go keys acc = + case keys of + [] -> acc + k : ks -> + if IntMap.member k acc + -- already in the map, so we can skip + then go ks acc + -- not in the map, so we need to add it + else + let -- get the dependencies of the current key + deps = IntSet.toList $ IntMap.findWithDefault IntSet.empty k modulesDeps + -- add fingerprints of the dependencies to the accumulator + depFingerprints = go deps acc + -- combine the fingerprints of the dependencies with the current key + combinedFingerprints = Util.fingerprintFingerprints $ shallowFingers IntMap.! k : map (depFingerprints IntMap.!) deps + in -- add the combined fingerprints to the accumulator + go ks (IntMap.insert k combinedFingerprints depFingerprints) 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 @@ -145,9 +145,8 @@ dflags = hsc_dflags env import_paths = mapMaybe (mkImportDirs env) comp_info other_imports = -#if MIN_VERSION_ghc(9,4,0) - -- On 9.4+ instead of bringing all the units into scope, only bring into scope the units - -- this one depends on + -- 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 @@ -163,17 +162,6 @@ units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue hpt_deps :: [UnitId] hpt_deps = homeUnitDepends units -#else - _import_paths' -#endif - - -- first try to find the module as a file. If we can't find it try to find it in the package - -- database. - -- Here the importPaths for the current modules are added to the front of the import paths from the other components. - -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in - -- each component will end up being found in the wrong place and cause a multi-cradle match failure. - _import_paths' = -- import_paths' is only used in GHC < 9.4 - import_paths toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -11,6 +11,7 @@ , Log(..) , ThreadQueue , runWithWorkerThreads + , Setup (..) ) where import Control.Concurrent.STM @@ -81,6 +82,17 @@ LogLspServer msg -> pretty msg LogServerShutdownMessage -> "Received shutdown message" +data Setup config m a + = MkSetup + { doInitialize :: LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)) + -- ^ the callback invoked when the language server receives the 'Method_Initialize' request + , staticHandlers :: LSP.Handlers m + -- ^ the statically known handlers of the lsp server + , interpretHandler :: (LanguageContextEnv config, a) -> m <~> IO + -- ^ how to interpret @m@ to 'IO' and how to lift 'IO' into @m@ + , onExit :: [IO ()] + -- ^ a list of 'IO' actions that clean up resources and must be run when the server shuts down + } runLanguageServer :: forall config a m. (Show config) @@ -90,18 +102,16 @@ -> Handle -- output -> config -> (config -> Value -> Either T.Text config) - -> (config -> m config ()) - -> (MVar () - -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)), - LSP.Handlers (m config), - (LanguageContextEnv config, a) -> m config <~> IO)) + -> (config -> m ()) + -> (MVar () -> IO (Setup config m a)) -> IO () runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do -- This MVar becomes full when the server thread exits or we receive exit message from client. -- LSP server will be canceled when it's full. clientMsgVar <- newEmptyMVar - (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar + MkSetup + { doInitialize, staticHandlers, interpretHandler, onExit } <- setup clientMsgVar let serverDefinition = LSP.ServerDefinition { LSP.parseConfig = parseConfig @@ -115,28 +125,29 @@ , LSP.options = modifyOptions options } - let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog) + let lspCologAction :: forall io. MonadIO io => Colog.LogAction io (Colog.WithSeverity LspServerLog) lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder) - void $ untilMVar clientMsgVar $ - void $ LSP.runServerWithHandles + let runServer = + LSP.runServerWithHandles lspCologAction lspCologAction inH outH serverDefinition + untilMVar clientMsgVar $ + runServer `finally` sequence_ onExit + setupLSP :: - forall config err. + forall config. Recorder (WithPriority Log) -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) -> MVar () - -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), - LSP.Handlers (ServerM config), - (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) + -> IO (Setup config (ServerM config) IdeState) setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available @@ -171,7 +182,7 @@ cancelled <- readTVar cancelledRequests unless (reqId `Set.member` cancelled) retry - let asyncHandlers = mconcat + let staticHandlers = mconcat [ userHandlers , cancelHandler cancelRequest , exitHandler exit @@ -184,9 +195,11 @@ let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO - pure (doInitialize, asyncHandlers, interpretHandler) + let onExit = [stopReactorLoop, exit] + pure MkSetup {doInitialize, staticHandlers, interpretHandler, onExit} + handleInit :: Recorder (WithPriority Log) -> FilePath -- ^ root directory, see Note [Root Directory] @@ -266,10 +279,12 @@ liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) -- | Runs the action until it ends or until the given MVar is put. +-- It is important, that the thread that puts the 'MVar' is not dropped before it puts the 'MVar' i.e. it should +-- occur as the final action in a 'finally' or 'bracket', because otherwise this thread will finish early (as soon +-- as the thread receives the BlockedIndefinitelyOnMVar exception) -- Rethrows any exceptions. -untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () -untilMVar mvar io = void $ - waitAnyCancel =<< traverse async [ io , readMVar mvar ] +untilMVar :: MonadUnliftIO m => MVar () -> m a -> m () +untilMVar mvar io = race_ (readMVar mvar) io cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} -> 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 @@ -12,11 +12,9 @@ ) where import Control.Concurrent.Extra (withNumCapabilities) -import Control.Concurrent.MVar (newEmptyMVar, +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, tryReadMVar) import Control.Concurrent.STM.Stats (dumpSTMStats) -import Control.Exception.Safe (SomeException, - displayException) import Control.Monad.Extra (concatMapM, unless, when) import Control.Monad.IO.Class (liftIO) @@ -320,9 +318,8 @@ ioT <- offsetTime logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) - ideStateVar <- newEmptyMVar - let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState - getIdeState env rootPath withHieDb threadQueue = do + let getIdeState :: MVar IdeState -> LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState + getIdeState ideStateVar env rootPath withHieDb threadQueue = do t <- ioT logWith recorder Info $ LogLspStartDuration t sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue) @@ -355,9 +352,9 @@ putMVar ideStateVar ide pure ide - let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) getIdeState + let setup ideStateVar = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) (getIdeState ideStateVar) -- See Note [Client configuration in Rules] - onConfigChange cfg = do + onConfigChange ideStateVar cfg = do -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint let cfgObj = J.toJSON cfg mide <- liftIO $ tryReadMVar ideStateVar @@ -370,7 +367,9 @@ modifyClientSettings ide (const $ Just cfgObj) return [toNoFileKey Rules.GetClientSettings] - runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup + do + ideStateVar <- newEmptyMVar + runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig (onConfigChange ideStateVar) (setup ideStateVar) dumpSTMStats Check argFiles -> do let dir = argsProjectRoot 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 @@ -114,15 +114,10 @@ -- Drop any explicit imports in ImportDecl if not hidden dropListFromImportDecl :: LImportDecl GhcPs -> LImportDecl GhcPs dropListFromImportDecl iDecl = let -#if MIN_VERSION_ghc(9,5,0) f d@ImportDecl {ideclImportList} = case ideclImportList of Just (Exactly, _) -> d {ideclImportList=Nothing} -#else - f d@ImportDecl {ideclHiding} = case ideclHiding of - Just (False, _) -> d {ideclHiding=Nothing} -#endif -- if hiding or Nothing just return d - _ -> d + _ -> d f x = x in f <$> iDecl @@ -137,11 +132,11 @@ name <- liftIO $ lookupNameCache nc mod occ mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file let (dm,km) = case mdkm of - Just (DKMap docMap tyThingMap, _) -> (docMap,tyThingMap) - Nothing -> (mempty, mempty) + Just (DKMap docMap tyThingMap _argDocMap, _) -> (docMap,tyThingMap) + Nothing -> (mempty, mempty) doc <- case lookupNameEnv dm name of Just doc -> pure $ spanDocToMarkdown doc - Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name + Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name typ <- case lookupNameEnv km name of _ | not needType -> pure Nothing Just ty -> pure (safeTyThingType 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 @@ -37,24 +37,26 @@ import Data.Function (on) import qualified Data.HashSet as HashSet -import Data.Monoid (First (..)) import Data.Ord (Down (Down)) import qualified Data.Set as Set import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (isQual, ppr) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util -import Development.IDE.GHC.CoreFile (occNamePrefixes) import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Exports import Development.IDE.Types.Options +import GHC.Iface.Ext.Types (HieAST, + NodeInfo (..)) +import GHC.Iface.Ext.Utils (nodeInfo) import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), IdePlugins (..), PluginId) +import Language.Haskell.Syntax.Basic import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types import qualified Language.LSP.VFS as VFS @@ -74,9 +76,6 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,5,0) -import Language.Haskell.Syntax.Basic -#endif -- Chunk size used for parallelizing fuzzy matching chunkSize :: Int @@ -138,42 +137,23 @@ | pos `isInsideSrcSpan` r = Just TypeContext goInline _ = Nothing -#if MIN_VERSION_ghc(9,5,0) importGo :: GHC.LImportDecl GhcPs -> Maybe Context importGo (L (locA -> r) impDecl) | pos `isInsideSrcSpan` r = importInline importModuleName (fmap (fmap reLoc) $ ideclImportList impDecl) -#else - importGo :: GHC.LImportDecl GhcPs -> Maybe Context - importGo (L (locA -> r) impDecl) - | pos `isInsideSrcSpan` r - = importInline importModuleName (fmap (fmap reLoc) $ ideclHiding impDecl) -#endif <|> Just (ImportContext importModuleName) | otherwise = Nothing where importModuleName = moduleNameString $ unLoc $ ideclName impDecl -- importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context -#if MIN_VERSION_ghc(9,5,0) importInline modName (Just (EverythingBut, L r _)) | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName | otherwise = Nothing -#else - importInline modName (Just (True, L r _)) - | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName - | otherwise = Nothing -#endif -#if MIN_VERSION_ghc(9,5,0) importInline modName (Just (Exactly, L r _)) | pos `isInsideSrcSpan` r = Just $ ImportListContext modName | otherwise = Nothing -#else - importInline modName (Just (False, L r _)) - | pos `isInsideSrcSpan` r = Just $ ImportListContext modName - | otherwise = Nothing -#endif importInline _ _ = Nothing @@ -261,7 +241,7 @@ compKind = occNameToComKind origName isTypeCompl = isTcOcc origName typeText = Nothing - label = stripPrefix $ printOutputable origName + label = stripOccNamePrefix $ printOutputable origName insertText = case isInfix of Nothing -> label Just LeftSide -> label <> "`" @@ -801,17 +781,6 @@ -- --------------------------------------------------------------------- --- | Under certain circumstance GHC generates some extra stuff that we --- don't want in the autocompleted symbols - {- When e.g. DuplicateRecordFields is enabled, compiler generates - names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors - https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation - -} --- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace. -stripPrefix :: T.Text -> T.Text -stripPrefix name = T.takeWhile (/=':') $ fromMaybe name $ - getFirst $ foldMap (First . (`T.stripPrefix` name)) occNamePrefixes - mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> Maybe (LImportDecl GhcPs) -> CompItem mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r where @@ -912,7 +881,9 @@ [] -> Nothing (x:xs) -> do let modParts = reverse $ filter (not .T.null) xs - modName = T.intercalate "." modParts + -- Must check the prefix is a valid module name, else record dot accesses treat + -- the record name as a qualName for search and generated imports + modName = if all (isUpper . T.head) modParts then T.intercalate "." modParts else "" return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos } completionPrefixPos :: PosPrefixInfo -> Position diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -16,7 +16,7 @@ import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) -import Control.Lens ((?~)) +import Control.Lens (to, (?~), (^?)) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -25,13 +25,17 @@ import qualified Data.Aeson.Types as A import Data.List (find) import qualified Data.Map as Map -import Data.Maybe (catMaybes, maybeToList) +import Data.Maybe (catMaybes, isJust, + maybeToList) import qualified Data.Text as T import Development.IDE (FileDiagnostic (..), GhcSession (..), HscEnvEq (hscEnv), RuleResult, Rules, Uri, - define, srcSpanToRange, + _SomeStructuredMessage, + define, + fdStructuredMessageL, + srcSpanToRange, usePropertyAction) import Development.IDE.Core.Compile (TcModuleResult (..)) import Development.IDE.Core.PluginUtils @@ -45,6 +49,10 @@ use) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Error (_TcRnMessage, + _TcRnMissingSignature, + msgEnvelopeErrorL, + stripTcRnMessageContext) import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes import Development.IDE.Types.Location (Position (Position, _line), @@ -129,9 +137,9 @@ -- dummy type to make sure HLS resolves our lens [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve) | diag <- diags - , let lspDiag@Diagnostic {_range} = fdLspDiagnostic diag + , let Diagnostic {_range} = fdLspDiagnostic diag , fdFilePath diag == nfp - , isGlobalDiagnostic lspDiag] + , isGlobalDiagnostic diag] -- The second option is to generate lenses from the GlobalBindingTypeSig -- rule. This is the only type that needs to have the range adjusted -- with PositionMapping. @@ -200,7 +208,7 @@ pure $ InR Null -------------------------------------------------------------------------------- -suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, TextEdit)] +suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> [(T.Text, TextEdit)] suggestSignature isQuickFix mGblSigs diag = maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag) @@ -208,14 +216,19 @@ -- works with a diagnostic, which then calls the secondary function with -- whatever pieces of the diagnostic it needs. This allows the resolve function, -- which no longer has the Diagnostic, to still call the secondary functions. -suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> Maybe (T.Text, TextEdit) -suggestGlobalSignature isQuickFix mGblSigs diag@Diagnostic{_range} +suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> Maybe (T.Text, TextEdit) +suggestGlobalSignature isQuickFix mGblSigs diag@FileDiagnostic {fdLspDiagnostic = Diagnostic {_range}} | isGlobalDiagnostic diag = suggestGlobalSignature' isQuickFix mGblSigs Nothing _range | otherwise = Nothing -isGlobalDiagnostic :: Diagnostic -> Bool -isGlobalDiagnostic Diagnostic{_message} = _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) +isGlobalDiagnostic :: FileDiagnostic -> Bool +isGlobalDiagnostic diag = diag ^? fdStructuredMessageL + . _SomeStructuredMessage + . msgEnvelopeErrorL + . _TcRnMessage + . _TcRnMissingSignature + & isJust -- If a PositionMapping is supplied, this function will call -- gblBindingTypeSigToEdit with it to create a TextEdit in the right location. 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 @@ -67,6 +67,23 @@ import qualified Data.Tree as T import Data.Version (showVersion) import Development.IDE.Types.Shake (WithHieDb) +import GHC.Iface.Ext.Types (EvVarSource (..), + HieAST (..), + HieASTs (..), + HieArgs (..), + HieType (..), Identifier, + IdentifierDetails (..), + NodeInfo (..), Scope, + Span) +import GHC.Iface.Ext.Utils (EvidenceInfo (..), + RefMap, getEvidenceTree, + getScopeFromContext, + hieTypeToIface, + isEvidenceContext, + isEvidenceUse, + isOccurrence, nodeInfo, + recoverFullType, + selectSmallestContaining) import HieDb hiding (pointCommand, withHieDb) import System.Directory (doesFileExist) @@ -113,7 +130,7 @@ getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] getNamesAtPoint hf pos mapping = - concat $ pointCommand hf posFile (rights . M.keys . getNodeIds) + concat $ pointCommand hf posFile (rights . M.keys . getSourceNodeIds) where posFile = fromMaybe pos $ fromCurrentPosition mapping pos @@ -239,7 +256,7 @@ -> HscEnv -> Position -> IO (Maybe (Maybe Range, [T.Text])) -atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km) env pos = +atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos = listToMaybe <$> sequence (pointCommand hf pos hoverInfo) where -- Hover info for values/data @@ -488,7 +505,7 @@ instanceLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _rm _ _) = let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) evTrees = mapMaybe (eitherToMaybe >=> getEvidenceTree _rm) ns - evNs = concatMap (map (evidenceVar) . T.flatten) evTrees + evNs = concatMap (map evidenceVar . T.flatten) evTrees in fmap (nubOrd . concat) $ mapMaybeM (nameToLocation withHieDb lookupModule) evNs diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -13,6 +13,7 @@ , spanDocToMarkdownForTest , DocMap , TyThingMap +, ArgDocMap , srcSpanToMdLink ) where @@ -29,6 +30,7 @@ import System.FilePath import Control.Lens +import Data.IntMap (IntMap) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import qualified Language.LSP.Protocol.Lens as JL @@ -36,13 +38,10 @@ type DocMap = NameEnv SpanDoc type TyThingMap = NameEnv TyThing +type ArgDocMap = NameEnv (IntMap SpanDoc) -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. -#if MIN_VERSION_ghc(9,5,0) unqualIEWrapName :: IEWrappedName GhcPs -> T.Text -#else -unqualIEWrapName :: IEWrappedName RdrName -> T.Text -#endif unqualIEWrapName = printOutputable . rdrNameOcc . ieWrappedName -- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -194,11 +193,10 @@ haddockToMarkdown (H.DocDefList things) = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things) --- we cannot render math by default -haddockToMarkdown (H.DocMathInline _) - = "*cannot render inline math formula*" -haddockToMarkdown (H.DocMathDisplay _) - = "\n\n*cannot render display math formula*\n\n" +haddockToMarkdown (H.DocMathInline s) + = "`" ++ s ++ "`" +haddockToMarkdown (H.DocMathDisplay s) + = "\n```latex\n" ++ s ++ "\n```\n" -- TODO: render tables haddockToMarkdown (H.DocTable _t) 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 @@ -16,6 +16,7 @@ import Control.Monad.IO.Class import Data.Either import Data.Foldable +import Data.IntMap (IntMap) import Data.List.Extra import qualified Data.Map as M import Data.Maybe @@ -28,6 +29,7 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Spans.Common +import GHC.Iface.Ext.Utils (RefMap) import Language.LSP.Protocol.Types (filePathToUri, getUri) import Prelude hiding (mod) import System.Directory @@ -41,21 +43,27 @@ -> IO DocAndTyThingMap mkDocMap env rm this_mod = do - (Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod + (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 k <- foldrM getType (tcg_type_env this_mod) names - pure $ DKMap d k + a <- foldrM getArgDocs (fmap (\(_, m) -> fmap (\x -> [hsDocString x] `SpanDocString` SpanDocUris Nothing Nothing) m) this_arg_docs) names + pure $ DKMap d k a where 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 <- getDocumentationTryGhc env n + (doc, _argDoc) <- getDocumentationTryGhc env n pure $ extendNameEnv nameMap n doc getType n nameMap | Nothing <- lookupNameEnv nameMap n = do kind <- lookupKind env n pure $ maybe nameMap (extendNameEnv nameMap n) kind | otherwise = pure nameMap + getArgDocs n nameMap + | maybe True (mod ==) $ nameModule_maybe n = pure nameMap + | otherwise = do + (_doc, argDoc) <- getDocumentationTryGhc env n + pure $ extendNameEnv nameMap n argDoc names = rights $ S.toList idents idents = M.keysSet rm mod = tcg_mod this_mod @@ -64,23 +72,23 @@ lookupKind env = fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env -getDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc +getDocumentationTryGhc :: HscEnv -> Name -> IO (SpanDoc, IntMap SpanDoc) getDocumentationTryGhc env n = - (fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env [n]) - `catch` (\(_ :: IOEnvFailure) -> pure emptySpanDoc) + (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env [n]) + `catch` (\(_ :: IOEnvFailure) -> pure (emptySpanDoc, mempty)) -getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc] +getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)] getDocumentationsTryGhc env names = do resOr <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names case resOr of Left _ -> return [] Right res -> zipWithM unwrap res names where - unwrap (Right (Just docs, _)) n = SpanDocString (map hsDocString docs) <$> getUris n + unwrap (Right (Just docs, argDocs)) n = (\uris -> (SpanDocString (map hsDocString docs) uris, fmap (\x -> SpanDocString [hsDocString x] uris) argDocs)) <$> getUris n unwrap _ n = mkSpanDocText n mkSpanDocText name = - SpanDocText [] <$> getUris name + (\uris -> (SpanDocText [] uris, mempty)) <$> getUris name -- Get the uris to the documentation and source html pages if they exist getUris name = do diff --git a/src/Development/IDE/Spans/LocalBindings.hs b/src/Development/IDE/Spans/LocalBindings.hs --- a/src/Development/IDE/Spans/LocalBindings.hs +++ b/src/Development/IDE/Spans/LocalBindings.hs @@ -17,15 +17,16 @@ import qualified Data.List as L import qualified Data.Map as M import qualified Data.Set as S +import GHC.Iface.Ext.Types (IdentifierDetails (..), + Scope (..)) +import GHC.Iface.Ext.Utils (RefMap, getBindSiteFromContext, + getScopeFromContext) + import Development.IDE.GHC.Compat (Name, NameEnv, RealSrcSpan, - RefMap, Scope (..), Type, - getBindSiteFromContext, - getScopeFromContext, identInfo, - identType, isSystemName, + Type, isSystemName, nonDetNameEnvElts, realSrcSpanEnd, realSrcSpanStart, unitNameEnv) - import Development.IDE.GHC.Error import Development.IDE.Types.Location 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 @@ -24,9 +24,7 @@ ideErrorFromLspDiag, showDiagnostics, showDiagnosticsColored, -#if MIN_VERSION_ghc(9,5,0) showGhcCode, -#endif IdeResultNoDiagnosticsEarlyCutoff, attachReason, attachedReason) where @@ -45,17 +43,11 @@ flagSpecName, wWarningFlags) import Development.IDE.Types.Location import GHC.Generics -#if MIN_VERSION_ghc(9,5,0) import GHC.Types.Error (DiagnosticCode (..), DiagnosticReason (..), diagnosticCode, diagnosticReason, errMsgDiagnostic) -#else -import GHC.Types.Error (DiagnosticReason (..), - diagnosticReason, - errMsgDiagnostic) -#endif import Language.LSP.Diagnostics import Language.LSP.Protocol.Lens (data_) import Language.LSP.Protocol.Types as LSP @@ -110,30 +102,25 @@ fdLspDiagnostic = lspDiag & attachReason (fmap (diagnosticReason . errMsgDiagnostic) mbOrigMsg) - & setGhcCode mbOrigMsg + & attachDiagnosticCode ((diagnosticCode . errMsgDiagnostic) =<< mbOrigMsg) in FileDiagnostic {..} --- | Set the code of the 'LSP.Diagnostic' to the GHC diagnostic code which is linked +-- | Set the code of the 'LSP.Diagnostic' to the GHC diagnostic code, and include the link -- to https://errors.haskell.org/. -setGhcCode :: Maybe (MsgEnvelope GhcMessage) -> LSP.Diagnostic -> LSP.Diagnostic -#if MIN_VERSION_ghc(9,5,0) -setGhcCode mbOrigMsg diag = - let mbGhcCode = do - origMsg <- mbOrigMsg - code <- diagnosticCode (errMsgDiagnostic origMsg) - pure (InR (showGhcCode code)) - in - diag { _code = mbGhcCode <|> _code diag } -#else -setGhcCode _ diag = diag -#endif +attachDiagnosticCode :: Maybe DiagnosticCode -> LSP.Diagnostic -> LSP.Diagnostic +attachDiagnosticCode Nothing diag = diag +attachDiagnosticCode (Just code) diag = + let + textualCode = showGhcCode code + codeDesc = LSP.CodeDescription{ _href = Uri $ "https://errors.haskell.org/messages/" <> textualCode } + in diag { _code = Just (InR textualCode), _codeDescription = Just codeDesc} #if MIN_VERSION_ghc(9,9,0) -- DiagnosticCode only got a show instance in 9.10.1 showGhcCode :: DiagnosticCode -> T.Text showGhcCode = T.pack . show -#elif MIN_VERSION_ghc(9,5,0) +#else showGhcCode :: DiagnosticCode -> T.Text showGhcCode (DiagnosticCode prefix c) = T.pack $ prefix ++ "-" ++ printf "%05d" c #endif 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 @@ -68,10 +68,12 @@ , optCheckParents :: IO CheckParents -- ^ When to typecheck reverse dependencies of a file , optHaddockParse :: OptHaddockParse - -- ^ Whether to return result of parsing module with Opt_Haddock. - -- Otherwise, return the result of parsing without Opt_Haddock, so - -- that the parsed module contains the result of Opt_KeepRawTokenStream, - -- which might be necessary for hlint. + -- ^ Whether to parse modules with '-haddock' by default. + -- If 'HaddockParse' is given, we parse local haskell modules with the + -- '-haddock' flag enables. + -- If a plugin requires the parsed sources *without* '-haddock', it needs + -- to use rules that explicitly disable the '-haddock' flag. + -- See call sites of 'withoutOptHaddock' for rules that parse without '-haddock'. , optModifyDynFlags :: Config -> DynFlagsModifications -- ^ Will be called right after setting up a new cradle, -- allowing to customize the Ghc options used