haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-09-11 08:45:35 +03:00
Code Issues Projects Releases Wiki Activity

9.4 support + MHU

Browse Source
This commit is contained in:
Zubin Duggal 2022-06-27 11:58:43 +05:30 committed by wz1000
parent fdbc555a92
commit 6c99563a9f
70 changed files with 1370 additions and 246 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.github/actions/setup-build/action.yml vendored
View File

@ -7,7 +7,7 @@ inputs:
cabal:
description: "Cabal version"
required: false
default: "3.6"
default: "3.8.1.0"
os:
description: "Operating system: Linux, Windows or macOS"
required: true

10
.github/workflows/test.yml vendored
View File

@ -57,7 +57,9 @@ jobs:
strategy:
fail-fast: true
matrix:
ghc: [ "9.2.4"
ghc: [ "9.4.2"
, "9.4.1"
, "9.2.4"
, "9.2.3"
, "9.0.2"
, "8.10.7"
@ -69,6 +71,9 @@ jobs:
]
include:
# only test supported ghc major versions
- os: ubuntu-latest
ghc: '9.4.2'
test: true
- os: ubuntu-latest
ghc: '9.2.4'
test: true
@ -84,6 +89,9 @@ jobs:
- os: ubuntu-latest
ghc: '8.6.5'
test: true
- os: windows-latest
ghc: '9.4.2'
test: true
- os: windows-latest
ghc: '9.2.4'
test: true

6
.gitlab-ci.yml
View File

@ -9,7 +9,7 @@ variables:
# Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: "4ed1a4f27828ba96a34662dc954335e29b470cd2"
CABAL_INSTALL_VERSION: 3.6.2.0
CABAL_INSTALL_VERSION: 3.8.1.0
.windows_matrix: &windows_matrix
matrix:
@ -21,6 +21,10 @@ variables:
CABAL_PROJECT: cabal.project
- GHC_VERSION: 9.2.4
CABAL_PROJECT: cabal.project
- GHC_VERSION: 9.4.1
CABAL_PROJECT: cabal.project
- GHC_VERSION: 9.4.2
CABAL_PROJECT: cabal.project
workflow:
rules:

2
bindist/ghcs
View File

@ -4,3 +4,5 @@
9.0.2,cabal.project
9.2.3,cabal.project
9.2.4,cabal.project
9.4.1,cabal.project
9.4.2,cabal.project

2
bindist/ghcs-Msys
View File

@ -2,3 +2,5 @@
9.0.2,cabal.project
9.2.3,cabal.project
9.2.4,cabal.project
9.4.1,cabal.project
9.4.2,cabal.project

13
cabal.project
View File

@ -67,6 +67,16 @@ source-repository-package
tag: 7a0af7a8fd38045fd15fb13445bdcc7085325460
-- https://github.com/tibbe/ekg-json/pull/12
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
-- Needed for ghcide-bench until a new release of lsp-test is out
source-repository-package
type:git
@ -76,6 +86,9 @@ source-repository-package
-- https://github.com/haskell/lsp/pull/450
allow-newer:
base, ghc-prim, ghc-bignum, ghc, Cabal, binary, bytestring, unix, time, template-haskell,
ghc-paths:Cabal,
-- ghc-9.2
----------
hiedb:base,

3
ghcide/ghcide.cabal
View File

@ -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

47
ghcide/session-loader/Development/IDE/Session.hs
View File

@ -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,9 @@ import HieDb.Types
import HieDb.Utils
import qualified System.Random as Random
import System.Random (RandomGen)
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Exception (evaluate)
import Control.DeepSeq
data Log
= LogSettingInitialDynFlags
@ -208,11 +212,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 +227,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 +502,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 +529,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 +734,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 +777,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 +797,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,2,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 +811,10 @@ 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
let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath
henv <- newFunc hscEnv' uids
@ -790,6 +822,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 +1031,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 =

407
ghcide/src/Development/IDE/Core/Compile.hs
View File

@ -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,55 @@ 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
; lbs <- getLinkables [toNormalizedFilePath' file | mod <- mkHomeModule
#if MIN_VERSION_ghc(9,0,0)
(hscHomeUnit hsc_env)
home_unit_ids =
#if MIN_VERSION_ghc(9,3,0)
map fst (hugElts $ hsc_HUG hsc_env)
#else
uid
[homeUnitId_ dflags]
#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] }
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
#if MIN_VERSION_ghc(9,0,0)
(mkModule (homeUnitId_ dflags))
#else
(InstalledModule (toInstalledUnitId $ homeUnitId_ dflags))
#endif
-- Non det OK as we will put it into maps later anyway
$ nonDetEltsUniqSet mods_transitive
#endif
#if MIN_VERSION_ghc(9,3,0)
; moduleLocs <- readIORef (fcModuleCache $ hsc_FC hsc_env)
#else
; moduleLocs <- readIORef (hsc_FC hsc_env)
#endif
; 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 +357,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 +385,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 +449,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,12 +471,22 @@ 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
#if MIN_VERSION_ghc(9,4,2)
Nothing
#endif
#elif MIN_VERSION_ghc(8,10,0)
let !partial_iface = force (mkPartialIface session details simplified_guts)
final_iface <- mkFullIface session partial_iface
@ -464,8 +529,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,9 +627,17 @@ 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)
#if MIN_VERSION_ghc(9,4,2)
(outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts
#elif MIN_VERSION_ghc(9,0,1)
(outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts
#else
(outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts
@ -565,7 +648,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 +704,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 +723,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 +752,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 +802,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 +815,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 +1017,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 +1091,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 +1110,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 +1139,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)
srcImports = map convImport src_idecls
textualImports = map convImport (implicit_imports ++ ordinary_imps)
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
-- 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 +1192,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 +1223,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 +1324,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 +1471,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 +1514,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 +1556,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 +1594,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 +1626,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

4
ghcide/src/Development/IDE/Core/IdeConfiguration.hs
View File

@ -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 ()

14
ghcide/src/Development/IDE/Core/Preprocessor.hs
View File

@ -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

35
ghcide/src/Development/IDE/Core/Rules.hs
View File

@ -158,6 +158,10 @@ 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
data Log
= LogShake Shake.Log
@ -664,7 +668,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 +689,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 +777,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 +897,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 +913,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 +996,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

22
ghcide/src/Development/IDE/Core/Shake.hs
View File

@ -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) }

3
ghcide/src/Development/IDE/GHC/CPP.hs
View File

@ -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)

