diff --git a/cabal-941.project b/cabal-941.project new file mode 100644 index 00000000000..28d2fda2d46 --- /dev/null +++ b/cabal-941.project @@ -0,0 +1,92 @@ +packages: + ./hie-compat + ./shake-bench + ./hls-graph + ./hls-plugin-api + ./ghcide + +-- Standard location for temporary packages needed for particular environments +-- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script +-- See https://github.com/haskell/haskell-language-server/blob/master/.gitlab-ci.yml +optional-packages: vendored/*/*.cabal + + +tests: true + +package * + -- ghc 8.10 cannot build ghc-lib 9.2 with --haddock + -- ghc-options: -haddock + test-show-details: direct + +write-ghc-environment-files: never + +constraints: + hyphenation +embed, + -- remove this when hlint sets ghc-lib to true by default + -- https://github.com/ndmitchell/hlint/issues/1376 + hlint +ghc-lib, + ghc-lib-parser-ex -auto, + stylish-haskell +ghc-lib + +source-repository-package + type:git + location: https://github.com/wz1000/hiedb + tag: 67b92df2359558091df9102db5b701327308b930 + +source-repository-package + type:git + location: https://github.com/wz1000/hie-bios + tag: aa73d3d2eb89df0003d2468a105e326d71b62cc7 + +-- This is benign and won't affect our ability to release to Hackage, +-- because we only depend on `ekg-json` when a non-default flag +-- is turned on. +source-repository-package + type:git + location: https://github.com/pepeiborra/ekg-json + tag: 7a0af7a8fd38045fd15fb13445bdcc7085325460 + +source-repository-package + type:git + location: https://github.com/parsonsmatt/cereal + tag: b4acf0b778a1d5da305f4de013ce7f32b53d8282 + +allow-newer: + base, ghc-prim, ghc-bignum, ghc, Cabal, binary, bytestring, unix, time, template-haskell, + ghc-paths:Cabal, + -- for shake-bench + Chart:lens, + Chart-diagrams:lens, + + -- ghc-9.2 + ---------- + hiedb:base, + + ekg-wai:time, + -- for shake-bench + Chart-diagrams:diagrams-core, + SVGFonts:diagrams-core, + + -- https://github.com/lspitzner/multistate/pull/8 + multistate:base, + -- https://github.com/lspitzner/data-tree-print/pull/3 + data-tree-print:base, + -- https://github.com/lspitzner/butcher/pull/8 + butcher:base, + + implicit-hie-cradle:bytestring, + implicit-hie-cradle:time + +allow-older: + primitive-extras:primitive-unlifted + +repository head.hackage.ghc.haskell.org + url: https://ghc.gitlab.haskell.org/head.hackage/ + secure: True + key-threshold: 3 + root-keys: + f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89 + 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329 + 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d + +active-repositories: hackage.haskell.org, head.hackage.ghc.haskell.org:override diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 01603987336..810d8a47f15 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -350,7 +350,6 @@ test-suite ghcide-tests -------------------------------------------------------------- ghcide, ghcide-test-utils-internal, - ghc-typelits-knownnat, lsp, lsp-types, hls-plugin-api, @@ -378,6 +377,8 @@ test-suite ghcide-tests build-depends: record-dot-preprocessor, record-hasfield + if impl(ghc < 9.3) + build-depends: ghc-typelits-knownnat hs-source-dirs: test/cabal test/exe bench/lib ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors main-is: Main.hs diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 4a3e932025c..5bc2cd78bbf 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} {-| The logic for setting up a ghcide session by tapping into hie-bios. @@ -100,6 +101,10 @@ import HieDb.Types import HieDb.Utils import qualified System.Random as Random import System.Random (RandomGen) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Debug.Trace +import Control.Exception (evaluate) +import Control.DeepSeq data Log = LogSettingInitialDynFlags @@ -208,11 +213,13 @@ data SessionLoadingOptions = SessionLoadingOptions , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' , getInitialGhcLibDir :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) +#if !MIN_VERSION_ghc(9,3,0) , fakeUid :: UnitId -- ^ unit id used to tag the internal component built by ghcide -- To reuse external interface files the unit ids must match, -- thus make sure to build them with `--this-unit-id` set to the -- same value as the ghcide fake uid +#endif } instance Default SessionLoadingOptions where @@ -221,7 +228,9 @@ instance Default SessionLoadingOptions where ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault +#if !MIN_VERSION_ghc(9,3,0) ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main") +#endif } -- | Find the cradle for a given 'hie.yaml' configuration. @@ -494,7 +503,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do -- Remove all inplace dependencies from package flags for -- components in this HscEnv +#if MIN_VERSION_ghc(9,3,0) + let (df2, uids) = (rawComponentDynFlags, []) +#else let (df2, uids) = removeInplacePackages fakeUid inplace rawComponentDynFlags +#endif let prefix = show rawComponentUnitId -- See Note [Avoiding bad interface files] let hscComponents = sort $ map show uids @@ -517,10 +530,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- that I do not fully understand log Info $ LogMakingNewHscEnv inplace hscEnv <- emptyHscEnv ideNc libDir - newHscEnv <- + !newHscEnv <- -- Add the options for the current component to the HscEnv evalGhcEnv hscEnv $ do - _ <- setSessionDynFlags $ setHomeUnitId_ fakeUid df + _ <- setSessionDynFlags +#if !MIN_VERSION_ghc(9,3,0) + $ setHomeUnitId_ fakeUid +#endif + df getSession -- Modify the map so the hieYaml now maps to the newly created @@ -718,7 +735,11 @@ cradleToOptsAndLibDir recorder cradle file = do logWith recorder Info $ LogNoneCradleFound file return (Left []) +#if MIN_VERSION_ghc(9,3,0) +emptyHscEnv :: NameCache -> FilePath -> IO HscEnv +#else emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv +#endif emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession initDynLinker env @@ -757,7 +778,11 @@ toFlagsMap TargetDetails{..} = [ (l, (targetEnv, targetDepends)) | l <- targetLocations] +#if MIN_VERSION_ghc(9,3,0) +setNameCache :: NameCache -> HscEnv -> HscEnv +#else setNameCache :: IORef NameCache -> HscEnv -> HscEnv +#endif setNameCache nc hsc = hsc { hsc_NC = nc } -- | Create a mapping from FilePaths to HscEnvEqs @@ -773,6 +798,11 @@ newComponentCache newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do let df = componentDynFlags ci hscEnv' <- +#if MIN_VERSION_ghc(9,3,0) + -- Set up a multi component session with the other units on GHC 9.4 + Compat.initUnits (map snd uids) (hscSetFlags df hsc_env) +#elif MIN_VERSION_ghc(9,3,0) + -- This initializes the units for GHC 9.2 -- Add the options for the current component to the HscEnv -- We want to call `setSessionDynFlags` instead of `hscSetFlags` -- because `setSessionDynFlags` also initializes the package database, @@ -782,7 +812,12 @@ newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do evalGhcEnv hsc_env $ do _ <- setSessionDynFlags $ df getSession +#else + -- getOptions is enough to initialize units on GHC <9.2 + pure $ hscSetFlags df hsc_env { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } +#endif + traceM "got new hsc env" let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath henv <- newFunc hscEnv' uids @@ -790,6 +825,7 @@ newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do targetDepends = componentDependencyInfo ci res = (targetEnv, targetDepends) logWith recorder Debug $ LogNewComponentCache res + evaluate $ liftRnf rwhnf $ componentTargets ci let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends ctargets <- concatMapM mk (componentTargets ci) @@ -998,9 +1034,11 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do -- initPackages parses the -package flags and -- sets up the visibility for each component. -- Throws if a -package flag cannot be satisfied. - env <- hscSetFlags dflags'' <$> getSession - final_env' <- liftIO $ wrapPackageSetupException $ Compat.initUnits env - return (hsc_dflags final_env', targets) + -- This only works for GHC <9.2 + -- For GHC >= 9.2, we need to modify the unit env in the hsc_dflags, which + -- is done later in newComponentCache + final_flags <- liftIO $ wrapPackageSetupException $ Compat.oldInitUnits dflags'' + return (final_flags, targets) setIgnoreInterfacePragmas :: DynFlags -> DynFlags setIgnoreInterfacePragmas df = diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 2430ec719a0..0b0ab034230 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -63,6 +63,7 @@ import Data.IORef import Data.List.Extra import Data.Map (Map) import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Data.Maybe import qualified Data.Text as T import Data.Time (UTCTime (..)) @@ -220,7 +221,12 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do -- names in the compiled bytecode, recording the modules that those names -- come from in the IORef,, as these are the modules on whose implementation -- we depend. - compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue + compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr +#if MIN_VERSION_ghc(9,3,0) + -> IO (ForeignHValue, [Linkable], PkgsLoaded) +#else + -> IO ForeignHValue +#endif compile_bco_hook var hsc_env srcspan ds_expr = do { let dflags = hsc_dflags hsc_env @@ -241,13 +247,21 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file = Nothing, ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", - ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" } +#if MIN_VERSION_ghc(9,3,0) + ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file", + ml_dyn_hi_file = panic "hscCompileCoreExpr':ml_dyn_hi_file", +#endif + ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" + } ; let ictxt = hsc_IC hsc_env ; (binding_id, stg_expr, _, _) <- myCoreToStgExpr (hsc_logger hsc_env) (hsc_dflags hsc_env) ictxt +#if MIN_VERSION_ghc(9,3,0) + True -- for bytecode +#endif (icInteractiveModule ictxt) iNTERACTIVELoc prepd_expr @@ -269,7 +283,13 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do -- by default, so we can safely ignore them here. -- Find the linkables for the modules we need - ; let needed_mods = mkUniqSet [ moduleName mod + ; let needed_mods = mkUniqSet [ +#if MIN_VERSION_ghc(9,3,0) + mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids +#else + moduleName mod -- On <= 9.2, just the name is enough because all unit ids will be the same +#endif + #if MIN_VERSION_ghc(9,2,0) | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos #else @@ -277,32 +297,50 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do #endif , Just mod <- [nameModule_maybe n] -- Names from other modules , not (isWiredInName n) -- Exclude wired-in names - , moduleUnitId mod == uid -- Only care about stuff from the home package + , moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set ] - hpt = hsc_HPT hsc_env - uid = homeUnitId_ dflags - mods_transitive = getTransitiveMods hpt needed_mods - -- Non det OK as we will put it into maps later anyway - mods_transitive_list = nonDetEltsUniqSet mods_transitive + home_unit_ids = +#if MIN_VERSION_ghc(9,3,0) + map fst (hugElts $ hsc_HUG hsc_env) +#else + [homeUnitId_ dflags] +#endif + mods_transitive = getTransitiveMods hsc_env needed_mods + -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same + mods_transitive_list = +#if MIN_VERSION_ghc(9,3,0) + mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive +#else + map (mkModule (homeUnitId_ dflags)) + -- Non det OK as we will put it into maps later anyway + $ nonDetEltsUniqSet mods_transitive +#endif - ; lbs <- getLinkables [toNormalizedFilePath' file | mod <- mkHomeModule -#if MIN_VERSION_ghc(9,0,0) - (hscHomeUnit hsc_env) +#if MIN_VERSION_ghc(9,3,0) + ; moduleLocs <- readIORef (fcModuleCache $ hsc_FC hsc_env) #else - uid + ; moduleLocs <- readIORef (hsc_FC hsc_env) #endif - <$> mods_transitive_list - , let ms = fromJust $ mgLookupModule (hsc_mod_graph hsc_env) mod - , let file = fromJust $ ml_hs_file $ ms_location ms - ] - ; let hsc_env' = hsc_env { hsc_HPT = addListToHpt hpt [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] } + ; lbs <- getLinkables [toNormalizedFilePath' file + | mod <- mods_transitive_list + , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs mod + file = case ifr of + InstalledFound loc _ -> + fromJust $ ml_hs_file loc + _ -> panic "hscCompileCoreExprHook: module not found" + ] + ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env -- Essential to do this here after we load the linkables ; keep_lbls <- getLinkablesToKeep ; unload hsc_env' $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) + {- load it -} + ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos + ; let hval = ((expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs), lbss, pkgs) +#elif MIN_VERSION_ghc(9,2,0) {- load it -} ; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs) @@ -314,9 +352,26 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb]) ; return hval } +#if MIN_VERSION_ghc(9,3,0) + -- TODO: support backpack + nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule + nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod _) uid)) = Just $ mkModule uid mod + nodeKeyToInstalledModule _ = Nothing + moduleToNodeKey :: Module -> NodeKey + moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod) +#endif + -- Compute the transitive set of linkables required - getTransitiveMods hpt needed_mods = go emptyUniqSet needed_mods + getTransitiveMods hsc_env needed_mods +#if MIN_VERSION_ghc(9,3,0) + = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods + , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))] + ]) + where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after +#else + = go emptyUniqSet needed_mods where + hpt = hsc_HPT hsc_env go seen new | isEmptyUniqSet new = seen | otherwise = go seen' new' @@ -325,8 +380,7 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do new' = new_deps `minusUniqSet` seen' new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)] - - +#endif -- | Add a Hook to the DynFlags which captures and returns the -- typechecked splices before they are run. This information @@ -390,11 +444,7 @@ mkHiFileResultNoCompile session tcm = do tcGblEnv = tmrTypechecked tcm details <- makeSimpleDetails hsc_env_tmp tcGblEnv sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv -#if MIN_VERSION_ghc(8,10,0) - iface <- mkIfaceTc hsc_env_tmp sf details tcGblEnv -#else - (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv -#endif + iface <- mkIfaceTc hsc_env_tmp sf details ms tcGblEnv pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing mkHiFileResultCompile @@ -416,11 +466,17 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do else do -- write core file -- give variables unique OccNames - (guts, details) <- tidyProgram session simplified_guts + tidy_opts <- initTidyOpts session + (guts, details) <- tidyProgram tidy_opts simplified_guts pure (details, Just guts) #if MIN_VERSION_ghc(9,0,1) - let !partial_iface = force (mkPartialIface session details simplified_guts) + let !partial_iface = force $ mkPartialIface session details +#if MIN_VERSION_ghc(9,3,0) + ms +#endif + simplified_guts + final_iface <- mkFullIface session partial_iface Nothing #elif MIN_VERSION_ghc(8,10,0) let !partial_iface = force (mkPartialIface session details simplified_guts) @@ -464,8 +520,18 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do -- Run corePrep first as we want to test the final version of the program that will -- get translated to STG/Bytecode - (prepd_binds , _) <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons - (prepd_binds', _) <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons +#if MIN_VERSION_ghc(9,3,0) + prepd_binds +#else + (prepd_binds , _) +#endif + <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons +#if MIN_VERSION_ghc(9,3,0) + prepd_binds' +#else + (prepd_binds', _) +#endif + <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons let binds = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds' @@ -552,7 +618,13 @@ generateObjectCode session summary guts = do withWarnings "object" $ \tweak -> do let env' = tweak (hscSetFlags (ms_hspp_opts summary) session) target = platformDefaultBackend (hsc_dflags env') - newFlags = setBackend target $ updOptLevel 0 $ setOutputFile dot_o $ hsc_dflags env' + newFlags = setBackend target $ updOptLevel 0 $ setOutputFile +#if MIN_VERSION_ghc(9,3,0) + (Just dot_o) +#else + dot_o +#endif + $ hsc_dflags env' session' = hscSetFlags newFlags session #if MIN_VERSION_ghc(9,0,1) (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts @@ -565,7 +637,14 @@ generateObjectCode session summary guts = do summary #endif fp - compileFile session' StopLn (outputFilename, Just (As False)) + obj <- compileFile session' driverNoStop (outputFilename, Just (As False)) +#if MIN_VERSION_ghc(9,3,0) + case obj of + Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code" + Just x -> pure x +#else + return obj +#endif let unlinked = DotO dot_o_fp -- Need time to be the modification time for recompilation checking t <- liftIO $ getModificationTime dot_o_fp @@ -614,10 +693,17 @@ update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedMod update_pm_mod_summary up pm = pm{pm_mod_summary = up $ pm_mod_summary pm} +#if MIN_VERSION_ghc(9,3,0) +unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic) +unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors) , fd) = (True, upgradeWarningToError fd) +unDefer (Just (WarningWithFlag Opt_WarnTypedHoles) , fd) = (True, upgradeWarningToError fd) +unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd) +#else unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic) unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = (True, upgradeWarningToError fd) unDefer (Reason Opt_WarnTypedHoles , fd) = (True, upgradeWarningToError fd) unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd) +#endif unDefer ( _ , fd) = (False, fd) upgradeWarningToError :: FileDiagnostic -> FileDiagnostic @@ -626,10 +712,15 @@ upgradeWarningToError (nfp, sh, fd) = warn2err :: T.Text -> T.Text warn2err = T.intercalate ": error:" . T.splitOn ": warning:" +#if MIN_VERSION_ghc(9,3,0) +hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) +hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd)) +#else hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -hideDiag originalFlags (Reason warning, (nfp, _sh, fd)) +hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd)) +#endif | not (wopt warning originalFlags) - = (Reason warning, (nfp, HideDiag, fd)) + = (w, (nfp, HideDiag, fd)) hideDiag _originalFlags t = t -- | Warnings which lead to a diagnostic tag @@ -650,10 +741,15 @@ unnecessaryDeprecationWarningFlags ] -- | Add a unnecessary/deprecated tag to the required diagnostics. +#if MIN_VERSION_ghc(9,3,0) +tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) +tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd)) +#else tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -tagDiag (Reason warning, (nfp, sh, fd)) +tagDiag (w@(Reason warning), (nfp, sh, fd)) +#endif | Just tag <- requiresTag warning - = (Reason warning, (nfp, sh, fd { _tags = addTag tag (_tags fd) })) + = (w, (nfp, sh, fd { _tags = addTag tag (_tags fd) })) where requiresTag :: WarningFlag -> Maybe DiagnosticTag requiresTag Opt_WarnWarningsDeprecations @@ -695,7 +791,12 @@ generateHieAsts hscEnv tcm = insts = tcg_insts ts :: [ClsInst] tcs = tcg_tcs ts :: [TyCon] run ts $ - Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs +#if MIN_VERSION_ghc(9,3,0) + pure $ Just $ +#else + Just <$> +#endif + GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs #else Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) #endif @@ -703,7 +804,7 @@ generateHieAsts hscEnv tcm = dflags = hsc_dflags hscEnv #if MIN_VERSION_ghc(9,0,0) run ts = -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) fmap (join . snd) . liftIO . initDs hscEnv ts #else id @@ -905,13 +1006,59 @@ loadModulesHome -> HscEnv -> HscEnv loadModulesHome mod_infos e = +#if MIN_VERSION_ghc(9,3,0) + hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars }) +#else let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] in e { hsc_HPT = new_modules - , hsc_type_env_var = Nothing } + , hsc_type_env_var = Nothing + } where mod_name = moduleName . mi_module . hm_iface +#endif -- Merge the HPTs, module graphs and FinderCaches +#if MIN_VERSION_ghc(9,3,0) +mergeEnvs :: HscEnv -> [ModuleGraphNode] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv +mergeEnvs env extraNodes extraMods envs = do + let extraModSummaries = mapMaybe moduleGraphNodeModSum extraNodes + ims = map (\ms -> Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))) extraModSummaries + ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims + curFinderCache = + foldl' + (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) Compat.emptyInstalledModuleEnv + $ zip ims ifrs + -- Very important to force this as otherwise the hsc_mod_graph field is not + -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get + -- this new one, which in turn leads to the EPS referencing the HPT. + module_graph_nodes = + extraNodes ++ nubOrdOn mkNodeKey (concatMap (mgModSummaries' . hsc_mod_graph) envs) + + newFinderCache <- concatFC curFinderCache (map hsc_FC envs) + liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ + let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in + (hscUpdateHUG (const newHug) env){ + hsc_FC = newFinderCache, + hsc_mod_graph = mkModuleGraph module_graph_nodes + }) + + where + mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b + mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) } + mergeUDFM = plusUDFM_C combineModules + + combineModules a b + | HsSrcFile <- mi_hsc_src (hm_iface a) = a + | otherwise = b + concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache + concatFC cur xs = do + fcModules <- mapM (readIORef . fcModuleCache) xs + fcFiles <- mapM (readIORef . fcFileCache) xs + fcModules' <- newIORef (foldl' (plusInstalledModuleEnv const) cur fcModules) + fcFiles' <- newIORef (Map.unions fcFiles) + pure $ FinderCache fcModules' fcFiles' + +#else mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv mergeEnvs env extraModSummaries extraMods envs = do prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs @@ -933,11 +1080,13 @@ mergeEnvs env extraModSummaries extraMods envs = do foldl' (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache $ zip ims ifrs - liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ env{ - hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs, - hsc_FC = newFinderCache, - hsc_mod_graph = mkModuleGraph module_graph_nodes - }) + liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ + env{ + hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs, + hsc_FC = newFinderCache, + hsc_mod_graph = mkModuleGraph module_graph_nodes + }) + where mergeUDFM = plusUDFM_C combineModules combineModules a b @@ -950,6 +1099,7 @@ mergeEnvs env extraModSummaries extraMods envs = do -- To remove this, I plan to upstream the missing Monoid instance concatFC :: [FinderCache] -> FinderCache concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult)) +#endif withBootSuffix :: HscSource -> ModLocation -> ModLocation withBootSuffix HsBootFile = addBootSuffixLocnOut @@ -978,26 +1128,45 @@ getModSummaryFromImports env fp modTime contents = do (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc - . ideclName . unLoc) - ord_idecls + (ordinary_imps, ghc_prim_imports) + = partition ((/= moduleName gHC_PRIM) . unLoc + . ideclName . unLoc) + ord_idecls implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports mod main_loc implicit_prelude imps - convImport (L _ i) = (fmap sl_fs (ideclPkgQual i) - , reLoc $ ideclName i) + convImport (L _ i) = ( +#if !MIN_VERSION_ghc (9,3,0) + fmap sl_fs +#endif + (ideclPkgQual i) + , reLoc $ ideclName i) + + msrImports = implicit_imports ++ imps + +#if MIN_VERSION_ghc (9,3,0) + rn_pkg_qual = renameRawPkgQual (hsc_unit_env env) + rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) + srcImports = rn_imps $ map convImport src_idecls + textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps) + ghc_prim_import = not (null ghc_prim_imports) +#else srcImports = map convImport src_idecls textualImports = map convImport (implicit_imports ++ ordinary_imps) +#endif - msrImports = implicit_imports ++ imps -- Force bits that might keep the string buffer and DynFlags alive unnecessarily liftIO $ evaluate $ rnf srcImports liftIO $ evaluate $ rnf textualImports +#if MIN_VERSION_ghc (9,3,0) + !src_hash <- liftIO $ fingerprintFromStringBuffer contents +#endif + modLoc <- liftIO $ if mod == mAIN_NAME -- specially in tests it's common to have lots of nameless modules -- mkHomeModLocation will map them to the same hi/hie locations @@ -1012,7 +1181,14 @@ getModSummaryFromImports env fp modTime contents = do #if MIN_VERSION_ghc(8,8,0) , ms_hie_date = Nothing #endif +#if MIN_VERSION_ghc(9,3,0) + , ms_dyn_obj_date = Nothing + , ms_ghc_prim_import = ghc_prim_import + , ms_hs_hash = src_hash + +#else , ms_hs_date = modTime +#endif , ms_hsc_src = sourceType -- The contents are used by the GetModSummary rule , ms_hspp_buf = Just contents @@ -1036,7 +1212,14 @@ getModSummaryFromImports env fp modTime contents = do put $ Util.uniq $ moduleNameFS $ moduleName ms_mod forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do put $ Util.uniq $ moduleNameFS $ unLoc m +#if MIN_VERSION_ghc(9,3,0) + case mb_p of + G.NoPkgQual -> pure () + G.ThisPkg uid -> put $ getKey $ getUnique uid + G.OtherPkg uid -> put $ getKey $ getUnique uid +#else whenJust mb_p $ put . Util.uniq +#endif return $! Util.fingerprintFingerprints $ [ Util.fingerprintString fp , fingerPrintImports @@ -1130,7 +1313,12 @@ parseFileContents env customPreprocessor filename ms = do -- - filter out the .hs/.lhs source filename if we have one -- let n_hspp = normalise filename - srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`)) +#if MIN_VERSION_ghc(9,3,0) + TempDir tmp_dir = tmpDir dflags +#else + tmp_dir = tmpDir dflags +#endif + srcs0 = nubOrd $ filter (not . (tmp_dir `isPrefixOf`)) $ filter (/= n_hspp) $ map normalise $ filter (not . isPrefixOf "<") @@ -1272,7 +1460,13 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do -- If mb_old_iface is nothing then checkOldIface will load it for us -- given that the source is unmodified (recomp_iface_reqd, mb_checked_iface) +#if MIN_VERSION_ghc(9,3,0) + <- liftIO $ checkOldIface sessionWithMsDynFlags ms mb_old_iface >>= \case + UpToDateItem x -> pure (UpToDate, Just x) + OutOfDateItem reason x -> pure (NeedsRecompile reason, x) +#else <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface +#endif let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do setTag "Module" $ moduleNameString $ moduleName mod @@ -1309,14 +1503,14 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do readBinCoreFile (mkUpdater $ hsc_NC session) core_file if cf_iface_hash == getModuleHash iface then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (core_file, fingerprintToBS core_hash))) - else do_regenerate (RecompBecause "Core file out of date (doesn't match iface hash)") + else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)") | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing) where handleErrs = flip catches - [Handler $ \(e :: IOException) -> do_regenerate (RecompBecause $ "Reading core file failed (" ++ show e ++ ")") + [Handler $ \(e :: IOException) -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")") ,Handler $ \(e :: GhcException) -> case e of Signal _ -> throw e Panic _ -> throw e - _ -> do_regenerate (RecompBecause $ "Reading core file failed (" ++ show e ++ ")") + _ -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")") ] (_, _reason) -> do_regenerate _reason @@ -1351,18 +1545,36 @@ checkLinkableDependencies get_linkable_hashes graph runtime_deps = do let out_of_date = [core_file | ((core_file, expected_hash), actual_hash) <- zip fs store_hashes, expected_hash /= actual_hash] case out_of_date of [] -> pure Nothing - _ -> pure $ Just $ - RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date) + _ -> pure $ Just $ recompBecause + $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date) + +recompBecause = +#if MIN_VERSION_ghc(9,3,0) + NeedsRecompile . +#endif + RecompBecause +#if MIN_VERSION_ghc(9,3,0) + . CustomReason +#endif + +#if MIN_VERSION_ghc(9,3,0) +data SourceModified = SourceModified | SourceUnmodified deriving (Eq, Ord, Show) +#endif showReason :: RecompileRequired -> String showReason UpToDate = "UpToDate" +#if MIN_VERSION_ghc(9,3,0) +showReason (NeedsRecompile MustCompile) = "MustCompile" +showReason (NeedsRecompile s) = printWithoutUniques s +#else showReason MustCompile = "MustCompile" showReason (RecompBecause s) = s +#endif mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails mkDetailsFromIface session iface = do fixIO $ \details -> do - let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details Nothing) } + let hsc' = hscUpdateHPT (\hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details Nothing)) session initIfaceLoad hsc' (typecheckIface iface) coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts @@ -1371,28 +1583,26 @@ coreFileToCgGuts session iface details core_file = do (HomeModInfo iface details Nothing) this_mod = mi_module iface types_var <- newIORef (md_types details) - let kv = Just (this_mod, types_var) - hsc_env' = session { hsc_HPT = act (hsc_HPT session) - , hsc_type_env_var = kv } + let hsc_env' = hscUpdateHPT act (session { +#if MIN_VERSION_ghc(9,3,0) + hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)]) +#else + hsc_type_env_var = Just (this_mod, types_var) +#endif + }) core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file -- Implicit binds aren't saved, so we need to regenerate them ourselves. let implicit_binds = concatMap getImplicitBinds tyCons tyCons = typeEnvTyCons (md_types details) +#if MIN_VERSION_ghc(9,3,0) + pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] +#else pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (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 - let act hpt = addToHpt hpt (moduleName this_mod) - (HomeModInfo iface details Nothing) - this_mod = mi_module iface - types_var <- newIORef (md_types details) - let kv = Just (this_mod, types_var) - hsc_env' = session { hsc_HPT = act (hsc_HPT session) - , hsc_type_env_var = kv } - core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file - let implicit_binds = concatMap getImplicitBinds tyCons - tyCons = typeEnvTyCons (md_types details) - let cgi_guts = CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing [] + cgi_guts <- coreFileToCgGuts session iface details core_file (warns, lb) <- case linkableType of BCOLinkable -> generateByteCode (CoreFileTime t) session ms cgi_guts ObjectLinkable -> generateObjectCode session ms cgi_guts @@ -1405,27 +1615,55 @@ getDocsBatch :: HscEnv -> Module -- ^ a moudle where the names are in scope -> [Name] +#if MIN_VERSION_ghc(9,3,0) + -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))] +#else -> IO [Either String (Maybe HsDocString, IntMap HsDocString)] +#endif getDocsBatch hsc_env _mod _names = do (msgs, res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> case nameModule_maybe name of Nothing -> return (Left $ NameHasNoModule name) Just mod -> do - ModIface { mi_doc_hdr = mb_doc_hdr + ModIface { +#if MIN_VERSION_ghc(9,3,0) + mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr + , docs_decls = dmap + , docs_args = amap + } +#else + mi_doc_hdr = mb_doc_hdr , mi_decl_docs = DeclDocMap dmap , mi_arg_docs = ArgDocMap amap +#endif } <- loadModuleInterface "getModuleInterface" mod +#if MIN_VERSION_ghc(9,3,0) + if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap +#else if isNothing mb_doc_hdr && Map.null dmap && null amap +#endif then pure (Left (NoDocsInIface mod $ compiled name)) - else pure (Right ( Map.lookup name dmap , + else pure (Right ( +#if MIN_VERSION_ghc(9,3,0) + lookupUniqMap dmap name, +#else + Map.lookup name dmap , +#endif #if !MIN_VERSION_ghc(9,2,0) IntMap.fromAscList $ Map.toAscList $ #endif +#if MIN_VERSION_ghc(9,3,0) + lookupWithDefaultUniqMap amap mempty name)) +#else Map.findWithDefault mempty name amap)) +#endif case res of - Just x -> return $ map (first $ T.unpack . printOutputable) x + Just x -> return $ map (first $ T.unpack . printOutputable) + $ x Nothing -> throwErrors -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) + $ fmap GhcTcRnMessage msgs +#elif MIN_VERSION_ghc(9,2,0) $ Error.getErrorMessages msgs #else $ snd msgs diff --git a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs index c3b5323548d..45f6e8c3da0 100644 --- a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs +++ b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs @@ -56,8 +56,8 @@ parseConfiguration InitializeParams {..} = clientSettings = hashed _initializationOptions parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri -parseWorkspaceFolder = - toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text) +parseWorkspaceFolder WorkspaceFolder{_uri} = + toNormalizedUri (Uri _uri) modifyWorkspaceFolders :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO () diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index 678471c9c15..08a41b0ed43 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} module Development.IDE.Core.Preprocessor ( preprocessor @@ -28,6 +29,10 @@ import Development.IDE.Types.Location import qualified GHC.LanguageExtensions as LangExt import System.FilePath import System.IO.Extra +#if MIN_VERSION_ghc(9,3,0) +import GHC.Utils.Logger (LogFlags(..)) +import GHC.Utils.Outputable (renderWithContext) +#endif -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. @@ -76,10 +81,15 @@ preprocessor env0 filename mbContents = do where logAction :: IORef [CPPLog] -> LogActionCompat logAction cppLogs dflags _reason severity srcSpan _style msg = do +#if MIN_VERSION_ghc(9,3,0) + let log = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg +#else let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg +#endif modifyIORef cppLogs (log :) + data CPPLog = CPPLog Severity SrcSpan Text deriving (Show) @@ -133,7 +143,11 @@ parsePragmasIntoDynFlags -> Util.StringBuffer -> IO (Either [FileDiagnostic] ([String], DynFlags)) parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do +#if MIN_VERSION_ghc(9,3,0) + let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp +#else let opts = getOptions dflags0 contents fp +#endif -- Force bits that might keep the dflags and stringBuffer alive unnecessarily evaluate $ rnf opts diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index dfba6a32e7a..f0b8349a6ea 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -158,6 +158,11 @@ import qualified Development.IDE.Types.Shake as Shake import Development.IDE.GHC.CoreFile import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Control.Monad.IO.Unlift +#if MIN_VERSION_ghc(9,3,0) +import GHC.Unit.Module.Graph +import GHC.Unit.Env +#endif +import Debug.Trace data Log = LogShake Shake.Log @@ -664,7 +669,7 @@ typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck fi -- 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 @@ -685,8 +690,9 @@ getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \G typeCheckRuleDefinition :: HscEnv -> ParsedModule + -> NormalizedFilePath -> Action (IdeResult TcModuleResult) -typeCheckRuleDefinition hsc pm = do +typeCheckRuleDefinition hsc pm file = do setPriority priorityTypeCheck IdeOptions { optDefer = defer } <- getIdeOptions @@ -772,9 +778,21 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps ifaces <- uses_ GetModIface deps - - let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces - session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions + let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces +#if MIN_VERSION_ghc(9,3,0) + mss_imports <- uses_ GetLocatedImports (file : deps) + final_deps <- forM mss_imports $ \imports -> do + let fs = mapMaybe (fmap artifactFilePath . snd) imports + dep_mss <- map msrModSummary <$> if fullModSummary + then uses_ GetModSummary fs + else uses_ GetModSummaryWithoutTimestamps fs + return (map (NodeKey_Module . msKey) dep_mss) + ms <- msrModSummary <$> use_ GetModSummary file + let moduleNodes = zipWith ModuleNode final_deps (ms : mss) +#else + let moduleNodes = mss +#endif + session' <- liftIO $ mergeEnvs hsc moduleNodes inLoadOrder depSessions Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' []) @@ -880,8 +898,12 @@ getModSummaryRule displayTHWarning recorder = do when (uses_th_qq $ msrModSummary res) $ do DisplayTHWarning act <- getIdeGlobalAction liftIO act +#if MIN_VERSION_ghc(9,3,0) + let bufFingerPrint = ms_hs_hash (msrModSummary res) +#else bufFingerPrint <- liftIO $ fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res +#endif let fingerPrint = Util.fingerprintFingerprints [ msrFingerprint res, bufFingerPrint ] return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) @@ -892,7 +914,9 @@ getModSummaryRule displayTHWarning recorder = do case ms of Just res@ModSummaryResult{..} -> do let ms = msrModSummary { +#if !MIN_VERSION_ghc(9,3,0) ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps", +#endif ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" } fp = fingerprintToBS msrFingerprint @@ -973,7 +997,7 @@ regenerateHiFile sess f ms compNeeded = do 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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 211c5468a22..0b31b83ac72 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} -- | A Shake implementation of the compiler service. -- @@ -129,8 +130,11 @@ import Development.IDE.GHC.Compat (NameCache, NameCacheUpdater (..), initNameCache, knownKeyNames, - mkSplitUniqSupply, - upNameCache) +#if !MIN_VERSION_ghc(9,3,0) + upNameCache, +#endif + mkSplitUniqSupply + ) import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake @@ -262,7 +266,11 @@ data ShakeExtras = ShakeExtras -> String -> [DelayedAction ()] -> IO () +#if MIN_VERSION_ghc(9,3,0) + ,ideNc :: NameCache +#else ,ideNc :: IORef NameCache +#endif -- | A mapping of module name to known target (or candidate targets, if missing) ,knownTargetsVar :: TVar (Hashed KnownTargets) -- | A mapping of exported identifiers for local modules. Updated on kick @@ -572,8 +580,12 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer let log :: Logger.Priority -> Log -> IO () log = logWith recorder +#if MIN_VERSION_ghc(9,3,0) + ideNc <- initNameCache 'r' knownKeyNames +#else us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) +#endif shakeExtras <- do globals <- newTVarIO HMap.empty state <- STM.newIO @@ -959,8 +971,14 @@ runIdeAction _herald s i = runReaderT (runIdeActionT i) s askShake :: IdeAction ShakeExtras askShake = ask + +#if MIN_VERSION_ghc(9,3,0) +mkUpdater :: NameCache -> NameCacheUpdater +mkUpdater = id +#else mkUpdater :: IORef NameCache -> NameCacheUpdater mkUpdater ref = NCU (upNameCache ref) +#endif -- | A (maybe) stale result now, and an up to date one later data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a) } diff --git a/ghcide/src/Development/IDE/GHC/CPP.hs b/ghcide/src/Development/IDE/GHC/CPP.hs index 788e93ea8d4..fc18450292a 100644 --- a/ghcide/src/Development/IDE/GHC/CPP.hs +++ b/ghcide/src/Development/IDE/GHC/CPP.hs @@ -34,6 +34,9 @@ import ToolSettings import DynFlags #endif #endif +#if MIN_VERSION_ghc(9,3,0) +import qualified GHC.Driver.Pipeline.Execute as Pipeline +#endif addOptP :: String -> DynFlags -> DynFlags #if MIN_VERSION_ghc (8,10,0) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 43cb5242562..4616c3075e8 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -9,12 +9,19 @@ -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( - NameCacheUpdater(..), + mkHomeModLocation, hPutStringBuffer, addIncludePathsQuote, getModuleHash, setUpTypedHoles, + NameCacheUpdater(..), +#if MIN_VERSION_ghc(9,3,0) + getMessages, + diagnosticMessage, + nameEnvElts, +#else upNameCache, +#endif disableWarningsAsErrors, reLoc, reLocA, @@ -27,8 +34,10 @@ module Development.IDE.GHC.Compat( #endif #if MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,3,0) extendModSummaryNoDeps, emsModSummary, +#endif myCoreToStgExpr, #endif @@ -87,7 +96,11 @@ module Development.IDE.GHC.Compat( icInteractiveModule, HomePackageTable, lookupHpt, +#if MIN_VERSION_ghc(9,3,0) + Dependencies(dep_direct_mods), +#else Dependencies(dep_mods), +#endif bcoFreeNames, ModIfaceAnnotation, pattern Annotation, @@ -116,7 +129,7 @@ module Development.IDE.GHC.Compat( ) where import Data.Bifunctor -import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Core hiding (moduleUnitId) import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Iface import Development.IDE.GHC.Compat.Logger @@ -147,7 +160,11 @@ import GHC.Linker.Types (isObjectLinkable) import GHC.Runtime.Context (icInteractiveModule) import GHC.Unit.Home.ModInfo (HomePackageTable, lookupHpt) -import GHC.Unit.Module.Deps (Dependencies (dep_mods)) +#if MIN_VERSION_ghc(9,3,0) +import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods)) +#else +import GHC.Unit.Module.Deps (Dependencies(dep_mods)) +#endif #else import GHC.CoreToByteCode (coreExprToBCOs) import GHC.Driver.Types (Dependencies (dep_mods), @@ -255,16 +272,37 @@ import GHC.Types.CostCentre import GHC.Types.IPE #endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.Error +import GHC.Driver.Config.Stg.Pipeline +#endif + type ModIfaceAnnotation = Annotation +#if MIN_VERSION_ghc(9,3,0) +nameEnvElts :: NameEnv a -> [a] +nameEnvElts = nonDetNameEnvElts +#endif + #if MIN_VERSION_ghc(9,2,0) myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext +#if MIN_VERSION_ghc(9,3,0) + -> Bool +#endif -> Module -> ModLocation -> CoreExpr -> IO ( Id - , [StgTopBinding] +#if MIN_VERSION_ghc(9,3,0) + ,[CgStgTopBinding] -- output program +#else + ,[StgTopBinding] -- output program +#endif , InfoTableProvMap , CollectedCCs ) -myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do +myCoreToStgExpr logger dflags ictxt +#if MIN_VERSION_ghc(9,3,0) + for_bytecode +#endif + this_mod ml prepd_expr = do {- Create a temporary binding (just because myCoreToStg needs a binding for the stg2stg step) -} let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") @@ -275,24 +313,42 @@ myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do myCoreToStg logger dflags ictxt +#if MIN_VERSION_ghc(9,3,0) + for_bytecode +#endif this_mod ml [NonRec bco_tmp_id prepd_expr] return (bco_tmp_id, stg_binds, prov_map, collected_ccs) myCoreToStg :: Logger -> DynFlags -> InteractiveContext +#if MIN_VERSION_ghc(9,3,0) + -> Bool +#endif -> Module -> ModLocation -> CoreProgram +#if MIN_VERSION_ghc(9,3,0) + -> IO ( [CgStgTopBinding] -- output program +#else -> IO ( [StgTopBinding] -- output program +#endif , InfoTableProvMap , CollectedCCs ) -- CAF cost centre info (declared and used) -myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do +myCoreToStg logger dflags ictxt +#if MIN_VERSION_ghc(9,3,0) + for_bytecode +#endif + this_mod ml prepd_binds = do let (stg_binds, denv, cost_centre_info) = {-# SCC "Core2Stg" #-} coreToStg dflags this_mod ml prepd_binds stg_binds2 <- {-# SCC "Stg2Stg" #-} +#if MIN_VERSION_ghc(9,3,0) + stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds +#else stg2stg logger dflags ictxt this_mod stg_binds +#endif return (stg_binds2, denv, cost_centre_info) #endif @@ -307,7 +363,9 @@ reLocA = id #endif getDependentMods :: ModIface -> [ModuleName] -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,3,0) +getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps +#elif MIN_VERSION_ghc(9,0,0) getDependentMods = map gwib_mod . dep_mods . mi_deps #else getDependentMods = map fst . dep_mods . mi_deps @@ -333,9 +391,15 @@ hPutStringBuffer hdl (StringBuffer buf len cur) #if MIN_VERSION_ghc(9,2,0) type ErrMsg = MsgEnvelope DecoratedSDoc #endif +#if MIN_VERSION_ghc(9,3,0) +type WarnMsg = MsgEnvelope DecoratedSDoc +#endif getMessages' :: PState -> DynFlags -> (Bag WarnMsg, Bag ErrMsg) getMessages' pst dflags = +#if MIN_VERSION_ghc(9,3,0) + bimap (fmap (fmap diagnosticMessage) . getMessages) (fmap (fmap diagnosticMessage) . getMessages) $ getPsMessages pst +#else #if MIN_VERSION_ghc(9,2,0) bimap (fmap pprWarning) (fmap pprError) $ #endif @@ -343,11 +407,16 @@ getMessages' pst dflags = #if !MIN_VERSION_ghc(9,2,0) dflags #endif +#endif #if MIN_VERSION_ghc(9,2,0) pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a pattern PFailedWithErrorMessages msgs +#if MIN_VERSION_ghc(9,3,0) + <- PFailed (const . fmap (fmap diagnosticMessage) . getMessages . getPsErrorMessages -> msgs) +#else <- PFailed (const . fmap pprError . getErrorMessages -> msgs) +#endif #elif MIN_VERSION_ghc(8,10,0) pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a pattern PFailedWithErrorMessages msgs @@ -360,7 +429,7 @@ pattern PFailedWithErrorMessages msgs mkPlainErrMsgIfPFailed (PFailed _ pst err) = Just (\dflags -> mkPlainErrMsg dflags pst err) mkPlainErrMsgIfPFailed _ = Nothing #endif -{-# COMPLETE PFailedWithErrorMessages #-} +{-# COMPLETE POk, PFailedWithErrorMessages #-} supportsHieFiles :: Bool supportsHieFiles = True @@ -368,7 +437,9 @@ supportsHieFiles = True hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports - +#if MIN_VERSION_ghc(9,3,0) +type NameCacheUpdater = NameCache +#else upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c #if MIN_VERSION_ghc(8,8,0) upNameCache = updNameCache @@ -376,6 +447,7 @@ upNameCache = updNameCache upNameCache ref upd_fn = atomicModifyIORef' ref upd_fn #endif +#endif #if !MIN_VERSION_ghc(9,0,1) type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)] @@ -535,13 +607,16 @@ data GhcVersion | GHC810 | GHC90 | GHC92 + | GHC94 deriving (Eq, Ord, Show) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion -#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) +ghcVersion = GHC94 +#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) ghcVersion = GHC92 #elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) ghcVersion = GHC90 diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 222be572e67..173759a5f88 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} -- TODO: remove {-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-} @@ -61,7 +62,9 @@ module Development.IDE.GHC.Compat.Core ( pattern ExposePackage, parseDynamicFlagsCmdLine, parseDynamicFilePragma, +#if !MIN_VERSION_ghc(9,3,0) WarnReason(..), +#endif wWarningFlags, updOptLevel, -- slightly unsafe @@ -84,7 +87,9 @@ module Development.IDE.GHC.Compat.Core ( HscSource(..), WhereFrom(..), loadInterface, +#if !MIN_VERSION_ghc(9,3,0) SourceModified(..), +#endif loadModuleInterface, RecompileRequired(..), #if MIN_VERSION_ghc(8,10,0) @@ -188,12 +193,17 @@ module Development.IDE.GHC.Compat.Core ( hscInteractive, hscSimplify, hscTypecheckRename, - makeSimpleDetails, + Development.IDE.GHC.Compat.Core.makeSimpleDetails, -- * Typecheck utils Development.IDE.GHC.Compat.Core.tcSplitForAllTyVars, Development.IDE.GHC.Compat.Core.tcSplitForAllTyVarBinder_maybe, typecheckIface, - mkIfaceTc, + Development.IDE.GHC.Compat.Core.mkIfaceTc, + Development.IDE.GHC.Compat.Core.mkBootModDetailsTc, + Development.IDE.GHC.Compat.Core.initTidyOpts, + hscUpdateHPT, + driverNoStop, + tidyProgram, ImportedModsVal(..), importedByUser, GHC.TypecheckedSource, @@ -297,7 +307,6 @@ module Development.IDE.GHC.Compat.Core ( Warn(..), -- * ModLocation GHC.ModLocation, - pattern ModLocation, Module.ml_hs_file, Module.ml_obj_file, Module.ml_hi_file, @@ -349,7 +358,6 @@ module Development.IDE.GHC.Compat.Core ( module GHC.HsToCore.Expr, module GHC.HsToCore.Monad, - module GHC.Iface.Tidy, module GHC.Iface.Syntax, #if MIN_VERSION_ghc(9,2,0) @@ -430,7 +438,6 @@ module Development.IDE.GHC.Compat.Core ( module TcRnTypes, module TcRnDriver, module TcRnMonad, - module TidyPgm, module TyCon, module TysPrim, module TysWiredIn, @@ -466,11 +473,46 @@ module Development.IDE.GHC.Compat.Core ( module ExtractDocs, module Parser, module Lexer, +#endif +#if MIN_VERSION_ghc(9,3,0) + CompileReason(..), + hsc_type_env_vars, + hscUpdateHUG, hscUpdateHPT, hsc_HUG, + GhcMessage(..), + getKey, + module GHC.Driver.Env.KnotVars, + module GHC.Iface.Recomp, + module GHC.Linker.Types, + module GHC.Unit.Module.Graph, + module GHC.Types.Unique.Map, + module GHC.Utils.TmpFs, + module GHC.Utils.Panic, + module GHC.Unit.Finder.Types, + module GHC.Unit.Env, + module GHC.Driver.Phases, #endif ) where import qualified GHC +#if MIN_VERSION_ghc(9,3,0) +import GHC.Iface.Recomp (CompileReason(..)) +import GHC.Driver.Env.Types (hsc_type_env_vars) +import GHC.Driver.Env (hscUpdateHUG, hscUpdateHPT, hsc_HUG) +import GHC.Driver.Env.KnotVars +import GHC.Iface.Recomp +import GHC.Linker.Types +import GHC.Unit.Module.Graph +import GHC.Driver.Errors.Types +import GHC.Types.Unique.Map +import GHC.Types.Unique +import GHC.Utils.TmpFs +import GHC.Utils.Panic +import GHC.Unit.Finder.Types +import GHC.Unit.Env +import GHC.Driver.Phases +#endif + #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names hiding (Unique, printName) import GHC.Builtin.Types @@ -484,6 +526,10 @@ import qualified GHC.Core.DataCon as DataCon import GHC.Core.FamInstEnv hiding (pprFamInst) import GHC.Core.InstEnv import GHC.Types.Unique.FM +#if MIN_VERSION_ghc(9,3,0) +import qualified GHC.Driver.Config.Tidy as GHC +import qualified GHC.Data.Strict as Strict +#endif #if MIN_VERSION_ghc(9,2,0) import GHC.Data.Bag import GHC.Core.Multiplicity (scaledThing) @@ -505,13 +551,13 @@ import GHC.Core.Utils #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env #else -import GHC.Driver.Finder +import GHC.Driver.Finder hiding (mkHomeModLocation) import GHC.Driver.Types import GHC.Driver.Ways #endif import GHC.Driver.CmdLine (Warn (..)) import GHC.Driver.Hooks -import GHC.Driver.Main +import GHC.Driver.Main as GHC import GHC.Driver.Monad import GHC.Driver.Phases import GHC.Driver.Pipeline @@ -537,11 +583,11 @@ import GHC.HsToCore.Docs import GHC.HsToCore.Expr import GHC.HsToCore.Monad import GHC.Iface.Load -import GHC.Iface.Make (mkFullIface, mkIfaceTc, - mkPartialIface) +import GHC.Iface.Make (mkFullIface, mkPartialIface) +import GHC.Iface.Make as GHC import GHC.Iface.Recomp import GHC.Iface.Syntax -import GHC.Iface.Tidy +import GHC.Iface.Tidy as GHC import GHC.IfaceToCore import GHC.Parser import GHC.Parser.Header hiding (getImports) @@ -588,7 +634,10 @@ import qualified GHC.Types.Name.Reader as RdrName #if MIN_VERSION_ghc(9,2,0) import GHC.Types.Name.Set import GHC.Types.SourceFile (HscSource (..), - SourceModified (..)) +#if !MIN_VERSION_ghc(9,3,0) + SourceModified(..) +#endif + ) import GHC.Types.SourceText import GHC.Types.Target (Target (..), TargetId (..)) import GHC.Types.TyThing @@ -604,7 +653,7 @@ import GHC.Types.Unique.Supply import GHC.Types.Var (Var (varName), setTyVarUnique, setVarUnique) #if MIN_VERSION_ghc(9,2,0) -import GHC.Unit.Finder +import GHC.Unit.Finder hiding (mkHomeModLocation) import GHC.Unit.Home.ModInfo #endif import GHC.Unit.Info (PackageName (..)) @@ -644,7 +693,7 @@ import ErrUtils hiding (logInfo, mkWarnMsg) import ExtractDocs import FamInst import FamInstEnv -import Finder +import Finder hiding (mkHomeModLocation) #if MIN_VERSION_ghc(8,10,0) import GHC.Hs hiding (HsLet, LetStmt) #endif @@ -652,7 +701,7 @@ import qualified GHCi import GhcMonad import HeaderInfo hiding (getImports) import Hooks -import HscMain +import HscMain as GHC import HscTypes #if !MIN_VERSION_ghc(8,10,0) -- Syntax imports @@ -674,7 +723,7 @@ import InstEnv import Lexer hiding (getSrcLoc) import qualified Linker import LoadIface -import MkIface +import MkIface as GHC import Module hiding (ModLocation (..), UnitId, addBootSuffixLocnOut, moduleUnitId) @@ -716,7 +765,7 @@ import TcRnMonad hiding (Applicative (..), IORef, import TcRnTypes import TcType hiding (mkVisFunTys) import qualified TcType -import TidyPgm +import TidyPgm as GHC import qualified TyCoRep import TyCon import Type hiding (mkVisFunTys) @@ -750,14 +799,48 @@ import System.FilePath #if MIN_VERSION_ghc(9,2,0) import Language.Haskell.Syntax hiding (FunDep) #endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Env as GHCi +#endif + +import Data.Foldable (toList) + +#if MIN_VERSION_ghc(9,3,0) +import qualified GHC.Unit.Finder as GHC +import qualified GHC.Driver.Config.Finder as GHC +#elif MIN_VERSION_ghc(9,2,0) +import qualified GHC.Unit.Finder as GHC +#elif MIN_VERSION_ghc(9,0,0) +import qualified GHC.Driver.Finder as GHC +#else +import qualified Finder as GHC +#endif + + +mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation +#if MIN_VERSION_ghc(9,3,0) +mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f +#else +mkHomeModLocation = GHC.mkHomeModLocation +#endif + #if !MIN_VERSION_ghc(9,0,0) type BufSpan = () type BufPos = () #endif +#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan -#if MIN_VERSION_ghc(9,0,0) +#else +pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan +#endif + +#if MIN_VERSION_ghc(9,3,0) +pattern RealSrcSpan x y <- SrcLoc.RealSrcSpan x ((\case Strict.Nothing -> Nothing; Strict.Just a -> Just a) -> y) where + RealSrcSpan x y = SrcLoc.RealSrcSpan x (case y of Nothing -> Strict.Nothing; Just a -> Strict.Just a) + +#elif MIN_VERSION_ghc(9,0,0) pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y #else pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where @@ -765,7 +848,11 @@ pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where #endif {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} +#if MIN_VERSION_ghc(9,3,0) +pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Strict.Maybe BufPos-> SrcLoc.SrcLoc +#else pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc +#endif #if MIN_VERSION_ghc(9,0,0) pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y #else @@ -936,14 +1023,6 @@ tcSplitForAllTyVarBinder_maybe = tcSplitForAllTy_maybe #endif -pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation -#if MIN_VERSION_ghc(8,8,0) -pattern ModLocation a b c <- - GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" -#else -pattern ModLocation a b c <- - GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c -#endif #if !MIN_VERSION_ghc(8,10,0) noExtField :: GHC.NoExt @@ -1015,6 +1094,7 @@ unload hsc_env linkables = #endif hsc_env linkables +#if !MIN_VERSION_ghc(9,3,0) setOutputFile :: FilePath -> DynFlags -> DynFlags setOutputFile f d = d { #if MIN_VERSION_ghc(9,2,0) @@ -1023,6 +1103,7 @@ setOutputFile f d = d { outputFile = Just f #endif } +#endif isSubspanOfA :: LocatedAn la a -> LocatedAn lb b -> Bool #if MIN_VERSION_ghc(9,2,0) @@ -1072,7 +1153,7 @@ pattern GRE :: Name -> Parent -> Bool -> [ImportSpec] -> RdrName.GlobalRdrElt #if MIN_VERSION_ghc(9,2,0) pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} <- RdrName.GRE {gre_name = (greNamePrintableName -> gre_name) - ,gre_par, gre_lcl, gre_imp} + ,gre_par, gre_lcl, gre_imp = (toList -> gre_imp)} #else pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} = RdrName.GRE{..} #endif @@ -1091,3 +1172,55 @@ pattern LetStmt xlet localBinds <- GHC.LetStmt xlet (SrcLoc.unLoc -> localBinds) rationalFromFractionalLit :: FractionalLit -> Rational rationalFromFractionalLit = fl_value #endif + +makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails +makeSimpleDetails hsc_env = + GHC.makeSimpleDetails +#if MIN_VERSION_ghc(9,3,0) + (hsc_logger hsc_env) +#else + hsc_env +#endif + +mkIfaceTc hsc_env sf details ms tcGblEnv = +#if MIN_VERSION_ghc(8,10,0) + GHC.mkIfaceTc hsc_env sf details +#if MIN_VERSION_ghc(9,3,0) + ms +#endif + tcGblEnv +#else + fst <$> GHC.mkIfaceTc hsc_env Nothing sf details tcGblEnv +#endif + +mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails +mkBootModDetailsTc session = GHC.mkBootModDetailsTc +#if MIN_VERSION_ghc(9,3,0) + (hsc_logger session) +#else + session +#endif + +#if !MIN_VERSION_ghc(9,3,0) +type TidyOpts = HscEnv +#endif + +initTidyOpts :: HscEnv -> IO TidyOpts +initTidyOpts = +#if MIN_VERSION_ghc(9,3,0) + GHC.initTidyOpts +#else + pure +#endif + +driverNoStop = +#if MIN_VERSION_ghc(9,3,0) + NoStop +#else + StopLn +#endif + +#if !MIN_VERSION_ghc(9,3,0) +hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv +hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) } +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Env.hs b/ghcide/src/Development/IDE/GHC/Compat/Env.hs index 76625878985..0909e783660 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Env.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Env.hs @@ -3,7 +3,14 @@ -- | Compat module for the main Driver types, such as 'HscEnv', -- 'UnitEnv' and some DynFlags compat functions. module Development.IDE.GHC.Compat.Env ( - Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph, hsc_HPT, hsc_type_env_var), + Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph +#if MIN_VERSION_ghc(9,3,0) + , hsc_type_env_vars +#else + , hsc_type_env_var +#endif + ), + Env.hsc_HPT, InteractiveContext(..), setInteractivePrintName, setInteractiveDynFlags, @@ -51,7 +58,11 @@ import GHC (setInteractiveDynFlags) #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Backend as Backend +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Env (HscEnv) +#else import GHC.Driver.Env (HscEnv, hsc_EPS) +#endif import qualified GHC.Driver.Env as Env import qualified GHC.Driver.Session as Session import GHC.Platform.Ways hiding (hostFullWays) @@ -80,6 +91,11 @@ import HscTypes as Env import Module #endif +#if MIN_VERSION_ghc(9,3,0) +hsc_EPS :: HscEnv -> UnitEnv +hsc_EPS = hsc_unit_env +#endif + #if MIN_VERSION_ghc(9,0,0) #if !MIN_VERSION_ghc(9,2,0) import qualified Data.Set as Set diff --git a/ghcide/src/Development/IDE/GHC/Compat/Iface.hs b/ghcide/src/Development/IDE/GHC/Compat/Iface.hs index 36ac26a446e..e0b36a13a99 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Iface.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Iface.hs @@ -7,6 +7,9 @@ module Development.IDE.GHC.Compat.Iface ( ) where import GHC +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Session (targetProfile) +#endif #if MIN_VERSION_ghc(9,2,0) import qualified GHC.Iface.Load as Iface import GHC.Unit.Finder.Types (FindResult) @@ -24,7 +27,9 @@ import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Outputable writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) +writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface +#elif MIN_VERSION_ghc(9,2,0) writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface #elif MIN_VERSION_ghc(9,0,0) writeIfaceFile env = Iface.writeIface (hsc_dflags env) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Logger.hs b/ghcide/src/Development/IDE/GHC/Compat/Logger.hs index cb94532eb71..6e8c6dca522 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Logger.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Logger.hs @@ -24,6 +24,9 @@ import GHC.Utils.Logger as Logger import DynFlags import Outputable (queryQual) #endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.Error +#endif putLogHook :: Logger -> HscEnv -> HscEnv putLogHook logger env = @@ -41,6 +44,15 @@ pushLogHook f logger = logger { Env.log_action = f (Env.log_action logger) } #endif +#if MIN_VERSION_ghc(9,3,0) +type LogActionCompat = LogFlags -> Maybe DiagnosticReason -> Maybe Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () + +-- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. +logActionCompat :: LogActionCompat -> LogAction +logActionCompat logAction logFlags (MCDiagnostic severity wr) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify +logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify + +#else #if MIN_VERSION_ghc(9,0,0) type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () @@ -54,3 +66,4 @@ type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnq logActionCompat :: LogActionCompat -> LogAction logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (queryQual style) #endif +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index 88bd76934e1..084a48a04b5 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -17,8 +17,12 @@ module Development.IDE.GHC.Compat.Outputable ( -- * Parser errors PsWarning, PsError, +#if MIN_VERSION_ghc(9,3,0) + DiagnosticReason(..), +#else pprWarning, pprError, +#endif -- * Error infrastructure DecoratedSDoc, MsgEnvelope, @@ -35,7 +39,11 @@ module Development.IDE.GHC.Compat.Outputable ( import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session +#if !MIN_VERSION_ghc(9,3,0) import GHC.Parser.Errors +#else +import GHC.Parser.Errors.Types +#endif import qualified GHC.Parser.Errors.Ppr as Ppr import qualified GHC.Types.Error as Error import GHC.Types.Name.Ppr @@ -69,6 +77,11 @@ import Outputable as Out hiding import qualified Outputable as Out import SrcLoc #endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Utils.Logger +import GHC.Driver.Config.Diagnostic +import Data.Maybe +#endif -- | A compatible function to print `Outputable` instances -- without unique symbols. @@ -125,6 +138,7 @@ oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc oldFormatErrDoc = Err.formatErrDoc #endif +#if !MIN_VERSION_ghc(9,3,0) pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc pprWarning = #if MIN_VERSION_ghc(9,2,0) @@ -140,18 +154,27 @@ pprError = #else id #endif +#endif formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e = #if MIN_VERSION_ghc(9,2,0) showSDoc dflags (pprNoLocMsgEnvelope e) +#if MIN_VERSION_ghc(9,3,0) +pprNoLocMsgEnvelope :: MsgEnvelope DecoratedSDoc -> SDoc +#else pprNoLocMsgEnvelope :: Error.RenderableDiagnostic e => MsgEnvelope e -> SDoc +#endif pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e , errMsgContext = unqual }) = sdocWithContext $ \ctx -> withErrStyle unqual $ +#if MIN_VERSION_ghc(9,3,0) + (formatBulleted ctx $ e) +#else (formatBulleted ctx $ Error.renderDiagnostic e) +#endif #else Out.showSDoc dflags @@ -178,13 +201,18 @@ mkPrintUnqualifiedDefault env = HscTypes.mkPrintUnqualified (hsc_dflags env) #endif -mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc -mkWarnMsg = +#if MIN_VERSION_ghc(9,3,0) +mkWarnMsg :: DynFlags -> Maybe DiagnosticReason -> b -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc +mkWarnMsg df reason _logFlags l st doc = fmap diagnosticMessage $ mkMsgEnvelope (initDiagOpts df) l st (mkPlainDiagnostic (fromMaybe WarningWithoutFlag reason) [] doc) +#else +mkWarnMsg :: a -> b -> DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc +mkWarnMsg _ _ = #if MIN_VERSION_ghc(9,2,0) const Error.mkWarnMsg #else Err.mkWarnMsg #endif +#endif defaultUserStyle :: PprStyle #if MIN_VERSION_ghc(9,0,0) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Parser.hs b/ghcide/src/Development/IDE/GHC/Compat/Parser.hs index 91a925cb0bc..391ca9fb825 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Parser.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Parser.hs @@ -62,7 +62,11 @@ import GHC (Anchor (anchor), pm_mod_summary, pm_parsed_source) import qualified GHC +#if MIN_VERSION_ghc(9,3,0) +import qualified GHC.Driver.Config.Parser as Config +#else import qualified GHC.Driver.Config as Config +#endif import GHC.Hs (LEpaComment, hpm_module, hpm_src_files) import GHC.Parser.Lexer hiding (initParserState) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs b/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs index 6fd5834f633..12cf035483a 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs @@ -24,6 +24,11 @@ import qualified GHC.Driver.Env as Env import GHC.Driver.Plugins (Plugin (..), PluginWithArgs (..), StaticPlugin (..), +#if MIN_VERSION_ghc(9,3,0) + staticPlugins, + ParsedResult(..), + PsMessages(..), +#endif defaultPlugin, withPlugins) import qualified GHC.Runtime.Loader as Loader #elif MIN_VERSION_ghc(8,8,0) @@ -42,15 +47,25 @@ applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.Api applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do -- Apply parsedResultAction of plugins let applyPluginAction p opts = parsedResultAction p opts ms +#if MIN_VERSION_ghc(9,3,0) + fmap (hpm_module . parsedResultModule) $ +#else fmap hpm_module $ +#endif runHsc env $ withPlugins -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) + (Env.hsc_plugins env) +#elif MIN_VERSION_ghc(9,2,0) env #else dflags #endif applyPluginAction +#if MIN_VERSION_ghc(9,3,0) + (ParsedResult (HsParsedModule parsed [] hpm_annotations) (PsMessages mempty mempty)) +#else (HsParsedModule parsed [] hpm_annotations) +#endif initializePlugins :: HscEnv -> IO HscEnv initializePlugins env = do @@ -64,7 +79,9 @@ initializePlugins env = do #if MIN_VERSION_ghc(8,8,0) hsc_static_plugins :: HscEnv -> [StaticPlugin] -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) +hsc_static_plugins = staticPlugins . Env.hsc_plugins +#elif MIN_VERSION_ghc(9,2,0) hsc_static_plugins = Env.hsc_static_plugins #else hsc_static_plugins = staticPlugins . hsc_dflags diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index 9077745aef5..c4a56bec5f5 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Units.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs @@ -5,7 +5,10 @@ module Development.IDE.GHC.Compat.Units ( -- * UnitState UnitState, +#if MIN_VERSION_ghc(9,3,0) initUnits, +#endif + oldInitUnits, unitState, getUnitName, explicitUnits, @@ -39,7 +42,7 @@ module Development.IDE.GHC.Compat.Units ( installedModule, -- * Module toUnitId, - moduleUnitId, + Development.IDE.GHC.Compat.Units.moduleUnitId, moduleUnit, -- * ExternalPackageState ExternalPackageState(..), @@ -49,10 +52,18 @@ module Development.IDE.GHC.Compat.Units ( showSDocForUser', ) where +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Control.Monad +#if MIN_VERSION_ghc(9,3,0) +import GHC.Unit.Home.ModInfo +#endif #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) import qualified GHC.Data.ShortText as ST +#if !MIN_VERSION_ghc(9,3,0) import GHC.Driver.Env (hsc_unit_dbs) +#endif import GHC.Driver.Ppr import GHC.Unit.Env import GHC.Unit.External @@ -128,37 +139,69 @@ unitState = DynFlags.unitState . hsc_dflags unitState = DynFlags.pkgState . hsc_dflags #endif -initUnits :: HscEnv -> IO HscEnv -initUnits env = do -#if MIN_VERSION_ghc(9,2,0) - let dflags1 = hsc_dflags env - -- Copied from GHC.setSessionDynFlags - let cached_unit_dbs = hsc_unit_dbs env - (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags1 cached_unit_dbs - - dflags <- DynFlags.updatePlatformConstants dflags1 mconstants - - +#if MIN_VERSION_ghc(9,3,0) +createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> HomeUnitGraph +createUnitEnvFromFlags unitDflags = + let + newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing + unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags + in + unitEnv_new (Map.fromList (NE.toList (unitEnvList))) + +initUnits :: [DynFlags] -> HscEnv -> IO HscEnv +initUnits unitDflags env = do + let dflags0 = hsc_dflags env + -- additionally, set checked dflags so we don't lose fixes + let initial_home_graph = createUnitEnvFromFlags (dflags0 NE.:| unitDflags) + home_units = unitEnv_keys initial_home_graph + home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + dflags = homeUnitEnv_dflags homeUnitEnv + old_hpt = homeUnitEnv_hpt homeUnitEnv + + (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags cached_unit_dbs home_units + + updated_dflags <- DynFlags.updatePlatformConstants dflags mconstants + pure HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = old_hpt + , homeUnitEnv_home_unit = Just home_unit + } + + let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (homeUnitId_ dflags0) home_unit_graph let unit_env = UnitEnv - { ue_platform = targetPlatform dflags - , ue_namever = DynFlags.ghcNameVersion dflags - , ue_home_unit = home_unit - , ue_units = unit_state + { ue_platform = targetPlatform dflags1 + , ue_namever = GHC.ghcNameVersion dflags1 + , ue_home_unit_graph = home_unit_graph + , ue_current_unit = homeUnitId_ dflags0 + , ue_eps = ue_eps (hsc_unit_env env) } - pure $ hscSetFlags dflags $ hscSetUnitEnv unit_env env - { hsc_unit_dbs = Just dbs - } + pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env +#endif + +-- | oldInitUnits only needs to modify DynFlags for GHC <9.2 +-- For GHC >= 9.2, we need to set the hsc_unit_env also, that is +-- done later by initUnits +oldInitUnits :: DynFlags -> IO DynFlags +#if MIN_VERSION_ghc(9,2,0) +oldInitUnits = pure #elif MIN_VERSION_ghc(9,0,0) - newFlags <- State.initUnits $ hsc_dflags env - pure $ hscSetFlags newFlags env +oldInitUnits dflags = do + newFlags <- State.initUnits dflags + pure newFlags #else - newFlags <- fmap fst . Packages.initPackages $ hsc_dflags env - pure $ hscSetFlags newFlags env +oldInitUnits dflags = do + newFlags <- fmap fst $ Packages.initPackages dflags + pure newFlags #endif explicitUnits :: UnitState -> [Unit] explicitUnits ue = -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,3,0) + map fst $ State.explicitUnits ue +#elif MIN_VERSION_ghc(9,0,0) State.explicitUnits ue #else Packages.explicitPackages ue @@ -180,7 +223,15 @@ getUnitName env i = packageName <$> Packages.lookupPackage (hsc_dflags env) (definiteUnitId (defUnitId i)) #endif -lookupModuleWithSuggestions :: HscEnv -> ModuleName -> Maybe FastString -> LookupResult +lookupModuleWithSuggestions + :: HscEnv + -> ModuleName +#if MIN_VERSION_ghc(9,3,0) + -> GHC.PkgQual +#else + -> Maybe FastString +#endif + -> LookupResult lookupModuleWithSuggestions env modname mpkg = #if MIN_VERSION_ghc(9,0,0) State.lookupModuleWithSuggestions (unitState env) modname mpkg diff --git a/ghcide/src/Development/IDE/GHC/Compat/Util.hs b/ghcide/src/Development/IDE/GHC/Compat/Util.hs index 17799ea31d1..7c521e88e8d 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Util.hs @@ -24,7 +24,9 @@ module Development.IDE.GHC.Compat.Util ( LBooleanFormula, BooleanFormula(..), -- * OverridingBool +#if !MIN_VERSION_ghc(9,3,0) OverridingBool(..), +#endif -- * Maybes MaybeErr(..), orElse, diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index 74a72148c8c..89c527e404b 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.GHC.Error @@ -121,13 +122,17 @@ p `isInsideSrcSpan` r = case srcSpanToRange r of -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing). toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity +#if !MIN_VERSION_ghc(9,3,0) toDSeverity SevOutput = Nothing toDSeverity SevInteractive = Nothing toDSeverity SevDump = Nothing toDSeverity SevInfo = Just DsInfo +toDSeverity SevFatal = Just DsError +#else +toDSeverity SevIgnore = Nothing +#endif toDSeverity SevWarning = Just DsWarning toDSeverity SevError = Just DsError -toDSeverity SevFatal = Just DsError -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given @@ -167,7 +172,11 @@ catchSrcErrors dflags fromWhere ghcM = do Right <$> ghcM where ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags - sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages + sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags +#if MIN_VERSION_ghc(9,3,0) + . fmap (fmap Compat.diagnosticMessage) . Compat.getMessages +#endif + . srcErrorMessages diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic] diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 3d506fbe4ae..4e7ff4463e1 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -43,6 +43,9 @@ import GHC.ByteCode.Types #else import ByteCodeTypes #endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.PkgQual +#endif -- Orphan instances for types from the GHC API. instance Show CoreModule where show = unpack . printOutputable @@ -85,7 +88,9 @@ instance NFData SB.StringBuffer where rnf = rwhnf instance Show Module where show = moduleNameString . moduleName +#if !MIN_VERSION_ghc(9,3,0) instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable +#endif instance (NFData l, NFData e) => NFData (GenLocated l e) where rnf (L l e) = rnf l `seq` rnf e @@ -126,10 +131,12 @@ instance Show HieFile where instance NFData HieFile where rnf = rwhnf +#if !MIN_VERSION_ghc(9,3,0) deriving instance Eq SourceModified deriving instance Show SourceModified instance NFData SourceModified where rnf = rwhnf +#endif #if !MIN_VERSION_ghc(9,2,0) instance Show ModuleName where @@ -207,3 +214,13 @@ instance Show HomeModInfo where show = show . mi_module . hm_iface instance NFData HomeModInfo where rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link + +#if MIN_VERSION_ghc(9,3,0) +instance NFData PkgQual where + rnf NoPkgQual = () + rnf (ThisPkg uid) = rnf uid + rnf (OtherPkg uid) = rnf uid + +instance NFData UnitId where + rnf = rwhnf +#endif diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index 4776626aa68..8dd99b8bde8 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -32,7 +32,7 @@ module Development.IDE.GHC.Util( #if MIN_VERSION_ghc(9,2,0) import GHC.Data.FastString import GHC.Data.StringBuffer -import GHC.Driver.Env +import GHC.Driver.Env hiding (hscSetFlags) import GHC.Driver.Monad import GHC.Driver.Session hiding (ExposePackage) import GHC.Parser.Lexer diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 720828fef3c..fa30373ce83 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE CPP #-} module Development.IDE.GHC.Warnings(withWarnings) where @@ -23,14 +24,18 @@ import Language.LSP.Types (type (|?) (..)) -- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 -- which basically says that log_action is taken from the ModSummary when GHC feels like it. -- The given argument lets you refresh a ModSummary log_action +#if MIN_VERSION_ghc(9,3,0) +withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a) +#else withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) +#endif withWarnings diagSource action = do warnings <- newVar [] - let newAction :: LogActionCompat - newAction dynFlags wr _ loc prUnqual msg = do - let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc prUnqual msg + let newAction :: DynFlags -> LogActionCompat + newAction dynFlags logFlags wr _ loc prUnqual msg = do + let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags wr logFlags loc prUnqual msg modifyVar_ warnings $ return . (wr_d:) - newLogger env = pushLogHook (const (logActionCompat newAction)) (hsc_logger env) + newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env) res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res) @@ -38,6 +43,15 @@ withWarnings diagSource action = do third3 :: (c -> d) -> (a, b, c) -> (a, b, d) third3 f (a, b, c) = (a, b, f c) +#if MIN_VERSION_ghc(9,3,0) +attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic +attachReason Nothing d = d +attachReason (Just wr) d = d{_code = InR <$> showReason wr} + where + showReason = \case + WarningWithFlag flag -> showFlag flag + _ -> Nothing +#else attachReason :: WarnReason -> Diagnostic -> Diagnostic attachReason wr d = d{_code = InR <$> showReason wr} where @@ -45,6 +59,7 @@ attachReason wr d = d{_code = InR <$> showReason wr} NoReason -> Nothing Reason flag -> showFlag flag ErrReason flag -> showFlag =<< flag +#endif showFlag :: WarningFlag -> Maybe T.Text showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index 101e21fe32d..2cc08b9f57d 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -27,6 +27,9 @@ import Control.Monad.IO.Class import Data.List (isSuffixOf) import Data.Maybe import System.FilePath +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.PkgQual +#endif data Import = FileImport !ArtifactsLocation @@ -37,11 +40,11 @@ data ArtifactsLocation = ArtifactsLocation { artifactFilePath :: !NormalizedFilePath , artifactModLocation :: !(Maybe ModLocation) , artifactIsSource :: !Bool -- ^ True if a module is a source input - } - deriving (Show) + , artifactModule :: !(Maybe Module) + } deriving Show instance NFData ArtifactsLocation where - rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource + rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource `seq` rnf artifactModule isBootLocation :: ArtifactsLocation -> Bool isBootLocation = not . artifactIsSource @@ -51,28 +54,30 @@ instance NFData Import where rnf PackageImport = () modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation -modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source +modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mod where isSource HsSrcFile = True isSource _ = False source = case ms of Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp Just ms -> isSource (ms_hsc_src ms) + mod = ms_mod <$> ms -- | locate a module in the file system. Where we go from *daml to Haskell locateModuleFile :: MonadIO m - => [[FilePath]] + => [(UnitId, [FilePath])] -> [String] -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -> Bool -> ModuleName - -> m (Maybe NormalizedFilePath) + -> m (Maybe (UnitId, NormalizedFilePath)) locateModuleFile import_dirss exts targetFor isSource modName = do let candidates import_dirs = [ toNormalizedFilePath' (prefix moduleNameSlashes modName <.> maybeBoot ext) | prefix <- import_dirs , ext <- exts] - firstJustM (targetFor modName) (concatMap candidates import_dirss) + firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs) <- import_dirss]) where + go (uid, candidate) = fmap ((uid,) <$>) $ targetFor modName candidate maybeBoot ext | isSource = ext ++ "-boot" | otherwise = ext @@ -81,8 +86,13 @@ locateModuleFile import_dirss exts targetFor isSource modName = do -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package. -mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, [FilePath]) -mkImportDirs env (i, flags) = (, importPaths flags) <$> getUnitName env i +#if MIN_VERSION_ghc(9,3,0) +mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, [FilePath]) +mkImportDirs env (i, flags) = Just (i, importPaths flags) +#else +mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath])) +mkImportDirs env (i, flags) = (, (i, importPaths flags)) <$> getUnitName env i +#endif -- | locate a module in either the file system or the package database. Where we go from *daml to -- Haskell @@ -93,43 +103,72 @@ locateModule -> [String] -- ^ File extensions -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name +#if MIN_VERSION_ghc(9,3,0) + -> PkgQual -- ^ Package name +#else -> Maybe FastString -- ^ Package name +#endif -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import) locateModule env comp_info exts targetFor modName mbPkgName isSource = do case mbPkgName of -- "this" means that we should only look in the current package +#if MIN_VERSION_ghc(9,3,0) + ThisPkg _ -> do +#else Just "this" -> do - lookupLocal [importPaths dflags] +#endif + lookupLocal (homeUnitId_ dflags) (importPaths dflags) -- if a package name is given we only go look for a package +#if MIN_VERSION_ghc(9,3,0) + OtherPkg uid + | Just dirs <- lookup uid import_paths +#else Just pkgName - | Just dirs <- lookup (PackageName pkgName) import_paths - -> lookupLocal [dirs] + | Just (uid, dirs) <- lookup (PackageName pkgName) import_paths +#endif + -> lookupLocal uid dirs | otherwise -> lookupInPackageDB env +#if MIN_VERSION_ghc(9,3,0) + NoPkgQual -> do +#else Nothing -> do +#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. - mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName + let import_paths' = +#if MIN_VERSION_ghc(9,3,0) + import_paths +#else + map snd import_paths +#endif + + mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : import_paths') exts targetFor isSource $ unLoc modName case mbFile of Nothing -> lookupInPackageDB env - Just file -> toModLocation file + Just (uid, file) -> toModLocation uid file where dflags = hsc_dflags env import_paths = mapMaybe (mkImportDirs env) comp_info - toModLocation file = liftIO $ do + toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) - return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) - - lookupLocal dirs = do - mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName +#if MIN_VERSION_ghc(9,0,0) + let mod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes +#else + let mod = mkModule uid (unLoc modName) +#endif + return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just mod) + + lookupLocal uid dirs = do + mbFile <- locateModuleFile [(uid, dirs)] exts targetFor isSource $ unLoc modName case mbFile of Nothing -> return $ Left $ notFoundErr env modName $ LookupNotFound [] - Just file -> toModLocation file + Just (uid, file) -> toModLocation uid file - lookupInPackageDB env = + lookupInPackageDB env = do case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport reason -> return $ Left $ notFoundErr env modName reason diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 0a45688fefc..87156c1ab82 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -122,8 +122,16 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLNam } where cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol +#if MIN_VERSION_ghc(9,3,0) + cvtFld (L (locA -> RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol) +#else cvtFld (L (RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol) +#endif +#if MIN_VERSION_ghc(9,3,0) + { _name = printOutputable (unLoc (foLabel n)) +#else { _name = printOutputable (unLoc (rdrNameFieldOcc n)) +#endif , _kind = SkField } cvtFld _ = Nothing @@ -217,7 +225,7 @@ documentSymbolForImportSummary importSymbols = let -- safe because if we have no ranges then we don't take this branch mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs) - importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols + importRange = mergeRanges $ map (\DocumentSymbol{_range} -> _range) importSymbols in Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange)) { _name = "imports" @@ -293,7 +301,11 @@ hsConDeclsBinders cons get_flds_gadt :: HsConDeclGADTDetails GhcPs -> ([LFieldOcc GhcPs]) +#if MIN_VERSION_ghc(9,3,0) + get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) +#else get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds) +#endif get_flds_gadt _ = [] get_flds :: Located [LConDeclField GhcPs] diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index c703ec7a667..415743d0823 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -526,7 +526,11 @@ findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result -- -- is encoded as @[[arg1, arg2], [arg3], [arg4]]@ -- Hence, we must concat nested arguments into one to get all the fields. +#if MIN_VERSION_ghc(9,3,0) + = map (foLabel . unLoc) cd_fld_names +#else = map (rdrNameFieldOcc . unLoc) cd_fld_names +#endif -- XConDeclField extract _ = [] findRecordCompl _ _ _ _ = [] diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index dd241e7fc9d..701074b3ac5 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -50,7 +50,11 @@ safeTyThingId _ = Nothing -- Possible documentation for an element in the code data SpanDoc +#if MIN_VERSION_ghc(9,3,0) + = SpanDocString [HsDocString] SpanDocUris +#else = SpanDocString HsDocString SpanDocUris +#endif | SpanDocText [T.Text] SpanDocUris deriving stock (Eq, Show, Generic) deriving anyclass NFData @@ -86,7 +90,12 @@ emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing) spanDocToMarkdown :: SpanDoc -> [T.Text] spanDocToMarkdown = \case (SpanDocString docs uris) -> - let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs + let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ +#if MIN_VERSION_ghc(9,3,0) + renderHsDocStrings docs +#else + unpackHDS docs +#endif in go [doc] uris (SpanDocText txt uris) -> go txt uris where diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index c5a91906524..08ad918bc40 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -33,6 +33,9 @@ import System.Directory import System.FilePath import Language.LSP.Types (filePathToUri, getUri) +#if MIN_VERSION_ghc(9,3,0) +import GHC.Types.Unique.Map +#endif mkDocMap :: HscEnv @@ -41,12 +44,18 @@ mkDocMap -> IO DocAndKindMap mkDocMap env rm this_mod = do -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,3,0) + (Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod +#elif MIN_VERSION_ghc(9,2,0) (_ , DeclDocMap this_docs, _) <- extractDocs this_mod #else let (_ , DeclDocMap this_docs, _) = extractDocs this_mod #endif +#if MIN_VERSION_ghc(9,3,0) + d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names +#else d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names +#endif k <- foldrM getType (tcg_type_env this_mod) names pure $ DKMap d k where @@ -69,7 +78,7 @@ lookupKind env mod = fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc -getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] +getDocumentationTryGhc env mod n = fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env mod [n] getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] getDocumentationsTryGhc env mod names = do @@ -78,7 +87,11 @@ getDocumentationsTryGhc env mod names = do Left _ -> return [] Right res -> zipWithM unwrap res names where +#if MIN_VERSION_ghc(9,3,0) + unwrap (Right (Just docs, _)) n = SpanDocString (map hsDocString docs) <$> getUris n +#else unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n +#endif unwrap _ n = mkSpanDocText n mkSpanDocText name = diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 12fce8ce67f..5d891365501 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -259,11 +259,11 @@ initializeResponseTests = withResource acquire release tests where _documentOnTypeFormattingProvider Nothing , chk "NO renaming" _renameProvider (Just $ InL False) , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" _colorProvider (Just $ InL False) + , chk "NO color" (^. L.colorProvider) (Just $ InL False) , chk "NO folding range" _foldingRangeProvider (Just $ InL False) , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] - , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) - , chk "NO experimental" _experimental Nothing + , chk " workspace" (^. L.workspace) (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) + , chk "NO experimental" (^. L.experimental) Nothing ] where tds = Just (InL (TextDocumentSyncOptions @@ -564,6 +564,7 @@ diagnosticTests = testGroup "diagnostics" , "useBase = BaseList.map" , "wrong1 = ThisList.map" , "wrong2 = BaseList.x" + , "main = pure ()" ] _ <- createDoc "Data/List.hs" "haskell" thisDataListContent _ <- createDoc "Main.hs" "haskell" mainContent @@ -621,7 +622,7 @@ diagnosticTests = testGroup "diagnostics" -- Check that if we put a lower-case drive in for A.A -- the diagnostics for A.B will also be lower-case. liftIO $ fileUri @?= uriB - let msg = _message (head (toList diags) :: Diagnostic) + let msg = head (toList diags) ^. L.message liftIO $ unless ("redundant" `T.isInfixOf` msg) $ assertFailure ("Expected redundant import but got " <> T.unpack msg) closeDoc a @@ -1778,10 +1779,10 @@ packageCompletionTests = , _label == "fromList" ] liftIO $ take 3 (sort compls') @?= - map ("Defined in "<>) + map ("Defined in "<>) ( [ "'Data.List.NonEmpty" , "'GHC.Exts" - ] + ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else []) , testSessionWait "Map" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines diff --git a/hie-compat/hie-compat.cabal b/hie-compat/hie-compat.cabal index 8166d2fcd24..7e3aee55a67 100644 --- a/hie-compat/hie-compat.cabal +++ b/hie-compat/hie-compat.cabal @@ -52,3 +52,5 @@ library hs-source-dirs: src-ghc90 src-reexport-ghc9 if (impl(ghc >= 9.2) && impl(ghc < 9.3)) hs-source-dirs: src-ghc92 src-reexport-ghc9 + if (impl(ghc >= 9.4) && impl(ghc < 9.5)) + hs-source-dirs: src-reexport-ghc92 diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs index a80f2519986..28e34ba3797 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs @@ -2,6 +2,9 @@ -- multiple ghc-exactprint versions, accepting that anything more ambitious is -- pretty much impossible with the GHC 9.2 redesign of ghc-exactprint module Development.IDE.GHC.Compat.ExactPrint +#if MIN_VERSION_ghc(9,3,0) + ( ) where +#else ( ExactPrint , exactPrint , makeDeltaAst @@ -31,3 +34,5 @@ pattern Annotated {astA, annsA} <- (Retrie.astA &&& Retrie.annsA -> (astA, annsA pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA)) #endif + +#endif diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs index abaaa81cfb1..68193c12a48 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -36,7 +36,11 @@ showAstDataHtml a0 = html $ li (showAstDataHtml' a0), li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0) #else - li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan a0) + li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan +#if MIN_VERSION_ghc(9,3,0) + NoBlankEpAnnotations +#endif + a0) #endif ]) where @@ -49,7 +53,7 @@ showAstDataHtml a0 = html $ li = tag "li" caret x = tag' [("class", text "caret")] "span" "" <+> x nested foo cts -#if MIN_VERSION_ghc(9,2,1) +#if MIN_VERSION_ghc(9,2,1) && !MIN_VERSION_ghc(9,3,0) | cts == empty = foo #endif | otherwise = foo $$ (caret $ ul cts) @@ -57,6 +61,7 @@ showAstDataHtml a0 = html $ header = tag "head" $ tag "style" $ text css html = tag "html" pre = tag "pre" +<<<<<<< HEAD:plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs #if MIN_VERSION_ghc(9,2,1) showAstDataHtml' :: Data a => a -> SDoc showAstDataHtml' = diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index a0d8ce135e7..d56b513a79c 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -3,6 +3,9 @@ -- | This module hosts various abstractions and utility functions to work with ghc-exactprint. module Development.IDE.GHC.ExactPrint +#if MIN_VERSION_ghc(9,3,0) + ( ) where +#else ( Graft(..), graftDecls, graftDeclsWithM, @@ -665,3 +668,5 @@ isCommaAnn :: TrailingAnn -> Bool isCommaAnn AddCommaAnn{} = True isCommaAnn _ = False #endif + +#endif diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index d883e84e890..01c3b555c1c 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -132,14 +132,16 @@ iePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescrip iePluginDescriptor recorder plId = let old = mkGhcideCAsPlugin [ - wrap suggestExtendImport - , wrap suggestImportDisambiguation - , wrap suggestNewOrExtendImportForClassMethod - , wrap suggestNewImport + wrap suggestExportUnusedTopBinding , wrap suggestModuleTypo , wrap suggestFixConstructorImport + , wrap suggestNewImport +#if !MIN_VERSION_ghc(9,3,0) + , wrap suggestExtendImport + , wrap suggestImportDisambiguation + , wrap suggestNewOrExtendImportForClassMethod , wrap suggestHideShadow - , wrap suggestExportUnusedTopBinding +#endif ] plId in mkExactprintPluginDescriptor recorder $ old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction } @@ -149,9 +151,11 @@ typeSigsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ mkGhcideCAsPlugin [ wrap $ suggestSignature True , wrap suggestFillTypeWildcard - , wrap removeRedundantConstraints , wrap suggestAddTypeAnnotationToSatisfyContraints +#if !MIN_VERSION_ghc(9,3,0) + , wrap removeRedundantConstraints , wrap suggestConstraint +#endif ] plId @@ -159,7 +163,9 @@ bindingsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> Plugin bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ mkGhcideCAsPlugin [ wrap suggestReplaceIdentifier +#if !MIN_VERSION_ghc(9,3,0) , wrap suggestImplicitParameter +#endif , wrap suggestNewDefinition , wrap suggestDeleteUnusedBinding ] @@ -296,7 +302,11 @@ findSigOfBind range bind = msum [findSigOfBinds range (grhssLocalBinds grhs) -- where clause , do +#if MIN_VERSION_ghc(9,3,0) + grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs) +#else grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs) +#endif case unLoc grhs of GRHS _ _ bd -> findSigOfExpr (unLoc bd) ] @@ -305,7 +315,11 @@ findSigOfBind range bind = findSigOfExpr :: HsExpr p -> Maybe (Sig p) findSigOfExpr = go where +#if MIN_VERSION_ghc(9,3,0) + go (HsLet _ _ binds _ _) = findSigOfBinds range binds +#else go (HsLet _ binds _) = findSigOfBinds range binds +#endif go (HsDo _ _ stmts) = do stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts) case stmtlr of @@ -355,6 +369,7 @@ findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l) -- imported from ‘Data.ByteString’ at B.hs:6:1-22 -- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 -- imported from ‘Data.Text’ at B.hs:7:1-16 +#if !MIN_VERSION_ghc(9,3,0) suggestHideShadow :: Annotated ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range} | Just [identifier, modName, s] <- @@ -386,6 +401,7 @@ suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range} then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl | otherwise = [] +#endif findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) findImportDeclByModuleName decls modName = flip find decls $ \case @@ -978,6 +994,7 @@ getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of indentation :: T.Text -> Int indentation = T.length . T.takeWhile isSpace +#if !MIN_VERSION_ghc(9,3,0) suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)] suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} | Just [binding, mod, srcspan] <- @@ -1025,6 +1042,7 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_ , parent = Nothing , isDatacon = False , moduleNameText = mod} +#endif data HidingMode = HideOthers [ModuleTarget] @@ -1050,6 +1068,7 @@ oneAndOthers = go isPreludeImplicit :: DynFlags -> Bool isPreludeImplicit = xopt Lang.ImplicitPrelude +#if !MIN_VERSION_ghc(9,3,0) -- | Suggests disambiguation for ambiguous symbols. suggestImportDisambiguation :: DynFlags -> @@ -1141,6 +1160,7 @@ suggestImportDisambiguation df (Just txt) ps fileContents diag@Diagnostic {..} <> "." <> symbol suggestImportDisambiguation _ _ _ _ _ = [] +#endif occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool occursUnqualified symbol ImportDecl{..} @@ -1163,6 +1183,7 @@ targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) = targetModuleName (ExistingImp _) = error "Cannot happen!" +#if !MIN_VERSION_ghc(9,3,0) disambiguateSymbol :: Annotated ParsedSource -> T.Text -> @@ -1195,6 +1216,8 @@ disambiguateSymbol ps fileContents Diagnostic {..} (T.unpack -> symbol) = \case liftParseAST @RdrName df $ T.unpack $ printOutputable $ L (mkGeneralSrcSpan "") rdr ] +#endif + findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs @@ -1212,6 +1235,7 @@ suggestFixConstructorImport Diagnostic{_range=_range,..} in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)] | otherwise = [] +#if !MIN_VERSION_ghc(9,3,0) -- | Suggests a constraint for a declaration for which a constraint is missing. suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..} @@ -1293,10 +1317,12 @@ suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _rang [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) , appendConstraint (T.unpack implicitT) hsib_body)] | otherwise = [] +#endif findTypeSignatureName :: T.Text -> Maybe T.Text findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head +#if !MIN_VERSION_ghc(9,3,0) -- | Suggests a constraint for a type signature with any number of existing constraints. suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] @@ -1443,6 +1469,7 @@ suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnos ] <> [(quickFixImportKind "new.all", newImportAll moduleNameText)] | otherwise -> [] +#endif suggestNewImport :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] suggestNewImport packageExportsMap ps fileContents Diagnostic{_message} diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 59c0ac868f9..ef5c7b623af 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -26,8 +26,10 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.ExactPrint +#if !MIN_VERSION_ghc(9,3,0) import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite, rewriteToEdit) +#endif import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), GlobalBindingTypeSigsResult) import Development.IDE.Spans.LocalBindings (Bindings) @@ -70,7 +72,9 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra Just (_, txt) -> pure txt _ -> pure Nothing caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule +#if !MIN_VERSION_ghc(9,3,0) caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource +#endif caaTmr <- onceIO $ runRule TypeCheck caaHar <- onceIO $ runRule GetHieAst caaBindings <- onceIO $ runRule GetBindings @@ -113,6 +117,7 @@ class ToTextEdit a where instance ToTextEdit TextEdit where toTextEdit _ = pure . pure +#if !MIN_VERSION_ghc(9,3,0) instance ToTextEdit Rewrite where toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $ runMaybeT $ do @@ -124,6 +129,7 @@ instance ToTextEdit Rewrite where let r = rewriteToEdit df rw #endif pure $ fromRight [] r +#endif instance ToTextEdit a => ToTextEdit [a] where toTextEdit caa = foldMap (toTextEdit caa) @@ -143,7 +149,11 @@ data CodeActionArgs = CodeActionArgs caaParsedModule :: IO (Maybe ParsedModule), caaContents :: IO (Maybe T.Text), caaDf :: IO (Maybe DynFlags), +#if MIN_VERSION_ghc(9,3,0) + caaAnnSource :: IO (Maybe ParsedSource), +#else caaAnnSource :: IO (Maybe (Annotated ParsedSource)), +#endif caaTmr :: IO (Maybe TcModuleResult), caaHar :: IO (Maybe HieAstResult), caaBindings :: IO (Maybe Bindings), @@ -212,10 +222,17 @@ toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCode -- | this instance returns a delta AST, useful for exactprint transforms instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where +#if !MIN_VERSION_ghc(9,3,0) toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> x >>= \case Just s -> flip runReaderT caa . toCodeAction . f . astA $ s _ -> pure [] +#else + toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} -> + x >>= \case + Just s -> flip runReaderT caa . toCodeAction . f . pm_parsed_source $ s + _ -> pure [] +#endif instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where toCodeAction = toCodeAction3 caaExportsMap @@ -244,11 +261,13 @@ instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where instance ToCodeAction r => ToCodeAction (DynFlags -> r) where toCodeAction = toCodeAction2 caaDf +#if !MIN_VERSION_ghc(9,3,0) instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where toCodeAction = toCodeAction1 caaAnnSource instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where toCodeAction = toCodeAction2 caaAnnSource +#endif instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where toCodeAction = toCodeAction1 caaTmr diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 57da3ee2f61..123ae7b0c04 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -723,3 +723,5 @@ deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ = do (filter ((/= symbol) . T.pack . Util.unpackFS . flLabel . unLoc) flds) #endif killLie v = Just v + +#endif