From 7db6215c6da39b6550d7c1ce6ea5b1bbe6e6dfde Mon Sep 17 00:00:00 2001 From: wz1000 Date: Wed, 22 Nov 2023 16:08:04 -0800 Subject: [PATCH] Add support for multi unit argument syntax (#3462) * Add support for the multi unit argument syntax introduced in GHC 9.4: https://downloads.haskell.org/ghc/9.4.4/docs/users_guide/using.html#multiple-home-units We now support arguments of the form ``` -unit @unitA -unit @unitB ``` where the response files `unitA` and `unitB` contain the actual list of arguments for that unit: ``` -this-unit-id a-0.1.0.0 -i -isrc A1 A2 ``` Also refactor the session loader and simplify it. Also adds error messages on GHC 9.4 if the units are not closed (#3422). fixes Fix closure check session-loader: override old units with new in multi-unit support Remove implicit-hie session-loader: remember which files caused old components to be loaded, and also pass them on to hie-bios so it can in turn pass them to `cabal repl` when loading newer components. This allows us to create valid set of build flags encompassing both the old and new components, and the closure of all components in between. The observation is that if you want to load some components X, Y, Z and so on, cabal repl X Y Z ... will be more likely to give you a valid multi component build plan/flags than cabal repl all, or any way of combining the results of cabal repl X, cabal repl Y ... Use new hie-bios Move implicit cradles to HLS Fix build on 9.0 Werror Improve handling of specialTarget * hie-bios doesn't mention the component name in the message anymore * stack fixes * wrapper: remove unused argument * werror * werror * Implicit cradle: match implicit-hie-cradle logic * Fix eval plugin * ignore multi unit tests on 9.2 * Some fixes for 9.2 * Add hie.yaml for call-hierarchy-plugin tests * Add hie.yaml for explicit-record-fields-plugin * Add hie.yaml for hls-overloaded-record-dot-plugin --- cabal.project | 2 +- exe/Wrapper.hs | 39 +- ghcide/ghcide.cabal | 11 +- .../session-loader/Development/IDE/Session.hs | 449 +++++++++++------- .../Development/IDE/Session/Implicit.hs | 133 ++++++ .../src/Development/IDE/GHC/Compat/CmdLine.hs | 38 ++ ghcide/src/Development/IDE/GHC/Compat/Core.hs | 8 + ghcide/src/Development/IDE/GHC/Compat/Env.hs | 8 + .../src/Development/IDE/GHC/Compat/Units.hs | 6 +- .../src/Development/IDE/Types/KnownTargets.hs | 2 +- ghcide/test/data/multi-unit/a-1.0.0-inplace | 18 + ghcide/test/data/multi-unit/a/A.hs | 3 + ghcide/test/data/multi-unit/b-1.0.0-inplace | 19 + ghcide/test/data/multi-unit/b/B.hs | 3 + ghcide/test/data/multi-unit/c-1.0.0-inplace | 19 + ghcide/test/data/multi-unit/c/C.hs | 3 + ghcide/test/data/multi-unit/cabal.project | 2 + ghcide/test/data/multi-unit/hie.yaml | 6 + ghcide/test/exe/CradleTests.hs | 29 +- .../test/testdata/hie.yaml | 1 + .../src/Ide/Plugin/Eval/CodeLens.hs | 8 +- .../src/Ide/Plugin/Eval/GHC.hs | 21 + .../test/testdata/hie.yaml | 1 + .../test/testdata/hie.yaml | 1 + src/Ide/Main.hs | 8 +- stack-lts21.yaml | 5 +- stack.yaml | 5 +- test/functional/FunctionalBadProject.hs | 2 +- 28 files changed, 610 insertions(+), 240 deletions(-) create mode 100644 ghcide/session-loader/Development/IDE/Session/Implicit.hs create mode 100644 ghcide/src/Development/IDE/GHC/Compat/CmdLine.hs create mode 100644 ghcide/test/data/multi-unit/a-1.0.0-inplace create mode 100644 ghcide/test/data/multi-unit/a/A.hs create mode 100644 ghcide/test/data/multi-unit/b-1.0.0-inplace create mode 100644 ghcide/test/data/multi-unit/b/B.hs create mode 100644 ghcide/test/data/multi-unit/c-1.0.0-inplace create mode 100644 ghcide/test/data/multi-unit/c/C.hs create mode 100644 ghcide/test/data/multi-unit/cabal.project create mode 100644 ghcide/test/data/multi-unit/hie.yaml create mode 100644 plugins/hls-call-hierarchy-plugin/test/testdata/hie.yaml create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/hie.yaml create mode 100644 plugins/hls-overloaded-record-dot-plugin/test/testdata/hie.yaml 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) ]