99
ghcide/src/Development/IDE/GHC/Compat.hs
View File

@ -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,46 @@ 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
#if MIN_VERSION_ghc(9,4,2)
(stg_binds2,_)
#else
stg_binds2
#endif
<- {-# 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 +367,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 +395,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 +411,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 +433,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 +441,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 +451,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 +611,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

185
ghcide/src/Development/IDE/GHC/Compat/Core.hs
View File

@ -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

18
ghcide/src/Development/IDE/GHC/Compat/Env.hs
View File

@ -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

7
ghcide/src/Development/IDE/GHC/Compat/Iface.hs
View File

@ -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)

13
ghcide/src/Development/IDE/GHC/Compat/Logger.hs
View File

@ -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

32
ghcide/src/Development/IDE/GHC/Compat/Outputable.hs
View File

@ -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)

4
ghcide/src/Development/IDE/GHC/Compat/Parser.hs
View File

@ -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)

21
ghcide/src/Development/IDE/GHC/Compat/Plugins.hs
View File

@ -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

95
ghcide/src/Development/IDE/GHC/Compat/Units.hs
View File

@ -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
#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)))
dflags <- DynFlags.updatePlatformConstants dflags1 mconstants
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

2
ghcide/src/Development/IDE/GHC/Compat/Util.hs
View File

@ -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,

13
ghcide/src/Development/IDE/GHC/Error.hs
View File

@ -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]

17
ghcide/src/Development/IDE/GHC/Orphans.hs
View File

@ -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

2
ghcide/src/Development/IDE/GHC/Util.hs
View File

@ -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

23
ghcide/src/Development/IDE/GHC/Warnings.hs
View File

@ -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

79
ghcide/src/Development/IDE/Import/FindImports.hs
View File

@ -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)
#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 dirs = do
mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName
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

30
ghcide/src/Development/IDE/LSP/Outline.hs
View File

@ -11,7 +11,7 @@ where
import Control.Monad.IO.Class
import Data.Functor
import Data.Generics
import Data.Generics hiding (Prefix)
import Data.Maybe
import qualified Data.Text as T
import Development.IDE.Core.Rules
@ -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
@ -161,8 +169,13 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfi
documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
#endif
= Just (defDocumentSymbol l :: DocumentSymbol)
{ _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords
{ _name =
#if MIN_VERSION_ghc(9,3,0)
printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats)
#else
printOutputable (unLoc feqn_tycon) <> " " <> T.unwords
(map printOutputable feqn_pats)
#endif
, _kind = SkInterface
}
#if MIN_VERSION_ghc(9,2,0)
@ -171,8 +184,13 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_
documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
#endif
= Just (defDocumentSymbol l :: DocumentSymbol)
{ _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords
{ _name =
#if MIN_VERSION_ghc(9,3,0)
printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats)
#else
printOutputable (unLoc feqn_tycon) <> " " <> T.unwords
(map printOutputable feqn_pats)
#endif
, _kind = SkInterface
}
documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) =
@ -217,7 +235,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 +311,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]

