mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
Remove pre-multi component junk for GHC <= 9.2
This commit is contained in:
parent
617542dc9c
commit
9d3480a9bc
@ -62,8 +62,7 @@ import Development.IDE.Graph (Action)
|
||||
import qualified Development.IDE.Session.Implicit as GhcIde
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.Types.Exports
|
||||
import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq,
|
||||
newHscEnvEqPreserveImportPaths)
|
||||
import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq)
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Types.Options
|
||||
import GHC.ResponseFile
|
||||
@ -569,8 +568,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
|
||||
-- For GHC's supporting multi component sessions, we create a shared
|
||||
-- HscEnv but set the active component accordingly
|
||||
hscEnv <- emptyHscEnv ideNc _libDir
|
||||
let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv
|
||||
all_target_details <- new_cache old_deps new_deps rootDir
|
||||
let new_cache = newComponentCache recorder optExtensions _cfp hscEnv
|
||||
all_target_details <- new_cache old_deps new_deps
|
||||
|
||||
this_dep_info <- getDependencyInfo $ maybeToList hieYaml
|
||||
let (all_targets, this_flags_map, this_options)
|
||||
@ -761,10 +760,6 @@ emptyHscEnv nc libDir = do
|
||||
-- We need to do this before we call initUnits.
|
||||
env <- runGhc (Just libDir) $
|
||||
getSessionDynFlags >>= setSessionDynFlags >> getSession
|
||||
-- On GHC 9.2 calling setSessionDynFlags caches the unit databases
|
||||
-- for an empty environment. This prevents us from reading the
|
||||
-- package database subsequently. So clear the unit db cache in
|
||||
-- hsc_unit_dbs
|
||||
pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env)
|
||||
|
||||
data TargetDetails = TargetDetails
|
||||
@ -870,14 +865,12 @@ checkHomeUnitsClosed' ue home_id_set
|
||||
newComponentCache
|
||||
:: Recorder (WithPriority Log)
|
||||
-> [String] -- ^ File extensions to consider
|
||||
-> Maybe FilePath -- ^ Path to cradle
|
||||
-> NormalizedFilePath -- ^ Path to file that caused the creation of this component
|
||||
-> HscEnv -- ^ An empty HscEnv
|
||||
-> [ComponentInfo] -- ^ New components to be loaded
|
||||
-> [ComponentInfo] -- ^ old, already existing components
|
||||
-> FilePath -- ^ root dir, see Note [Root Directory]
|
||||
-> IO [ [TargetDetails] ]
|
||||
newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do
|
||||
newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do
|
||||
let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis)
|
||||
-- When we have multiple components with the same uid,
|
||||
-- prefer the new one over the old.
|
||||
@ -917,13 +910,12 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do
|
||||
|
||||
forM (Map.elems cis) $ \ci -> do
|
||||
let df = componentDynFlags ci
|
||||
let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths (newHscEnvEq dir) cradlePath
|
||||
thisEnv <- do
|
||||
-- In GHC 9.4 we have multi component support, and we have initialised all the units
|
||||
-- above.
|
||||
-- We just need to set the current unit here
|
||||
pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv'
|
||||
henv <- createHscEnvEq thisEnv (zip uids dfs)
|
||||
henv <- newHscEnvEq thisEnv
|
||||
let targetEnv = (if isBad ci then multi_errs else [], Just henv)
|
||||
targetDepends = componentDependencyInfo ci
|
||||
logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)
|
||||
@ -1185,14 +1177,7 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do
|
||||
Compat.setUpTypedHoles $
|
||||
makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory
|
||||
dflags''
|
||||
-- initPackages parses the -package flags and
|
||||
-- sets up the visibility for each component.
|
||||
-- Throws if a -package flag cannot be satisfied.
|
||||
-- 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)
|
||||
return (dflags''', targets)
|
||||
|
||||
setIgnoreInterfacePragmas :: DynFlags -> DynFlags
|
||||
setIgnoreInterfacePragmas df =
|
||||
|
@ -50,7 +50,6 @@ import Development.IDE.Graph as X (Action, RuleResult,
|
||||
import Development.IDE.Plugin as X
|
||||
import Development.IDE.Types.Diagnostics as X
|
||||
import Development.IDE.Types.HscEnvEq as X (HscEnvEq (..),
|
||||
hscEnv,
|
||||
hscEnvWithImportPaths)
|
||||
hscEnv)
|
||||
import Development.IDE.Types.Location as X
|
||||
import Ide.Logger as X
|
||||
|
@ -319,18 +319,11 @@ getLocatedImportsRule recorder =
|
||||
(KnownTargets targets targetsMap) <- useNoFile_ GetKnownTargets
|
||||
let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
|
||||
env_eq <- use_ GhcSession file
|
||||
let env = hscEnvWithImportPaths env_eq
|
||||
let import_dirs = deps env_eq
|
||||
let env = hscEnv env_eq
|
||||
let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env
|
||||
let dflags = hsc_dflags env
|
||||
isImplicitCradle = isNothing $ envImportPaths env_eq
|
||||
let dflags' = if isImplicitCradle
|
||||
then addRelativeImport file (moduleName $ ms_mod ms) dflags
|
||||
else dflags
|
||||
opt <- getIdeOptions
|
||||
let getTargetFor modName nfp
|
||||
| isImplicitCradle = do
|
||||
itExists <- getFileExists nfp
|
||||
return $ if itExists then Just nfp else Nothing
|
||||
| Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do
|
||||
-- reuse the existing NormalizedFilePath in order to maximize sharing
|
||||
itExists <- getFileExists nfp'
|
||||
@ -341,10 +334,11 @@ getLocatedImportsRule recorder =
|
||||
nfp' = HM.lookupDefault nfp nfp ttmap
|
||||
itExists <- getFileExists nfp'
|
||||
return $ if itExists then Just nfp' else Nothing
|
||||
| otherwise
|
||||
= return Nothing
|
||||
| otherwise = do
|
||||
itExists <- getFileExists nfp
|
||||
return $ if itExists then Just nfp else Nothing
|
||||
(diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
|
||||
diagOrImp <- locateModule (hscSetFlags dflags' env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource
|
||||
diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource
|
||||
case diagOrImp of
|
||||
Left diags -> pure (diags, Just (modName, Nothing))
|
||||
Right (FileImport path) -> pure ([], Just (modName, Just path))
|
||||
|
@ -5,7 +5,6 @@ module Development.IDE.GHC.Compat.Units (
|
||||
-- * UnitState
|
||||
UnitState,
|
||||
initUnits,
|
||||
oldInitUnits,
|
||||
unitState,
|
||||
getUnitName,
|
||||
explicitUnits,
|
||||
@ -127,12 +126,6 @@ initUnits unitDflags env = do
|
||||
pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env
|
||||
|
||||
|
||||
-- | 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
|
||||
oldInitUnits = pure
|
||||
|
||||
explicitUnits :: UnitState -> [Unit]
|
||||
explicitUnits ue =
|
||||
map fst $ State.explicitUnits ue
|
||||
|
@ -1,25 +1,18 @@
|
||||
module Development.IDE.Types.HscEnvEq
|
||||
( HscEnvEq,
|
||||
hscEnv, newHscEnvEq,
|
||||
hscEnvWithImportPaths,
|
||||
newHscEnvEqPreserveImportPaths,
|
||||
newHscEnvEqWithImportPaths,
|
||||
updateHscEnvEq,
|
||||
envImportPaths,
|
||||
envPackageExports,
|
||||
envVisibleModuleNames,
|
||||
deps
|
||||
) where
|
||||
|
||||
|
||||
import Control.Concurrent.Async (Async, async, waitCatch)
|
||||
import Control.Concurrent.Strict (modifyVar, newVar)
|
||||
import Control.DeepSeq (force)
|
||||
import Control.DeepSeq (force, rwhnf)
|
||||
import Control.Exception (evaluate, mask, throwIO)
|
||||
import Control.Monad.Extra (eitherM, join, mapMaybeM)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Unique (Unique)
|
||||
import qualified Data.Unique as Unique
|
||||
import Development.IDE.GHC.Compat hiding (newUnique)
|
||||
@ -28,9 +21,7 @@ import Development.IDE.GHC.Error (catchSrcErrors)
|
||||
import Development.IDE.GHC.Util (lookupPackageConfig)
|
||||
import Development.IDE.Graph.Classes
|
||||
import Development.IDE.Types.Exports (ExportsMap, createExportsMap)
|
||||
import Ide.PluginUtils (toAbsolute)
|
||||
import OpenTelemetry.Eventlog (withSpan)
|
||||
import System.FilePath
|
||||
|
||||
-- | An 'HscEnv' with equality. Two values are considered equal
|
||||
-- if they are created with the same call to 'newHscEnvEq' or
|
||||
@ -38,13 +29,6 @@ import System.FilePath
|
||||
data HscEnvEq = HscEnvEq
|
||||
{ envUnique :: !Unique
|
||||
, hscEnv :: !HscEnv
|
||||
, deps :: [(UnitId, DynFlags)]
|
||||
-- ^ In memory components for this HscEnv
|
||||
-- This is only used at the moment for the import dirs in
|
||||
-- the DynFlags
|
||||
, envImportPaths :: Maybe (Set FilePath)
|
||||
-- ^ If Just, import dirs originally configured in this env
|
||||
-- If Nothing, the env import dirs are unaltered
|
||||
, envPackageExports :: IO ExportsMap
|
||||
, envVisibleModuleNames :: IO (Maybe [ModuleName])
|
||||
-- ^ 'listVisibleModuleNames' is a pure function,
|
||||
@ -59,19 +43,8 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do
|
||||
update <$> Unique.newUnique
|
||||
|
||||
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
|
||||
newHscEnvEq :: FilePath -> FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
|
||||
newHscEnvEq root cradlePath hscEnv0 deps = do
|
||||
let relativeToCradle = (takeDirectory cradlePath </>)
|
||||
hscEnv = removeImportPaths hscEnv0
|
||||
|
||||
-- Make Absolute since targets are also absolute
|
||||
let importPathsCanon = toAbsolute root . relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
|
||||
|
||||
newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps
|
||||
|
||||
newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
|
||||
newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do
|
||||
|
||||
newHscEnvEq :: HscEnv -> IO HscEnvEq
|
||||
newHscEnvEq hscEnv = do
|
||||
let dflags = hsc_dflags hscEnv
|
||||
|
||||
envUnique <- Unique.newUnique
|
||||
@ -112,23 +85,6 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do
|
||||
|
||||
return HscEnvEq{..}
|
||||
|
||||
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
|
||||
newHscEnvEqPreserveImportPaths
|
||||
:: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
|
||||
newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing
|
||||
|
||||
-- | Unwrap the 'HscEnv' with the original import paths.
|
||||
-- Used only for locating imports
|
||||
hscEnvWithImportPaths :: HscEnvEq -> HscEnv
|
||||
hscEnvWithImportPaths HscEnvEq{..}
|
||||
| Just imps <- envImportPaths
|
||||
= hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv
|
||||
| otherwise
|
||||
= hscEnv
|
||||
|
||||
removeImportPaths :: HscEnv -> HscEnv
|
||||
removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc
|
||||
|
||||
instance Show HscEnvEq where
|
||||
show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique)
|
||||
|
||||
@ -136,9 +92,9 @@ instance Eq HscEnvEq where
|
||||
a == b = envUnique a == envUnique b
|
||||
|
||||
instance NFData HscEnvEq where
|
||||
rnf (HscEnvEq a b c d _ _) =
|
||||
rnf (HscEnvEq a b _ _) =
|
||||
-- deliberately skip the package exports map and visible module names
|
||||
rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d
|
||||
rnf (Unique.hashUnique a) `seq` rwhnf b
|
||||
|
||||
instance Hashable HscEnvEq where
|
||||
hashWithSalt s = hashWithSalt s . envUnique
|
||||
|
@ -38,7 +38,7 @@ import Development.IDE (GetParsedModule (GetParse
|
||||
Priority (Debug),
|
||||
Recorder, WithPriority,
|
||||
colon, evalGhcEnv,
|
||||
hscEnvWithImportPaths,
|
||||
hscEnv,
|
||||
logWith,
|
||||
realSrcSpanToRange,
|
||||
rootDir, runAction,
|
||||
@ -140,7 +140,7 @@ pathModuleNames recorder state normFilePath filePath
|
||||
| firstLetter isLower $ takeFileName filePath = return ["Main"]
|
||||
| otherwise = do
|
||||
(session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession normFilePath
|
||||
srcPaths <- liftIO $ evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags
|
||||
srcPaths <- liftIO $ evalGhcEnv (hscEnv session) $ importPaths <$> getSessionDynFlags
|
||||
logWith recorder Debug (SrcPaths srcPaths)
|
||||
|
||||
-- Append a `pathSeparator` to make the path looks like a directory,
|
||||
|
@ -210,7 +210,7 @@ setupHscEnv ideState fp pm = do
|
||||
hscEnvEq <- runActionE "expandTHSplice.fallback.ghcSessionDeps" ideState $
|
||||
useE GhcSessionDeps fp
|
||||
let ps = annotateParsedSource pm
|
||||
hscEnv0 = hscEnvWithImportPaths hscEnvEq
|
||||
hscEnv0 = hscEnv hscEnvEq
|
||||
modSum = pm_mod_summary pm
|
||||
hscEnv <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum
|
||||
pure (ps, hscEnv, hsc_dflags hscEnv)
|
||||
|
Loading…
Reference in New Issue
Block a user