diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index c4faae618ad..208558dd89e 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -170,6 +170,7 @@ library Development.IDE.Core.UseStale Development.IDE.GHC.Compat Development.IDE.GHC.Compat.Core + Development.IDE.GHC.Compat.CmdLine Development.IDE.GHC.Compat.Env Development.IDE.GHC.Compat.Iface Development.IDE.GHC.Compat.Logger diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 4f0dc3bbb55..6e5378122b7 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -39,9 +39,12 @@ import Data.Either.Extra import Data.Function import Data.Hashable hiding (hash) import qualified Data.HashMap.Strict as HM +import Data.IORef +import qualified Data.Set as OS import Data.List import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List as L import qualified Data.Map.Strict as Map import Data.Maybe import Data.Proxy @@ -63,7 +66,7 @@ import Development.IDE.Graph (Action) import Development.IDE.Session.VersionCheck import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, +import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, envImportPaths, newHscEnvEqPreserveImportPaths) import Development.IDE.Types.Location import Development.IDE.Types.Options @@ -110,12 +113,28 @@ import HieDb.Utils import qualified System.Random as Random import System.Random (RandomGen) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,4,0) -import Data.IORef +import Development.IDE.GHC.Compat.CmdLine + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Errors.Types +import GHC.Driver.Env (hscSetActiveUnitId, hsc_all_home_unit_ids) +import GHC.Driver.Make (checkHomeUnitsClosed) +import GHC.Unit.State +import GHC.Unit.Env +import GHC.Types.Error (errMsgDiagnostic) +import GHC.Data.Bag #endif +import GHC.ResponseFile +import qualified Data.List.NonEmpty as NE +import GHC.Unit.Env +import GHC.Unit.Home +import GHC.Unit.Home.ModInfo + +import GHC.Utils.Trace + data Log = LogSettingInitialDynFlags | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) @@ -483,29 +502,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- combined with the components in the old HscEnv into a new HscEnv -- which contains the union. let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (HscEnv, ComponentInfo, [ComponentInfo]) + -> IO ([ComponentInfo], [ComponentInfo]) packageSetup (hieYaml, cfp, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir - (df', targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv) - let df = -#if MIN_VERSION_ghc(9,3,0) - case unitIdString (homeUnitId_ df') of - -- cabal uses main for the unit id of all executable packages - -- This makes multi-component sessions confused about what - -- options to use for that component. - -- Solution: hash the options and use that as part of the unit id - -- This works because there won't be any dependencies on the - -- executable unit. - "main" -> - let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack $ componentOptions opts) - hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) - in setHomeUnitId_ hashed_uid df' - _ -> df' -#else - df' -#endif - + newTargetDfs <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv) let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv @@ -520,13 +521,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- We will modify the unitId and DynFlags used for -- compilation but these are the true source of -- information. - - new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info - :| maybe [] snd oldDeps + new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newTargetDfs + all_deps = new_deps `appendList` maybe [] id oldDeps -- Get all the unit-ids for things in this component - inplace = map rawComponentUnitId $ NE.toList new_deps + inplace = map rawComponentUnitId $ NE.toList all_deps - new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do + all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do -- Remove all inplace dependencies from package flags for -- components in this HscEnv #if MIN_VERSION_ghc(9,3,0) @@ -550,22 +550,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do rawComponentFP rawComponentCOptions rawComponentDependencyInfo - -- Make a new HscEnv, we have to recompile everything from - -- scratch again (for now) - -- It's important to keep the same NameCache though for reasons - -- that I do not fully understand - logWith recorder Info $ LogMakingNewHscEnv inplace - hscEnvB <- emptyHscEnv ideNc libDir - !newHscEnv <- - -- Add the options for the current component to the HscEnv - evalGhcEnv hscEnvB $ do - _ <- 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 -- HscEnv -- Returns @@ -574,49 +558,29 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- . The information for the new component which caused this cache miss -- . The modified information (without -inplace flags) for -- existing packages - pure (Map.insert hieYaml (newHscEnv, NE.toList new_deps) m, (newHscEnv, NE.head new_deps', NE.tail new_deps')) + let (new,old) = NE.splitAt (NE.length new_deps) all_deps' + pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> IO (IdeResult HscEnvEq,[FilePath]) session args@(hieYaml, _cfp, _opts, _libDir) = do - (hscEnv, new, old_deps) <- packageSetup args - - -- Whenever we spin up a session on Linux, dynamically load libm.so.6 - -- in. We need this in case the binary is statically linked, in which - -- case the interactive session will fail when trying to load - -- ghc-prim, which happens whenever Template Haskell is being - -- evaluated or haskell-language-server's eval plugin tries to run - -- some code. If the binary is dynamically linked, then this will have - -- no effect. - -- See https://github.com/haskell/haskell-language-server/issues/221 - when (os == "linux") $ do - initObjLinker hscEnv - res <- loadDLL hscEnv "libm.so.6" - case res of - Nothing -> pure () - Just err -> logWith recorder Error $ LogDLLLoadError err - - - -- Make a map from unit-id to DynFlags, this is used when trying to - -- resolve imports. (especially PackageImports) - let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps) + (new_deps, old_deps) <- packageSetup args -- For each component, now make a new HscEnvEq which contains the -- HscEnv for the hie.yaml file but the DynFlags for that component + -- 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 - -- New HscEnv for the component in question, returns the new HscEnvEq and - -- a mapping from FilePath to the newly created HscEnvEq. - let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv uids - (cs, res) <- new_cache new - -- Modified cache targets for everything else in the hie.yaml file - -- which now uses the same EPS and so on - cached_targets <- concatMapM (fmap fst . new_cache) old_deps + let all_targets = concatMap fst all_target_details - let all_targets = cs ++ cached_targets + let this_flags_map = HM.fromList (concatMap toFlagsMap all_targets) void $ modifyVar' fileToFlags $ - Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets)) + Map.insert hieYaml this_flags_map void $ modifyVar' filesMap $ flip HM.union (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml))) @@ -630,8 +594,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- Typecheck all files in the project on startup checkProject <- getCheckProject - unless (null cs || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs) + unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do mmt <- uses GetModificationTime cfps' let cs_exist = catMaybes (zipWith (<$) cfps' mmt) @@ -641,7 +605,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - return (second Map.keys res) + return $ second Map.keys $ this_flags_map HM.! _cfp let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do @@ -707,7 +671,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- again. modifyVar_ fileToFlags (const (return Map.empty)) -- Keep the same name cache - modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml ) + modifyVar_ hscEnvs (return . Map.adjust (\_ -> []) hieYaml ) consultCradle hieYaml cfp else return (opts, Map.keys old_di) Nothing -> consultCradle hieYaml cfp @@ -767,7 +731,7 @@ emptyHscEnv :: NameCache -> FilePath -> IO HscEnv emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv #endif emptyHscEnv nc libDir = do - env <- runGhc (Just libDir) getSession + env <- runGhc (Just libDir) $ getSessionDynFlags >>= setSessionDynFlags >> getSession pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) data TargetDetails = TargetDetails @@ -810,6 +774,15 @@ setNameCache :: IORef NameCache -> HscEnv -> HscEnv #endif setNameCache nc hsc = hsc { hsc_NC = nc } +pprHomeUnitGraph :: HomeUnitGraph -> Compat.SDoc +pprHomeUnitGraph unitEnv = Compat.vcat (map (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv) + +pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> Compat.SDoc +pprHomeUnitEnv uid env = + Compat.ppr uid Compat.<+> Compat.text "(flags:" Compat.<+> Compat.ppr (homeUnitId_ $ homeUnitEnv_dflags env) Compat.<+> Compat.text "," Compat.<+> Compat.ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) Compat.<+> Compat.text ")" Compat.<+> Compat.text "->" + Compat.$$ Compat.nest 4 (pprHPT $ homeUnitEnv_hpt env) + + -- | Create a mapping from FilePaths to HscEnvEqs newComponentCache :: Recorder (WithPriority Log) @@ -817,49 +790,116 @@ newComponentCache -> Maybe FilePath -- Path to cradle -> NormalizedFilePath -- Path to file that caused the creation of this component -> HscEnv - -> [(UnitId, DynFlags)] - -> ComponentInfo - -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) -newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do - let df = componentDynFlags ci - hscEnv' <- + -> [ComponentInfo] + -> [ComponentInfo] + -> IO [ ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))] +newComponentCache recorder exts cradlePath cfp hsc_env old_cis new_cis = do + let cis = Map.union (mkMap new_cis) (mkMap old_cis) -- Left biased so prefer new components over old ones + mkMap = Map.fromList . map (\ci -> (componentUnitId ci, ci)) + let dfs = map componentDynFlags $ Map.elems cis + uids = Map.keys cis + pprTraceM "newComponentCache" $ Compat.ppr uids + hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4 + Compat.initUnits dfs hsc_env + +#if MIN_VERSION_ghc(9,3,0) + let closure_errs = checkHomeUnitsClosed (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') pkg_deps + pkg_deps = do + home_unit_id <- uids + home_unit_env <- maybeToList $ unitEnv_lookup_maybe home_unit_id $ hsc_HUG hscEnv' + map (home_unit_id,) (map (Compat.toUnitId . fst) $ explicitUnits $ homeUnitEnv_units home_unit_env) + + case closure_errs of + errs@(_:_) -> do + let rendered = map (ideErrorWithSource (Just "cradle") (Just DsError) cfp . T.pack . Compat.printWithoutUniques) errs + res = (rendered,Nothing) + dep_info = foldMap componentDependencyInfo (filter isBad $ Map.elems cis) + bad_units = OS.fromList $ concat $ do + x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages errs + DriverHomePackagesNotClosed us <- pure x + pure us + isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units + return [([TargetDetails (TargetFile cfp) res dep_info [cfp]],(res,dep_info))] + [] -> do +#else + do +#endif + -- Whenever we spin up a session on Linux, dynamically load libm.so.6 + -- in. We need this in case the binary is statically linked, in which + -- case the interactive session will fail when trying to load + -- ghc-prim, which happens whenever Template Haskell is being + -- evaluated or haskell-language-server's eval plugin tries to run + -- some code. If the binary is dynamically linked, then this will have + -- no effect. + -- See https://github.com/haskell/haskell-language-server/issues/221 + when (os == "linux") $ do + initObjLinker hscEnv' + res <- loadDLL hscEnv' "libm.so.6" + case res of + Nothing -> pure () + + fmap (addSpecial cfp) $ forM (Map.elems cis) $ \ci -> do + let df = componentDynFlags ci + let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath + thisEnv <- do #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) + -- 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' #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, - -- which we need for any changes to the package flags in the dynflags - -- to be visible. - -- See #2693 - evalGhcEnv hsc_env $ do - _ <- setSessionDynFlags $ df - getSession + -- 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, + -- which we need for any changes to the package flags in the dynflags + -- to be visible. + -- See #2693 + 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 } } + -- 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 + henv <- newFunc thisEnv (zip uids dfs) + let targetEnv = ([], Just henv) + targetDepends = componentDependencyInfo ci + res = ( targetEnv, targetDepends) + logWith recorder Debug $ LogNewComponentCache res + evaluate $ liftRnf rwhnf $ componentTargets ci - let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath - henv <- newFunc hscEnv' uids - let targetEnv = ([], Just henv) - 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) + let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends + ctargets <- concatMapM mk (componentTargets ci) + return (ctargets, res) + where -- A special target for the file which caused this wonderful -- component to be created. In case the cradle doesn't list all the targets for -- the component, in which case things will be horribly broken anyway. -- Otherwise, we will immediately attempt to reload this module which -- causes an infinite loop and high CPU usage. - let special_target = TargetDetails (TargetFile cfp) targetEnv targetDepends [componentFP ci] - return (special_target:ctargets, res) + addSpecial cfp xs + | alreadyIncluded = xs + | otherwise = let (as,bs) = break inIncludePath xs + in case bs of + [] -> + -- There is no appropriate target to add the file to, so pick one randomly + case as of + [] -> [] + ((ctargets,res@(targetEnv, targetDepends)):xs) -> + let x = (TargetDetails (TargetFile cfp) targetEnv targetDepends [cfp] : ctargets, res) + in x:xs + -- There is a component which could have this file in its include path + -- pick one of these components + ((ctargets,res@(targetEnv, targetDepends)):bs) -> + let b = (TargetDetails (TargetFile cfp) targetEnv targetDepends [cfp] : ctargets, res) + in as ++ (b:bs) + where + alreadyIncluded = any (any (cfp ==) . concatMap targetLocations . fst) xs + inIncludePath (_,((_, Just env),_)) = any (isParent $ fromNormalizedFilePath cfp) $ maybe [] OS.toList $ envImportPaths env + where + isParent fp parent = any (equalFilePath parent) (map (foldr () "") $ inits $ splitPath fp) {- Note [Avoiding bad interface files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -926,7 +966,7 @@ setCacheDirs recorder CacheDirs{..} dflags = do -- See Note [Multi Cradle Dependency Info] type DependencyInfo = Map.Map FilePath (Maybe UTCTime) -type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo]) +type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo] -- | Maps a "hie.yaml" location to all its Target Filepaths and options. type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) -- | Maps a Filepath to its respective "hie.yaml" location. @@ -1032,31 +1072,71 @@ memoIO op = do return (Map.insert k res mp, res) Just res -> return (mp, res) +unit_flags :: [Flag (CmdLineP [String])] +unit_flags = [defFlag "unit" (SepArg addUnit)] + +addUnit :: String -> EwM (CmdLineP [String]) () +addUnit unit_str = liftEwM $ do + units <- getCmdLineState + putCmdLineState (unit_str : units) + -- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target]) +setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (NE.NonEmpty (DynFlags, [GHC.Target])) setOptions (ComponentOptions theOpts compRoot _) dflags = do - (dflags', targets') <- addCmdOpts theOpts dflags - let targets = makeTargetsAbsolute compRoot targets' - let dflags'' = - disableWarningsAsErrors $ - -- disabled, generated directly by ghcide instead - flip gopt_unset Opt_WriteInterface $ - -- disabled, generated directly by ghcide instead - -- also, it can confuse the interface stale check - dontWriteHieFiles $ - setIgnoreInterfacePragmas $ - setBytecodeLinkerOptions $ - disableOptimisation $ - Compat.setUpTypedHoles $ - makeDynFlagsAbsolute compRoot 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) + ((theOpts',errs,warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) + case NE.nonEmpty units of + Just us -> initMulti us + Nothing -> (NE.:| []) <$> initOne (map unLoc theOpts') + where + initMulti unitArgFiles = + forM unitArgFiles $ \f -> do + args <- liftIO $ expandResponse [f] + initOne args + initOne theOpts = do + (dflags', targets') <- addCmdOpts theOpts dflags + let dflags'' = +#if MIN_VERSION_ghc(9,3,0) + case unitIdString (homeUnitId_ df') of + -- cabal uses main for the unit id of all executable packages + -- This makes multi-component sessions confused about what + -- options to use for that component. + -- Solution: hash the options and use that as part of the unit id + -- This works because there won't be any dependencies on the + -- executable unit. + "main" -> + let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack $ componentOptions opts) + hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) + in setHomeUnitId_ hashed_uid dflags' + _ -> dflags' +#else + dflags' +#endif + + let targets = makeTargetsAbsolute root targets' -- TODO + root = case workingDirectory dflags'' of + Nothing -> compRoot + Just wdir -> compRoot wdir + let dflags''' = + disableWarningsAsErrors $ + -- disabled, generated directly by ghcide instead + flip gopt_unset Opt_WriteInterface $ + -- disabled, generated directly by ghcide instead + -- also, it can confuse the interface stale check + dontWriteHieFiles $ + setIgnoreInterfacePragmas $ + setBytecodeLinkerOptions $ + disableOptimisation $ + Compat.setUpTypedHoles $ + makeDynFlagsAbsolute compRoot + 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) setIgnoreInterfacePragmas :: DynFlags -> DynFlags setIgnoreInterfacePragmas df = diff --git a/ghcide/src/Development/IDE/GHC/Compat/CmdLine.hs b/ghcide/src/Development/IDE/GHC/Compat/CmdLine.hs new file mode 100644 index 00000000000..21f1b496306 --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/CmdLine.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +-- | Compat module Interface file relevant code. +module Development.IDE.GHC.Compat.CmdLine ( + processCmdLineP + , CmdLineP (..) + , getCmdLineState + , putCmdLineState + , Flag(..) + , OptKind(..) + , EwM + , defFlag + , liftEwM + ) where + +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Session (processCmdLineP, CmdLineP (..), getCmdLineState, putCmdLineState) +import GHC.Driver.CmdLine +#else + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Driver.CmdLine +#else +import CmdLineParser +#endif + +import Control.Monad.IO.Class +import Control.Monad.Trans.State +import GHC (Located, mkGeneralLocated) +import GHC.ResponseFile +import Control.Exception +#endif + +#if !MIN_VERSION_ghc(9,3,0) +-- | A helper to parse a set of flags from a list of command-line arguments, handling +-- response files. +processCmdLineP + :: forall s m. MonadIO m + => [Flag (CmdLineP s)] -- ^ valid flags to match against + -> s -- ^ current state + -> [Located String] -- ^ arguments to parse + -> m (([Located String], [Err], [Warn]), s) + -- ^ (leftovers, errors, warnings) +processCmdLineP activeFlags s0 args = + pure $ runCmdLine (processArgs activeFlags args) s0 + +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Env.hs b/ghcide/src/Development/IDE/GHC/Compat/Env.hs index c1bb5a6aab4..c4bbe33ecf3 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Env.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Env.hs @@ -52,6 +52,7 @@ module Development.IDE.GHC.Compat.Env ( setBackend, ghciBackend, Development.IDE.GHC.Compat.Env.platformDefaultBackend, + workingDirectory ) where import GHC (setInteractiveDynFlags) @@ -111,6 +112,11 @@ hsc_EPS :: HscEnv -> UnitEnv hsc_EPS = hsc_unit_env #endif +#if !MIN_VERSION_ghc(9,3,0) +workingDirectory :: a -> Maybe b +workingDirectory _ = Nothing +#endif + #if !MIN_VERSION_ghc(9,2,0) type UnitEnv = () newtype Logger = Logger { log_action :: LogAction } diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index cd890d855e3..3ae3c70317a 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Units.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs @@ -5,9 +5,7 @@ module Development.IDE.GHC.Compat.Units ( -- * UnitState UnitState, -#if MIN_VERSION_ghc(9,3,0) initUnits, -#endif oldInitUnits, unitState, getUnitName, @@ -160,8 +158,12 @@ initUnits unitDflags env = do , ue_eps = ue_eps (hsc_unit_env env) } pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env +#else +initUnits :: [DynFlags] -> HscEnv -> IO HscEnv +initUnits _df env = pure env -- Can't do anything here, oldInitUnits should already be called #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 diff --git a/ghcide/test/data/multi-unit/a-1.0.0-inplace b/ghcide/test/data/multi-unit/a-1.0.0-inplace new file mode 100644 index 00000000000..a54ea9bc4bb --- /dev/null +++ b/ghcide/test/data/multi-unit/a-1.0.0-inplace @@ -0,0 +1,18 @@ +-this-package-name +a +-working-dir +a +-fbuilding-cabal-package +-O0 +-i. +-this-unit-id +a-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package +base +-package +text +-XHaskell98 +A diff --git a/ghcide/test/data/multi-unit/a/A.hs b/ghcide/test/data/multi-unit/a/A.hs new file mode 100644 index 00000000000..9a7d7e33c91 --- /dev/null +++ b/ghcide/test/data/multi-unit/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Data.Text +foo = () diff --git a/ghcide/test/data/multi-unit/b-1.0.0-inplace b/ghcide/test/data/multi-unit/b-1.0.0-inplace new file mode 100644 index 00000000000..b08c50c1cea --- /dev/null +++ b/ghcide/test/data/multi-unit/b-1.0.0-inplace @@ -0,0 +1,19 @@ +-this-package-name +b +-working-dir +b +-fbuilding-cabal-package +-O0 +-i +-i. +-this-unit-id +b-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-id +a-1.0.0-inplace +-package +base +-XHaskell98 +B diff --git a/ghcide/test/data/multi-unit/b/B.hs b/ghcide/test/data/multi-unit/b/B.hs new file mode 100644 index 00000000000..2c6d4b28a22 --- /dev/null +++ b/ghcide/test/data/multi-unit/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import A +qux = foo diff --git a/ghcide/test/data/multi-unit/c-1.0.0-inplace b/ghcide/test/data/multi-unit/c-1.0.0-inplace new file mode 100644 index 00000000000..7201a40de4d --- /dev/null +++ b/ghcide/test/data/multi-unit/c-1.0.0-inplace @@ -0,0 +1,19 @@ +-this-package-name +c +-working-dir +c +-fbuilding-cabal-package +-O0 +-i +-i. +-this-unit-id +c-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-id +a-1.0.0-inplace +-package +base +-XHaskell98 +C diff --git a/ghcide/test/data/multi-unit/c/C.hs b/ghcide/test/data/multi-unit/c/C.hs new file mode 100644 index 00000000000..b75a7fc3c74 --- /dev/null +++ b/ghcide/test/data/multi-unit/c/C.hs @@ -0,0 +1,3 @@ +module C(module C) where +import A +cux = foo diff --git a/ghcide/test/data/multi-unit/cabal.project b/ghcide/test/data/multi-unit/cabal.project new file mode 100644 index 00000000000..96f52330c92 --- /dev/null +++ b/ghcide/test/data/multi-unit/cabal.project @@ -0,0 +1,2 @@ +packages: a b c +multi-repl: True diff --git a/ghcide/test/data/multi-unit/hie.yaml b/ghcide/test/data/multi-unit/hie.yaml new file mode 100644 index 00000000000..34858b5f641 --- /dev/null +++ b/ghcide/test/data/multi-unit/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: ["-unit" ,"@a-1.0.0-inplace" + ,"-unit" ,"@b-1.0.0-inplace" + ,"-unit" ,"@c-1.0.0-inplace" + ]