4
ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
View File

@ -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 _ _ _ _ = []

11
ghcide/src/Development/IDE/Spans/Common.hs
View File

@ -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

17
ghcide/src/Development/IDE/Spans/Documentation.hs
View File

@ -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 =

47
ghcide/test/exe/Main.hs
View File

@ -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,13 +564,20 @@ 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
expectDiagnostics
[ ( "Main.hs"
, [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")
, [(DsError, (6, 9),
if ghcVersion >= GHC94
then "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130
else "Not in scope: \8216ThisList.map\8217")
,(DsError, (7, 9),
if ghcVersion >= GHC94
then "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130
else "Not in scope: \8216BaseList.x\8217")
]
)
]
@ -588,7 +595,7 @@ diagnosticTests = testGroup "diagnostics"
-- where appropriate. The warning should use an unqualified name 'Ord', not
-- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to
-- test this is fairly arbitrary.
, [(DsWarning, (2, 0), "Redundant constraint: Ord a")
, [(DsWarning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a")
]
)
]
@ -621,7 +628,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
@ -1096,7 +1103,7 @@ findDefinitionAndHoverTests = let
holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]]
cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"]
imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]
reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]
reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)]
thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]
in
mkFindTests
@ -1180,7 +1187,7 @@ checkFileCompiles fp diag =
pluginSimpleTests :: TestTree
pluginSimpleTests =
ignoreInWindowsForGHC88And810 $
ignoreForGHC92 "blocked on ghc-typelits-natnormalise" $
ignoreForGHC92Plus "blocked on ghc-typelits-natnormalise" $
testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do
_ <- openDoc (dir </> "KnownNat.hs") "haskell"
liftIO $ writeFile (dir</>"hie.yaml")
@ -1195,7 +1202,7 @@ pluginSimpleTests =
pluginParsedResultTests :: TestTree
pluginParsedResultTests =
ignoreInWindowsForGHC88And810 $
ignoreForGHC92 "No need for this plugin anymore!" $
ignoreForGHC92Plus "No need for this plugin anymore!" $
testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do
_ <- openDoc (dir</> "RecordDot.hs") "haskell"
expectNoMoreDiagnostics 2
@ -1778,10 +1785,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
@ -1994,10 +2001,10 @@ completionDocTests =
test doc (Position 1 7) "id" (Just $ T.length expected) [expected]
]
where
brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92]) "Completion doc doesn't support ghc9"
brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2"
brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94]) "Completion doc doesn't support ghc9"
brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92, GHC94]) "Extern doc doesn't support Windows for ghc9.2"
-- https://gitlab.haskell.org/ghc/ghc/-/issues/20903
brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92]) "Extern doc doesn't support MacOS for ghc9"
brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94]) "Extern doc doesn't support MacOS for ghc9"
test doc pos label mn expected = do
_ <- waitForDiagnostics
compls <- getCompletions doc pos
@ -2040,7 +2047,7 @@ highlightTests = testGroup "highlight"
, DocumentHighlight (R 6 10 6 13) (Just HkRead)
, DocumentHighlight (R 7 12 7 15) (Just HkRead)
]
, knownBrokenForGhcVersions [GHC90, GHC92] "Ghc9 highlights the constructor and not just this field" $
, knownBrokenForGhcVersions [GHC90, GHC92, GHC94] "Ghc9 highlights the constructor and not just this field" $
testSessionWait "record" $ do
doc <- createDoc "A.hs" "haskell" recsource
_ <- waitForDiagnostics
@ -2048,8 +2055,8 @@ highlightTests = testGroup "highlight"
liftIO $ highlights @?= List
-- Span is just the .. on 8.10, but Rec{..} before
[ if ghcVersion >= GHC810
then DocumentHighlight (R 4 8 4 10) (Just HkWrite)
else DocumentHighlight (R 4 4 4 11) (Just HkWrite)
then DocumentHighlight (R 4 8 4 10) (Just HkWrite)
else DocumentHighlight (R 4 4 4 11) (Just HkWrite)
, DocumentHighlight (R 4 14 4 20) (Just HkRead)
]
highlights <- getHighlights doc (Position 3 17)
@ -2270,8 +2277,8 @@ ignoreInWindowsForGHC88And810 :: TestTree -> TestTree
ignoreInWindowsForGHC88And810 =
ignoreFor (BrokenSpecific Windows [GHC88, GHC810]) "tests are unreliable in windows for ghc 8.8 and 8.10"
ignoreForGHC92 :: String -> TestTree -> TestTree
ignoreForGHC92 = ignoreFor (BrokenForGHC [GHC92])
ignoreForGHC92Plus :: String -> TestTree -> TestTree
ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94])
ignoreInWindowsForGHC88 :: TestTree -> TestTree
ignoreInWindowsForGHC88 =

