diff --git a/cabal.project b/cabal.project index 3299b5cd07..27bf98c9c5 100644 --- a/cabal.project +++ b/cabal.project @@ -35,7 +35,7 @@ packages: ./plugins/hls-refactor-plugin ./plugins/hls-overloaded-record-dot-plugin -index-state: 2023-11-13T12:07:58Z +index-state: 2023-11-14T11:26:13Z tests: True test-show-details: direct diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 8489c96f3d..f2e01ce39e 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -51,8 +51,7 @@ import Ide.Logger (Doc, Logger (Logger), Recorder (logger_), WithPriority (WithPriority), cmapWithPrio, - makeDefaultStderrRecorder, - toCologActionWithPrio) + makeDefaultStderrRecorder) import Ide.Plugin.Config (Config) import Ide.Types (IdePlugins (IdePlugins)) import Language.LSP.Protocol.Message (Method (Method_Initialize), @@ -83,8 +82,8 @@ main = do putStrLn "Tool versions found on the $PATH" putStrLn $ showProgramVersionOfInterest programsOfInterest putStrLn "Tool versions in your project" - cradle <- findProjectCradle' False - ghcVersion <- runExceptT $ getRuntimeGhcVersion' recorder cradle + cradle <- findProjectCradle' recorder False + ghcVersion <- runExceptT $ getRuntimeGhcVersion' cradle putStrLn $ showProgramVersion "ghc" $ mkVersion =<< eitherToMaybe ghcVersion VersionMode PrintVersion -> @@ -94,10 +93,10 @@ main = do putStrLn haskellLanguageServerNumericVersion BiosMode PrintCradleType -> - print =<< findProjectCradle + print =<< findProjectCradle recorder PrintLibDir -> do - cradle <- findProjectCradle' False - (CradleSuccess libdir) <- HieBios.getRuntimeGhcLibDir (toCologActionWithPrio (cmapWithPrio pretty recorder)) cradle + cradle <- findProjectCradle' recorder False + (CradleSuccess libdir) <- HieBios.getRuntimeGhcLibDir cradle putStr libdir _ -> launchHaskellLanguageServer recorder args >>= \case Right () -> pure () @@ -116,7 +115,7 @@ launchHaskellLanguageServer recorder parsedArgs = do d <- getCurrentDirectory -- search for the project cradle type - cradle <- findProjectCradle + cradle <- findProjectCradle recorder -- Get the root directory from the cradle setCurrentDirectory $ cradleRootDir cradle @@ -124,7 +123,7 @@ launchHaskellLanguageServer recorder parsedArgs = do case parsedArgs of Ghcide GhcideArguments{..} -> when argsProjectGhcVersion $ do - runExceptT (getRuntimeGhcVersion' recorder cradle) >>= \case + runExceptT (getRuntimeGhcVersion' cradle) >>= \case Right ghcVersion -> putStrLn ghcVersion >> exitSuccess Left err -> T.putStrLn (prettyError err NoShorten) >> exitFailure _ -> pure () @@ -147,7 +146,7 @@ launchHaskellLanguageServer recorder parsedArgs = do hPutStrLn stderr "Consulting the cradle to get project GHC version..." runExceptT $ do - ghcVersion <- getRuntimeGhcVersion' recorder cradle + ghcVersion <- getRuntimeGhcVersion' cradle liftIO $ hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion let @@ -172,10 +171,10 @@ launchHaskellLanguageServer recorder parsedArgs = do let cradleName = actionName (cradleOptsProg cradle) -- we need to be compatible with NoImplicitPrelude - ghcBinary <- liftIO (fmap trim <$> runGhcCmd (toCologActionWithPrio (cmapWithPrio pretty recorder)) ["-v0", "-package-env=-", "-ignore-dot-ghci", "-e", "Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"]) + ghcBinary <- liftIO (fmap trim <$> runGhcCmd ["-v0", "-package-env=-", "-ignore-dot-ghci", "-e", "Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"]) >>= cradleResult cradleName - libdir <- liftIO (HieBios.getRuntimeGhcLibDir (toCologActionWithPrio (cmapWithPrio pretty recorder)) cradle) + libdir <- liftIO (HieBios.getRuntimeGhcLibDir cradle) >>= cradleResult cradleName env <- Map.fromList <$> liftIO getEnvironment @@ -192,8 +191,8 @@ cradleResult cradleName CradleNone = throwE $ NoneCradleGhcVersion cradleName -- | Version of 'getRuntimeGhcVersion' that dies if we can't get it, and also -- checks to see if the tool is missing if it is one of -getRuntimeGhcVersion' :: Recorder (WithPriority (Doc ())) -> Cradle Void -> ExceptT WrapperSetupError IO String -getRuntimeGhcVersion' recorder cradle = do +getRuntimeGhcVersion' :: Cradle Void -> ExceptT WrapperSetupError IO String +getRuntimeGhcVersion' cradle = do let cradleName = actionName (cradleOptsProg cradle) -- See if the tool is installed @@ -204,7 +203,7 @@ getRuntimeGhcVersion' recorder cradle = do Direct -> checkToolExists "ghc" _ -> pure () - ghcVersionRes <- liftIO $ HieBios.getRuntimeGhcVersion (toCologActionWithPrio (cmapWithPrio pretty recorder)) cradle + ghcVersionRes <- liftIO $ HieBios.getRuntimeGhcVersion cradle cradleResult cradleName ghcVersionRes where @@ -214,11 +213,11 @@ getRuntimeGhcVersion' recorder cradle = do Just _ -> pure () Nothing -> throwE $ ToolRequirementMissing exe (actionName (cradleOptsProg cradle)) -findProjectCradle :: IO (Cradle Void) -findProjectCradle = findProjectCradle' True +findProjectCradle :: Recorder (WithPriority (Doc ())) -> IO (Cradle Void) +findProjectCradle recorder = findProjectCradle' recorder True -findProjectCradle' :: Bool -> IO (Cradle Void) -findProjectCradle' log = do +findProjectCradle' :: Recorder (WithPriority (Doc ())) -> Bool -> IO (Cradle Void) +findProjectCradle' recorder log = do d <- getCurrentDirectory let initialFp = d "a" @@ -230,7 +229,7 @@ findProjectCradle' log = do Just yaml -> hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ initialFp ++ "\"" Nothing -> hPutStrLn stderr "No 'hie.yaml' found. Try to discover the project type!" - Session.loadCradle def hieYaml d + Session.loadCradle def (cmapWithPrio pretty recorder) hieYaml d trim :: String -> String trim s = case lines s of diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 03cc575c78..c5b0308961 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -76,13 +76,12 @@ library , Glob , haddock-library >=1.8 && <1.12 , hashable - , hie-bios ==0.12.1 + , hie-bios ==0.13.1 , hie-compat ^>=0.3.0.0 , hiedb >=0.4.4 && <0.4.5 , hls-graph ==2.4.0.0 , hls-plugin-api ==2.4.0.0 - , implicit-hie <0.1.3 - , implicit-hie-cradle ^>=0.3.0.5 || ^>=0.5 + , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens , list-t , lsp ^>=2.3.0.0 @@ -111,10 +110,6 @@ library , unordered-containers >=0.2.10.0 , vector - -- implicit-hie 0.1.3.0 introduced an unexpected behavioral change. - -- https://github.com/Avi-D-coder/implicit-hie/issues/50 - -- to make sure ghcide behaves in a desirable way, we put implicit-hie - -- fake dependency here. if os(windows) build-depends: Win32 @@ -165,6 +160,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 @@ -197,6 +193,7 @@ library Development.IDE.Plugin.TypeLenses Development.IDE.Session Development.IDE.Session.Diagnostics + Development.IDE.Session.Implicit Development.IDE.Spans.AtPoint Development.IDE.Spans.Common Development.IDE.Spans.Documentation diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 9ae787a30e..42615de78a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -39,8 +39,10 @@ import Data.Either.Extra import Data.Function import Data.Hashable hiding (hash) import qualified Data.HashMap.Strict as HM +import Data.IORef import Data.List import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.Extra as L import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe @@ -72,7 +74,6 @@ import qualified HIE.Bios as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios -import Hie.Implicit.Cradle (loadImplicitHieCradle) import Ide.Logger (Pretty (pretty), Priority (Debug, Error, Info, Warning), Recorder, WithPriority, @@ -110,12 +111,25 @@ import HieDb.Utils import qualified System.Random as Random import System.Random (RandomGen) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +import qualified Development.IDE.Session.Implicit as GhcIde -#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 qualified Data.Set as OS + +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.Types.Error (errMsgDiagnostic) +import GHC.Data.Bag #endif +import GHC.ResponseFile + data Log = LogSettingInitialDynFlags | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) @@ -218,7 +232,7 @@ data SessionLoadingOptions = SessionLoadingOptions -- | Load the cradle with an optional 'hie.yaml' location. -- If a 'hie.yaml' is given, use it to load the cradle. -- Otherwise, use the provided project root directory to determine the cradle type. - , loadCradle :: Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void) + , loadCradle :: Recorder (WithPriority Log) -> Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void) -- | Given the project name and a set of command line flags, -- return the path for storing generated GHC artifacts, -- or 'Nothing' to respect the cradle setting @@ -255,22 +269,25 @@ instance Default SessionLoadingOptions where -- using the provided root directory for discovering the project. -- The implicit config uses different heuristics to determine the type -- of the project that may or may not be accurate. -loadWithImplicitCradle :: Maybe FilePath - -- ^ Optional 'hie.yaml' location. Will be used if given. - -> FilePath - -- ^ Root directory of the project. Required as a fallback - -- if no 'hie.yaml' location is given. - -> IO (HieBios.Cradle Void) -loadWithImplicitCradle mHieYaml rootDir = do +loadWithImplicitCradle + :: Recorder (WithPriority Log) + -> Maybe FilePath + -- ^ Optional 'hie.yaml' location. Will be used if given. + -> FilePath + -- ^ Root directory of the project. Required as a fallback + -- if no 'hie.yaml' location is given. + -> IO (HieBios.Cradle Void) +loadWithImplicitCradle recorder mHieYaml rootDir = do + let logger = toCologActionWithPrio (cmapWithPrio LogHieBios recorder) case mHieYaml of - Just yaml -> HieBios.loadCradle yaml - Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir + Just yaml -> HieBios.loadCradle logger yaml + Nothing -> GhcIde.loadImplicitCradle logger rootDir getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) getInitialGhcLibDirDefault recorder rootDir = do hieYaml <- findCradle def (rootDir "a") - cradle <- loadCradle def hieYaml rootDir - libDirRes <- getRuntimeGhcLibDir (toCologActionWithPrio (cmapWithPrio LogHieBios recorder)) cradle + cradle <- loadCradle def recorder hieYaml rootDir + libDirRes <- getRuntimeGhcLibDir cradle case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir CradleFail err -> do @@ -420,6 +437,7 @@ loadSession recorder = loadSessionWithOptions recorder def loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do + cradle_files <- newIORef [] -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv @@ -479,33 +497,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do logWith recorder Debug $ LogKnownFilesUpdated x -- Create a new HscEnv from a hieYaml root and a set of options - -- If the hieYaml file already has an HscEnv, the new component is - -- 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 cfp 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,19 +517,18 @@ 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 `NE.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) let (df2, uids) = (rawComponentDynFlags, []) #else - let (df2, uids) = _removeInplacePackages fakeUid inplace rawComponentDynFlags + let (df2, uids) = _removeInplacePackages fakeUid _inplace rawComponentDynFlags #endif let prefix = show rawComponentUnitId -- See Note [Avoiding bad interface files] @@ -543,80 +539,44 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- The final component information, mostly the same but the DynFlags don't -- contain any packages which are also loaded -- into the same component. - pure $ ComponentInfo rawComponentUnitId - processed_df - uids - rawComponentTargets - 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 + pure $ ComponentInfo + { componentUnitId = rawComponentUnitId + , componentDynFlags = processed_df + , componentInternalUnits = uids + , componentTargets = rawComponentTargets + , componentFP = rawComponentFP + , componentCOptions = rawComponentCOptions + , componentDependencyInfo = rawComponentDependencyInfo + } + -- Modify the map so the hieYaml now maps to the newly updated + -- ComponentInfos -- Returns - -- . the new HscEnv so it can be used to modify the - -- FilePath -> HscEnv map (fileToFlags) -- . 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 +590,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 +601,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 @@ -651,7 +611,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do when (isNothing hieYaml) $ logWith recorder Warning $ LogCradleNotFound lfpLog - cradle <- loadCradle hieYaml dir + cradle <- loadCradle recorder hieYaml dir -- TODO: Why are we repeating the same command we have on line 646? lfp <- flip makeRelative cfp <$> getCurrentDirectory @@ -664,7 +624,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfp - res <- cradleToOptsAndLibDir recorder cradle cfp + old_files <- readIORef cradle_files + res <- cradleToOptsAndLibDir recorder cradle cfp old_files addTag "result" (show res) return res @@ -679,7 +640,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do error $ "GHC installation not found in libdir: " <> libdir InstallationMismatch{..} -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) - InstallationChecked _compileTime _ghcLibCheck -> + InstallationChecked _compileTime _ghcLibCheck -> do + atomicModifyIORef' cradle_files (\xs -> (cfp:xs,())) session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) -- Failure case, either a cradle error or the none cradle Left err -> do @@ -707,7 +669,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 @@ -735,19 +697,18 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory -cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> Cradle Void -> FilePath +cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> Cradle Void -> FilePath -> [FilePath] -> IO (Either [CradleError] (ComponentOptions, FilePath)) -cradleToOptsAndLibDir recorder cradle file = do +cradleToOptsAndLibDir recorder cradle file old_files = do -- let noneCradleFoundMessage :: FilePath -> T.Text -- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file" -- Start off by getting the session options logWith recorder Debug $ LogCradle cradle - let logger = toCologActionWithPrio $ cmapWithPrio LogHieBios recorder - cradleRes <- HieBios.getCompilerOptions logger file cradle + cradleRes <- HieBios.getCompilerOptions file old_files cradle case cradleRes of CradleSuccess r -> do -- Now get the GHC lib dir - libDirRes <- getRuntimeGhcLibDir logger cradle + libDirRes <- getRuntimeGhcLibDir cradle case libDirRes of -- This is the successful path CradleSuccess libDir -> pure (Right (r, libDir)) @@ -767,8 +728,18 @@ emptyHscEnv :: NameCache -> FilePath -> IO HscEnv emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv #endif emptyHscEnv nc libDir = do - env <- runGhc (Just libDir) getSession + -- We call setSessionDynFlags so that the loader is initialised + -- 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) +#if !MIN_VERSION_ghc(9,3,0) + {hsc_unit_dbs = Nothing} +#endif data TargetDetails = TargetDetails { @@ -796,7 +767,10 @@ fromTargetId is exts (GHC.TargetModule modName) env dep = do -- For a 'TargetFile' we consider all the possible module names fromTargetId _ _ (GHC.TargetFile f _) env deps = do nf <- toNormalizedFilePath' <$> makeAbsolute f - return [TargetDetails (TargetFile nf) env deps [nf]] + let other + | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) + | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") + return [TargetDetails (TargetFile nf) env deps [nf, other]] toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] toFlagsMap TargetDetails{..} = @@ -811,52 +785,103 @@ setNameCache :: IORef NameCache -> HscEnv -> HscEnv setNameCache nc hsc = hsc { hsc_NC = nc } -- | Create a mapping from FilePaths to HscEnvEqs +-- This combines all the components we know about into +-- an appropriate session, which is a multi component +-- session on GHC 9.4+ 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 - -> [(UnitId, DynFlags)] - -> ComponentInfo - -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) -newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do - let df = componentDynFlags ci - hscEnv' <- + -> [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 + -> IO [ ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))] +newComponentCache recorder exts cradlePath _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. + -- However, we might have added some targets to the old unit + -- (see special target), so preserve those + unionCIs new_ci old_ci = new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci } + mkMap = Map.fromListWith unionCIs . map (\ci -> (componentUnitId ci, ci)) + let dfs = map componentDynFlags $ Map.elems cis + uids = Map.keys cis + logWith recorder Info $ LogMakingNewHscEnv 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) - -- Set up a multi component session with the other units on GHC 9.4 - Compat.initUnits (map snd uids) (hscSetFlags df hsc_env) + 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_err = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp . T.pack . Compat.printWithoutUniques) errs + res = (rendered_err,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 - -- 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 + 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 + -- We need to do this after the call to setSessionDynFlags initialises + -- the loader + when (os == "linux") $ do + initObjLinker hscEnv' + res <- loadDLL hscEnv' "libm.so.6" + case res of + Nothing -> pure () + Just err -> logWith recorder Error $ LogDLLLoadError err + + forM (Map.elems cis) $ \ci -> do + let df = componentDynFlags ci + let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath + thisEnv <- do +#if MIN_VERSION_ghc(9,3,0) + -- 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' +#else + -- 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 hscEnv' $ do + _ <- setSessionDynFlags df + getSession +#endif + henv <- createHscEnvEq 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 mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends + ctargets <- concatMapM mk (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) - - -- 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) + return (L.nubOrdOn targetTarget ctargets, res) {- Note [Avoiding bad interface files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -923,7 +948,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. @@ -956,13 +981,13 @@ data ComponentInfo = ComponentInfo -- | Internal units, such as local libraries, that this component -- is loaded with. These have been extracted from the original -- ComponentOptions. - , _componentInternalUnits :: [UnitId] + , componentInternalUnits :: [UnitId] -- | All targets of this components. , componentTargets :: [GHC.Target] -- | Filepath which caused the creation of this component , componentFP :: NormalizedFilePath -- | Component Options used to load the component. - , _componentCOptions :: ComponentOptions + , componentCOptions :: ComponentOptions -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file -- to last modification time. See Note [Multi Cradle Dependency Info] , componentDependencyInfo :: DependencyInfo @@ -1029,31 +1054,87 @@ 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 (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) +setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> m (NonEmpty (DynFlags, [GHC.Target])) +setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do + ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) + case NE.nonEmpty units of + Just us -> initMulti us + Nothing -> do + (df, targets) <- initOne (map unLoc theOpts') + -- 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. + -- + -- We don't do this when we have multiple components, because each + -- component better list all targets or there will be anarchy. + -- It is difficult to know which component to add our file to in + -- that case. + -- Multi unit arguments are likely to come from cabal, which + -- does list all targets. + abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp) + let special_target = Compat.mkSimpleTarget df abs_fp + pure $ (df, special_target : targets) :| [] + where + initMulti unitArgFiles = + forM unitArgFiles $ \f -> do + args <- liftIO $ expandResponse [f] + initOne args + initOne this_opts = do + (dflags', targets') <- addCmdOpts this_opts dflags + let dflags'' = +#if MIN_VERSION_ghc(9,3,0) + case unitIdString (homeUnitId_ dflags') 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 $ this_opts) + hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) + in setHomeUnitId_ hashed_uid dflags' + _ -> dflags' +#else + dflags' +#endif + + let targets = makeTargetsAbsolute root targets' + 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/session-loader/Development/IDE/Session/Implicit.hs b/ghcide/session-loader/Development/IDE/Session/Implicit.hs new file mode 100644 index 0000000000..d25b72276b --- /dev/null +++ b/ghcide/session-loader/Development/IDE/Session/Implicit.hs @@ -0,0 +1,133 @@ +module Development.IDE.Session.Implicit + ( loadImplicitCradle + ) where + + +import Control.Applicative ((<|>)) +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Control.Exception (handleJust) +import Data.Bifunctor +import Data.Maybe +import Data.Void +import System.FilePath +import System.Directory hiding (findFile) +import System.IO.Error + +import Colog.Core (LogAction (..), WithSeverity (..)) +import HIE.Bios.Cradle (getCradle, defaultCradle) +import HIE.Bios.Config +import HIE.Bios.Types hiding (ActionName(..)) + +import Hie.Locate +import Hie.Cabal.Parser +import qualified Hie.Yaml as Implicit + +loadImplicitCradle :: Show a => LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle a) +loadImplicitCradle l wfile = do + is_dir <- doesDirectoryExist wfile + let wdir | is_dir = wfile + | otherwise = takeDirectory wfile + cfg <- runMaybeT (implicitConfig wdir) + case cfg of + Just bc -> getCradle l absurd bc + Nothing -> return $ defaultCradle l wdir + +-- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies +implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath) +implicitConfig = (fmap . first) (CradleConfig noDeps) . inferCradleTree + where + noDeps :: [FilePath] + noDeps = [] + + +inferCradleTree :: FilePath -> MaybeT IO (CradleTree a, FilePath) +inferCradleTree start_dir = + maybeItsBios + -- If we have both a config file (cabal.project/stack.yaml) and a work dir + -- (dist-newstyle/.stack-work), prefer that + <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (cabalCradle dir)) + <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir) + -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal + <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) >>= pure . cabalCradle) + -- If we have a stack.yaml, use stack + <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle) + -- If we have a cabal file, use cabal + <|> (cabalExecutable >> cabalFileDir start_dir >>= pure . cabalCradle) + + where + maybeItsBios = (\wdir -> (Bios (Program $ wdir ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir + + cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir) + + stackCradle :: FilePath -> MaybeT IO (CradleTree a, FilePath) + stackCradle fp = do + pkgs <- stackYamlPkgs fp + pkgsWithComps <- liftIO $ catMaybes <$> mapM (nestedPkg fp) pkgs + let yaml = fp "stack.yaml" + pure $ (,fp) $ case pkgsWithComps of + [] -> Stack (StackType Nothing (Just yaml)) + ps -> StackMulti mempty $ do + Package n cs <- ps + c <- cs + let (prefix, comp) = Implicit.stackComponent n c + pure (prefix, StackType (Just comp) (Just yaml)) + cabalCradle fp = (Cabal $ CabalType Nothing Nothing, fp) + +cabalExecutable :: MaybeT IO FilePath +cabalExecutable = MaybeT $ findExecutable "cabal" + +stackExecutable :: MaybeT IO FilePath +stackExecutable = MaybeT $ findExecutable "stack" + +biosWorkDir :: FilePath -> MaybeT IO FilePath +biosWorkDir = findFileUpwards (".hie-bios" ==) + +cabalWorkDir :: FilePath -> MaybeT IO () +cabalWorkDir wdir = do + check <- liftIO $ doesDirectoryExist (wdir "dist-newstyle") + unless check $ fail "No dist-newstyle" + +stackWorkDir :: FilePath -> MaybeT IO () +stackWorkDir wdir = do + check <- liftIO $ doesDirectoryExist (wdir ".stack-work") + unless check $ fail "No .stack-work" + +cabalConfigDir :: FilePath -> MaybeT IO FilePath +cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local") + +cabalFileDir :: FilePath -> MaybeT IO FilePath +cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal") + +stackConfigDir :: FilePath -> MaybeT IO FilePath +stackConfigDir = findFileUpwards isStack + where + isStack name = name == "stack.yaml" + +-- | Searches upwards for the first directory containing a file to match +-- the predicate. +findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath +findFileUpwards p dir = do + cnts <- + liftIO + $ handleJust + -- Catch permission errors + (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing) + pure + (findFile p dir) + + case cnts of + [] | dir' == dir -> fail "No cabal files" + | otherwise -> findFileUpwards p dir' + _ : _ -> return dir + where dir' = takeDirectory dir + +-- | Sees if any file in the directory matches the predicate +findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +findFile p dir = do + b <- doesDirectoryExist dir + if b then getFiles >>= filterM doesPredFileExist else return [] + where + getFiles = filter p <$> getDirectoryContents dir + doesPredFileExist file = doesFileExist $ dir file 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 0000000000..62e57e2b3c --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/CmdLine.hs @@ -0,0 +1,38 @@ +{-# 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 +import GHC.Driver.CmdLine +import Control.Monad.IO.Class +import GHC (Located) +#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/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 767d23ef35..bb57f602b7 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -262,6 +262,7 @@ module Development.IDE.GHC.Compat.Core ( -- * Driver-Make Target(..), TargetId(..), + mkSimpleTarget, mkModuleGraph, -- * GHCi initObjLinker, @@ -805,3 +806,10 @@ homeModInfoObject = hm_linkable field_label :: a -> a field_label = id #endif + +mkSimpleTarget :: DynFlags -> FilePath -> Target +#if MIN_VERSION_ghc(9,3,0) +mkSimpleTarget df fp = Target (TargetFile fp Nothing) True (homeUnitId_ df) Nothing +#else +mkSimpleTarget _ fp = Target (TargetFile fp Nothing) True Nothing +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Env.hs b/ghcide/src/Development/IDE/GHC/Compat/Env.hs index b7b268b5b0..66d135737c 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Env.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Env.hs @@ -19,6 +19,9 @@ module Development.IDE.GHC.Compat.Env ( Env.hsc_logger, Env.hsc_tmpfs, Env.hsc_unit_env, +#if !MIN_VERSION_ghc(9,3,0) + Env.hsc_unit_dbs, +#endif Env.hsc_hooks, hscSetHooks, TmpFs, @@ -52,6 +55,7 @@ module Development.IDE.GHC.Compat.Env ( setBackend, ghciBackend, Development.IDE.GHC.Compat.Env.platformDefaultBackend, + workingDirectory ) where import GHC (setInteractiveDynFlags) @@ -84,6 +88,10 @@ hsc_EPS :: HscEnv -> UnitEnv hsc_EPS = Env.hsc_unit_env #endif +#if !MIN_VERSION_ghc(9,3,0) +workingDirectory :: a -> Maybe b +workingDirectory _ = Nothing +#endif setHomeUnitId_ :: UnitId -> DynFlags -> DynFlags setHomeUnitId_ uid df = df { Session.homeUnitId_ = uid } diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index 2082cf10d0..2af02273f9 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, @@ -144,8 +142,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/src/Development/IDE/Types/KnownTargets.hs b/ghcide/src/Development/IDE/Types/KnownTargets.hs index 7f49ced08d..5e14816c7f 100644 --- a/ghcide/src/Development/IDE/Types/KnownTargets.hs +++ b/ghcide/src/Development/IDE/Types/KnownTargets.hs @@ -17,7 +17,7 @@ import GHC.Generics type KnownTargets = HashMap Target (HashSet NormalizedFilePath) data Target = TargetModule ModuleName | TargetFile NormalizedFilePath - deriving ( Eq, Generic, Show ) + deriving ( Eq, Ord, Generic, Show ) deriving anyclass (Hashable, NFData) toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath 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 0000000000..a54ea9bc4b --- /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 0000000000..9a7d7e33c9 --- /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 0000000000..b08c50c1ce --- /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 0000000000..2c6d4b28a2 --- /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 0000000000..7201a40de4 --- /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 0000000000..b75a7fc3c7 --- /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 0000000000..96f52330c9 --- /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 0000000000..34858b5f64 --- /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" + ] diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs index 167860833b..9274e807c9 100644 --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -40,7 +40,9 @@ tests = testGroup "cradle" [testGroup "dependencies" [sessionDepsArePickedUp] ,testGroup "ignore-fatal" [ignoreFatalWarning] ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] - ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest] + ,testGroup "multi" (multiTests "multi") + ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2" + $ testGroup "multi-unit" (multiTests "multi-unit") ,testGroup "sub-directory" [simpleSubDirectoryTest] ] @@ -113,8 +115,15 @@ simpleSubDirectoryTest = ] expectNoMoreDiagnostics 0.5 -simpleMultiTest :: TestTree -simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do +multiTests :: FilePath -> [TestTree] +multiTests dir = + [simpleMultiTest dir, simpleMultiTest2 dir, simpleMultiTest3 dir, simpleMultiDefTest dir] + +multiTestName :: FilePath -> String -> String +multiTestName dir name = "simple-" ++ dir ++ "-" ++ name + +simpleMultiTest :: FilePath -> TestTree +simpleMultiTest variant = testCase (multiTestName variant "test") $ withLongTimeout $ runWithExtraFiles variant $ \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" adoc <- openDoc aPath "haskell" @@ -129,8 +138,8 @@ simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraF expectNoMoreDiagnostics 0.5 -- Like simpleMultiTest but open the files in the other order -simpleMultiTest2 :: TestTree -simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do +simpleMultiTest2 :: FilePath -> TestTree +simpleMultiTest2 variant = testCase (multiTestName variant "test2") $ runWithExtraFiles variant $ \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" bdoc <- openDoc bPath "haskell" @@ -143,9 +152,9 @@ simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \ expectNoMoreDiagnostics 0.5 -- Now with 3 components -simpleMultiTest3 :: TestTree -simpleMultiTest3 = - testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do +simpleMultiTest3 :: FilePath -> TestTree +simpleMultiTest3 variant = + testCase (multiTestName variant "test3") $ runWithExtraFiles variant $ \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" cPath = dir "c/C.hs" @@ -161,8 +170,8 @@ simpleMultiTest3 = expectNoMoreDiagnostics 0.5 -- Like simpleMultiTest but open the files in component 'a' in a separate session -simpleMultiDefTest :: TestTree -simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do +simpleMultiDefTest :: FilePath -> TestTree +simpleMultiDefTest variant = testCase (multiTestName variant "def-test") $ runWithExtraFiles variant $ \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" adoc <- liftIO $ runInDir dir $ do diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/hie.yaml b/plugins/hls-call-hierarchy-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..1909df7d79 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["A", "B", "C"]}} diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 356c2079f7..de83ff8bf1 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -116,7 +116,8 @@ import Ide.Plugin.Eval.Config (EvalConfig (..), import Ide.Plugin.Eval.GHC (addImport, addPackages, hasPackage, - showDynFlags) + showDynFlags, + setSessionAndInteractiveDynFlags) import Ide.Plugin.Eval.Parse.Comments (commentsToSections) import Ide.Plugin.Eval.Parse.Option (parseSetFlags) import Ide.Plugin.Eval.Rules (queueForEvaluation, @@ -465,9 +466,7 @@ evals mark_exception (st, fp) df stmts = do <> T.pack (intercalate ", " $ map SrcLoc.unLoc ignoreds) ] dbg "post set" $ showDynFlags df' - _ <- setSessionDynFlags df' - sessDyns <- getSessionDynFlags - setInteractiveDynFlags sessDyns + setSessionAndInteractiveDynFlags df' pure $ warnings <> igns | -- A type/kind command Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt = @@ -689,4 +688,3 @@ parseGhciLikeCmd :: Text -> Maybe (Text, Text) parseGhciLikeCmd input = do (':', rest) <- T.uncons $ T.stripStart input pure $ second T.strip $ T.break isSpace rest - diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs index 68ea0a4050..19e9a403bc 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -11,6 +12,7 @@ module Ide.Plugin.Eval.GHC ( addPackages, modifyFlags, showDynFlags, + setSessionAndInteractiveDynFlags, ) where import Data.List (isPrefixOf) @@ -25,6 +27,12 @@ import Development.IDE.GHC.Util (printOutputable) import GHC.LanguageExtensions.Type (Extension (..)) import Ide.Plugin.Eval.Util (gStrictTry) +#if MIN_VERSION_ghc(9,3,0) +import GHC (setUnitDynFlags, setTopSessionDynFlags) +import GHC.Driver.Session (getDynFlags) +import GHC.Driver.Env +#endif + {- $setup >>> import GHC >>> import GHC.Paths @@ -164,3 +172,16 @@ showDynFlags df = vList :: [String] -> SDoc vList = vcat . map text + +setSessionAndInteractiveDynFlags :: DynFlags -> Ghc () +setSessionAndInteractiveDynFlags df = do +#if MIN_VERSION_ghc(9,3,0) + _ <- setUnitDynFlags (homeUnitId_ df) df + modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ df)) + df' <- getDynFlags + setTopSessionDynFlags df' +#else + _ <- setSessionDynFlags df +#endif + sessDyns <- getSessionDynFlags + setInteractiveDynFlags sessDyns diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/hie.yaml b/plugins/hls-explicit-record-fields-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..ee67c73150 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: []}} diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/hie.yaml b/plugins/hls-overloaded-record-dot-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..ee67c73150 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: []}} diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 726eebc524..4547de5b73 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -46,6 +46,7 @@ data Log | LogLspStart !GhcideArguments ![PluginId] | LogIDEMain IDEMain.Log | LogHieBios HieBios.Log + | LogSession Session.Log | LogOther T.Text deriving Show @@ -61,6 +62,7 @@ instance Pretty Log where , "PluginIds:" <+> pretty (coerce @_ @[Text] pluginIds) ] LogIDEMain iDEMainLog -> pretty iDEMainLog LogHieBios hieBiosLog -> pretty hieBiosLog + LogSession sessionLog -> pretty sessionLog LogOther t -> pretty t defaultMain :: Recorder (WithPriority Log) -> Arguments -> IdePlugins IdeState -> IO () @@ -91,7 +93,7 @@ defaultMain recorder args idePlugins = do BiosMode PrintCradleType -> do dir <- IO.getCurrentDirectory hieYaml <- Session.findCradle def (dir "a") - cradle <- Session.loadCradle def hieYaml dir + cradle <- Session.loadCradle def (cmapWithPrio LogSession recorder) hieYaml dir print cradle Ghcide ghcideArgs -> do @@ -107,8 +109,8 @@ defaultMain recorder args idePlugins = do d <- getCurrentDirectory let initialFp = d "a" hieYaml <- Session.findCradle def initialFp - cradle <- Session.loadCradle def hieYaml d - (CradleSuccess libdir) <- HieBios.getRuntimeGhcLibDir (toCologActionWithPrio (cmapWithPrio LogHieBios recorder)) cradle + cradle <- Session.loadCradle def (cmapWithPrio LogSession recorder) hieYaml d + (CradleSuccess libdir) <- HieBios.getRuntimeGhcLibDir cradle putStr libdir where encodePrettySorted = A.encodePretty' A.defConfig diff --git a/stack-lts21.yaml b/stack-lts21.yaml index 74f5b8c4dc..2920b0e807 100644 --- a/stack-lts21.yaml +++ b/stack-lts21.yaml @@ -45,9 +45,8 @@ allow-newer: true extra-deps: - floskell-0.10.7 - hiedb-0.4.4.0 -- hie-bios-0.12.1 -- implicit-hie-0.1.2.7 -- implicit-hie-cradle-0.5.0.1 +- hie-bios-0.13.1 +- implicit-hie-0.1.4.0 - monad-dijkstra-0.1.1.3 - algebraic-graphs-0.6.1 - retrie-1.2.2 diff --git a/stack.yaml b/stack.yaml index 5c5703a168..504971dca4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -45,9 +45,8 @@ extra-deps: - Cabal-syntax-3.10.1.0@sha256:bb835ebab577fd0f9c11dab96210dbb8d68ffc62652576f4b092563c345930e7,7434 # - floskell-0.10.7 - hiedb-0.4.4.0 -- hie-bios-0.12.1 -- implicit-hie-0.1.2.7 -- implicit-hie-cradle-0.5.0.1 +- hie-bios-0.13.1 +- implicit-hie-0.1.4.0 - algebraic-graphs-0.6.1 - retrie-1.2.2 - hw-fingertree-0.1.2.1 diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs index e6242ba9c1..b9e604638f 100644 --- a/test/functional/FunctionalBadProject.hs +++ b/test/functional/FunctionalBadProject.hs @@ -24,5 +24,5 @@ tests = testGroup "behaviour on malformed projects" liftIO $ assertBool "missing module name" $ "Other" `T.isInfixOf` (diag ^. L.message) liftIO $ assertBool "hie-bios message" $ - "Cabal {component = Just \"exe:testExe\"}" `T.isInfixOf` (diag ^. L.message) + "Cabal" `T.isInfixOf` (diag ^. L.message) ]