40
haskell-language-server.cabal
View File

@ -239,12 +239,12 @@ flag dynamic
manual: True
common class
if flag(class)
if flag(class) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-class-plugin ^>= 1.0
cpp-options: -Dhls_class
common callHierarchy
if flag(callHierarchy)
if flag(callHierarchy) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-call-hierarchy-plugin ^>= 1.0
cpp-options: -Dhls_callHierarchy
@ -254,22 +254,22 @@ common haddockComments
cpp-options: -Dhls_haddockComments
common eval
if flag(eval)
if flag(eval) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-eval-plugin ^>= 1.2
cpp-options: -Dhls_eval
common importLens
if flag(importLens)
if flag(importLens) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-explicit-imports-plugin ^>= 1.1
cpp-options: -Dhls_importLens
common refineImports
if flag(refineImports)
if flag(refineImports) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-refine-imports-plugin ^>=1.0
cpp-options: -Dhls_refineImports
common rename
if flag(rename)
if flag(rename) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-rename-plugin ^>= 1.0
cpp-options: -Dhls_rename
@ -284,7 +284,7 @@ common tactic
cpp-options: -Dhls_tactic
common hlint
if flag(hlint)
if flag(hlint) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-hlint-plugin ^>= 1.0
cpp-options: -Dhls_hlint
@ -294,12 +294,12 @@ common stan
cpp-options: -Dhls_stan
common moduleName
if flag(moduleName)
if flag(moduleName) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-module-name-plugin ^>= 1.0
cpp-options: -Dhls_moduleName
common pragmas
if flag(pragmas)
if flag(pragmas) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-pragmas-plugin ^>= 1.0
cpp-options: -Dhls_pragmas
@ -309,54 +309,54 @@ common splice
cpp-options: -Dhls_splice
common alternateNumberFormat
if flag(alternateNumberFormat)
if flag(alternateNumberFormat) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-alternate-number-format-plugin ^>= 1.1
cpp-options: -Dhls_alternateNumberFormat
common qualifyImportedNames
if flag(qualifyImportedNames)
if flag(qualifyImportedNames) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-qualify-imported-names-plugin ^>=1.0
cpp-options: -Dhls_qualifyImportedNames
common codeRange
if flag(codeRange)
if flag(codeRange) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-code-range-plugin ^>= 1.0
cpp-options: -Dhls_codeRange
common changeTypeSignature
if flag(changeTypeSignature)
if flag(changeTypeSignature) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-change-type-signature-plugin ^>= 1.0
cpp-options: -Dhls_changeTypeSignature
common gadt
if flag(gadt)
if flag(gadt) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-gadt-plugin ^>= 1.0
cpp-options: -Dhls_gadt
common explicitFixity
if flag(explicitFixity)
if flag(explicitFixity) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-explicit-fixity-plugin ^>= 1.0
cpp-options: -DexplicitFixity
-- formatters
common floskell
if flag(floskell)
if flag(floskell) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-floskell-plugin ^>= 1.0
cpp-options: -Dhls_floskell
common fourmolu
if flag(fourmolu)
if flag(fourmolu) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-fourmolu-plugin ^>= 1.0
cpp-options: -Dhls_fourmolu
common ormolu
if flag(ormolu)
if flag(ormolu) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-ormolu-plugin ^>= 1.0
cpp-options: -Dhls_ormolu
common stylishHaskell
if flag(stylishHaskell)
if flag(stylishHaskell) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-stylish-haskell-plugin ^>= 1.0
cpp-options: -Dhls_stylishHaskell
@ -366,7 +366,7 @@ common brittany
cpp-options: -Dhls_brittany
common refactor
if flag(refactor)
if flag(refactor) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
build-depends: hls-refactor-plugin ^>= 1.0
cpp-options: -Dhls_refactor

2
hie-compat/hie-compat.cabal
View File

@ -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

3
hie-compat/src-reexport-ghc92/Compat/HieAst.hs Normal file
View File

@ -0,0 +1,3 @@
module Compat.HieAst
( module GHC.Iface.Ext.Ast ) where
import GHC.Iface.Ext.Ast

8
hie-compat/src-reexport-ghc92/Compat/HieBin.hs Normal file
View File

@ -0,0 +1,8 @@
{-
Binary serialization for .hie files.
-}
module Compat.HieBin ( module GHC.Iface.Ext.Binary)
where
import GHC.Iface.Ext.Binary

10
hie-compat/src-reexport-ghc92/Compat/HieDebug.hs Normal file
View File

@ -0,0 +1,10 @@
module Compat.HieDebug
( module GHC.Iface.Ext.Debug
, ppHie ) where
import GHC.Iface.Ext.Debug
import GHC.Iface.Ext.Types (HieAST)
import GHC.Utils.Outputable (Outputable(ppr), SDoc)
ppHie :: Outputable a => HieAST a -> SDoc
ppHie = ppr

3
hie-compat/src-reexport-ghc92/Compat/HieTypes.hs Normal file
View File

@ -0,0 +1,3 @@
module Compat.HieTypes
( module GHC.Iface.Ext.Types ) where
import GHC.Iface.Ext.Types

3
hie-compat/src-reexport-ghc92/Compat/HieUtils.hs Normal file
View File

@ -0,0 +1,3 @@
module Compat.HieUtils
( module GHC.Iface.Ext.Utils ) where
import GHC.Iface.Ext.Utils

8
plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal
View File

@ -18,6 +18,10 @@ extra-source-files:
test/testdata/*.yaml
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.AlternateNumberFormat, Ide.Plugin.Conversion
other-modules: Ide.Plugin.Literals
hs-source-dirs: src
@ -47,6 +51,10 @@ library
RecordWildCards
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal
View File

@ -16,6 +16,10 @@ extra-source-files:
test/testdata/*.hs
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.CallHierarchy
other-modules:
Ide.Plugin.CallHierarchy.Internal
@ -43,6 +47,10 @@ library
default-extensions: DataKinds
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal
View File

@ -19,6 +19,10 @@ extra-source-files:
test/testdata/*.yaml
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.ChangeTypeSignature
hs-source-dirs: src
build-depends:
@ -46,6 +50,10 @@ library
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-class-plugin/hls-class-plugin.cabal
View File

@ -21,6 +21,10 @@ extra-source-files:
test/testdata/*.hs
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.Class
other-modules: Ide.Plugin.Class.CodeAction
, Ide.Plugin.Class.CodeLens
@ -58,6 +62,10 @@ library
ghc-options: -Wall -Wno-unticked-promoted-constructors -Wno-name-shadowing
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-code-range-plugin/hls-code-range-plugin.cabal
View File

@ -21,6 +21,10 @@ extra-source-files:
test/testdata/selection-range/*.txt
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules:
Ide.Plugin.CodeRange
Ide.Plugin.CodeRange.Rules
@ -48,6 +52,10 @@ library
, vector
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-eval-plugin/hls-eval-plugin.cabal
View File

@ -37,6 +37,10 @@ source-repository head
location: https://github.com/haskell/haskell-language-server
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules:
Ide.Plugin.Eval
Ide.Plugin.Eval.Types
@ -97,6 +101,10 @@ library
TypeOperators
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-explicit-fixity-plugin/hls-explicit-fixity-plugin.cabal
View File

@ -16,6 +16,10 @@ extra-source-files:
test/testdata/*.hs
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.ExplicitFixity
hs-source-dirs: src
@ -39,6 +43,10 @@ library
default-extensions: DataKinds
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal
View File

@ -16,6 +16,10 @@ extra-source-files:
test/testdata/*.yaml
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.ExplicitImports
hs-source-dirs: src
build-depends:
@ -37,6 +41,10 @@ library
TypeOperators
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-floskell-plugin/hls-floskell-plugin.cabal
View File

@ -17,6 +17,10 @@ extra-source-files:
test/testdata/**/*.hs
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.Floskell
hs-source-dirs: src
build-depends:
@ -31,6 +35,10 @@ library
default-language: Haskell2010
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal
View File

@ -23,6 +23,10 @@ source-repository head
location: git://github.com/haskell/haskell-language-server.git
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules:
Ide.Plugin.Fourmolu
, Ide.Plugin.Fourmolu.Shim
@ -44,6 +48,10 @@ library
default-language: Haskell2010
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-gadt-plugin/hls-gadt-plugin.cabal
View File

@ -16,6 +16,10 @@ extra-source-files:
test/testdata/*.hs
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.GADT
other-modules: Ide.Plugin.GHC
@ -46,6 +50,10 @@ library
default-extensions: DataKinds
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-hlint-plugin/hls-hlint-plugin.cabal
View File

@ -26,6 +26,10 @@ flag pedantic
manual: True
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.Hlint
hs-source-dirs: src
build-depends:
@ -73,6 +77,10 @@ library
TypeOperators
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-module-name-plugin/hls-module-name-plugin.cabal
View File

@ -20,6 +20,10 @@ extra-source-files:
test/testdata/**/*.project
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.ModuleName
hs-source-dirs: src
build-depends:
@ -37,6 +41,10 @@ library
default-language: Haskell2010
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal
View File

@ -17,6 +17,10 @@ extra-source-files:
test/testdata/**/*.hs
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.Ormolu
hs-source-dirs: src
build-depends:
@ -34,6 +38,10 @@ library
default-language: Haskell2010
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal
View File

@ -18,6 +18,10 @@ extra-source-files:
test/testdata/*.yaml
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.Pragmas
hs-source-dirs: src
build-depends:
@ -37,6 +41,10 @@ library
default-language: Haskell2010
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-qualify-imported-names-plugin/hls-qualify-imported-names-plugin.cabal
View File

@ -18,6 +18,10 @@ extra-source-files:
test/data/*.yaml
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.QualifyImportedNames
hs-source-dirs: src
build-depends:
@ -41,6 +45,10 @@ library
TypeOperators
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-refactor-plugin/hls-refactor-plugin.cabal
View File

@ -18,6 +18,10 @@ extra-source-files:
test/data/**/*.yaml
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Development.IDE.GHC.ExactPrint
Development.IDE.GHC.Compat.ExactPrint
Development.IDE.Plugin.CodeAction
@ -81,6 +85,10 @@ library
default-language: Haskell2010
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

5
plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs
View File

@ -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

8
plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs
View File

@ -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)

5
plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs
View File

@ -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

39
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs
View File

@ -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}

19
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs
View File

@ -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

8
plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal
View File

@ -16,6 +16,10 @@ extra-source-files:
test/testdata/*.yaml
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.RefineImports
hs-source-dirs: src
build-depends:
@ -38,6 +42,10 @@ library
TypeOperators
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-rename-plugin/hls-rename-plugin.cabal
View File

@ -17,6 +17,10 @@ extra-source-files:
test/testdata/*.yaml
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.Rename
hs-source-dirs: src
build-depends:
@ -41,6 +45,10 @@ library
default-language: Haskell2010
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

4
plugins/hls-retrie-plugin/hls-retrie-plugin.cabal
View File

@ -13,6 +13,10 @@ build-type: Simple
extra-source-files: LICENSE
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.Retrie
hs-source-dirs: src
build-depends:

8
plugins/hls-splice-plugin/hls-splice-plugin.cabal
View File

@ -23,6 +23,10 @@ extra-source-files:
test/testdata/*.yaml
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules:
Ide.Plugin.Splice
Ide.Plugin.Splice.Types
@ -56,6 +60,10 @@ library
TypeOperators
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

2
plugins/hls-stan-plugin/hls-stan-plugin.cabal
View File

@ -76,4 +76,4 @@ test-suite test
, text
default-extensions:
NamedFieldPuns
OverloadedStrings
OverloadedStrings

8
plugins/hls-stylish-haskell-plugin/hls-stylish-haskell-plugin.cabal
View File

@ -16,6 +16,10 @@ extra-source-files:
test/testdata/*.hs
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
exposed-modules: Ide.Plugin.StylishHaskell
hs-source-dirs: src
build-depends:
@ -33,6 +37,10 @@ library
default-language: Haskell2010
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
default-language: Haskell2010
hs-source-dirs: test

8
plugins/hls-tactics-plugin/hls-tactics-plugin.cabal
View File

@ -25,6 +25,10 @@ flag pedantic
manual: True
library
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
hs-source-dirs: src
exposed-modules:
Ide.Plugin.Tactic
@ -127,6 +131,10 @@ library
ViewPatterns
test-suite tests
if impl(ghc >= 9.3)
buildable: False
else
buildable: True
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules: