diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # ChangeLog hie-bios +## 2026-02-06 - 0.18.0 + +* Adapt to OsPath change ([#493](https://github.com/haskell/hie-bios/pull/493)) +* Parallel test suite ([#487](https://github.com/haskell/hie-bios/pull/487)) +* Fix processCabalLoadStyle to include dyn dep for extra files ([#484](https://github.com/haskell/hie-bios/pull/484)) +* Improve hie-bios cli interface ([#480](https://github.com/haskell/hie-bios/pull/480)) +* Only pass --keep-temp-files once ([#477](https://github.com/haskell/hie-bios/pull/477)) + ## 2025-08-07 - 0.17.0 * Add support for cabal 3.16.1.0 [#470](https://github.com/haskell/hie-bios/pull/470) diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -8,7 +8,7 @@ import Data.Version (showVersion) import Prettyprinter import Options.Applicative -import System.Directory (getCurrentDirectory) +import System.Directory (getCurrentDirectory, makeAbsolute) import System.IO (stdout, hSetEncoding, utf8) import System.FilePath( () ) @@ -16,46 +16,69 @@ import HIE.Bios.Ghc.Check import HIE.Bios.Ghc.Gap as Gap import HIE.Bios.Internal.Debug -import HIE.Bios.Types (LoadStyle(LoadFile)) +import HIE.Bios.Types (LoadStyle(..)) import Paths_hie_bios +import Data.Void (Void) +import Data.Function ---------------------------------------------------------------- progVersion :: String progVersion = "hie-bios version " ++ showVersion version ++ " compiled by GHC " ++ Gap.ghcVersion ++ "\n" +data UseLoadStyle + = UseSingleFile + | UseMultiFile + +data Cli = Cli + { logLevel :: Maybe L.Severity + , biosCommand :: Command + } + data Command = Check { checkTargetFiles :: [FilePath] } | Flags { flagTargetFiles :: [FilePath] } - | Debug { debugComponents :: FilePath } + | Debug { debugUseMultiLoadStyle :: UseLoadStyle, debugComponents :: [FilePath] } | ConfigInfo { configFiles :: [FilePath] } | CradleInfo { cradleFiles :: [FilePath] } | Root | Version -filepathParser :: Parser [FilePath] -filepathParser = some (argument str ( metavar "TARGET_FILES...")) +filepathParser :: Parser FilePath +filepathParser = argument str ( metavar "TARGET_FILES...") -progInfo :: ParserInfo Command -progInfo = info (progParser <**> helper) +progInfo :: ParserInfo Cli +progInfo = info (cliParser <**> helper) ( fullDesc <> progDesc "hie-bios is the way to specify how haskell-language-server and ghcide set up a GHC API session.\ \Delivers the full set of flags to pass to GHC in order to build the project." <> header progVersion <> footer "You can report issues/contribute at https://github.com/mpickering/hie-bios") +cliParser :: Parser Cli +cliParser = Cli + <$> optional sevParser + <*> progParser + +sevParser :: Parser L.Severity +sevParser = + flag' L.Debug (short 'v') + progParser :: Parser Command -progParser = subparser - (command "check" (info (Check <$> filepathParser) (progDesc "Try to load modules into the GHC API.")) - <> command "flags" (info (Flags <$> filepathParser) (progDesc "Print out the options that hie-bios thinks you will need to load a file.")) - <> command "debug" (info (Debug <$> argument str ( metavar "TARGET_FILES...")) (progDesc "Print out the options that hie-bios thinks you will need to load a file.")) - <> command "config" (info (ConfigInfo <$> filepathParser) (progDesc "Print out the cradle config.")) - <> command "cradle" (info (CradleInfo <$> filepathParser) (progDesc ".")) +progParser = hsubparser + (command "check" (info (Check <$> some filepathParser) (progDesc "Try to load modules into the GHC API.")) + <> command "flags" (info (Flags <$> some filepathParser) (progDesc "Print out the options that hie-bios thinks you will need to load a file.")) + <> command "debug" (info (Debug <$> loadStyleParser <*> many filepathParser) (progDesc "Print out the options that hie-bios thinks you will need to load a file.")) + <> command "config" (info (ConfigInfo <$> some filepathParser) (progDesc "Print out the cradle config location.")) + <> command "cradle" (info (CradleInfo <$> some filepathParser) (progDesc "Print out only the cradle type.")) <> command "root" (info (pure Root) (progDesc "Display the path towards the selected hie.yaml.")) <> command "version" (info (pure Version) (progDesc "Print version and exit.")) ) +loadStyleParser :: Parser UseLoadStyle +loadStyleParser = + flag UseSingleFile UseMultiFile (long "multi" <> help "Load all targets in bulk if supported") ---------------------------------------------------------------- @@ -63,11 +86,15 @@ main = do hSetEncoding stdout utf8 cwd <- getCurrentDirectory - cmd <- execParser progInfo + cli <- execParser progInfo let printLog (L.WithSeverity l sev) = "[" ++ show sev ++ "] " ++ show (pretty l) logger :: forall a . Pretty a => L.LogAction IO (L.WithSeverity a) - logger = L.cmap printLog L.logStringStderr + logger = L.logStringStderr + & L.cmap printLog + & L.cfilter (\msg -> case logLevel cli of + Nothing -> False + Just lvl -> L.getSeverity msg >= lvl ) cradle <- -- find cradle does a takeDirectory on the argument, so make it into a file @@ -75,11 +102,11 @@ Just yaml -> loadCradle logger yaml Nothing -> loadImplicitCradle logger (cwd "File.hs") - res <- case cmd of + res <- case biosCommand cli of Check targetFiles -> checkSyntax logger cradle targetFiles - Debug files -> case files of - [] -> debugInfo (cradleRootDir cradle) cradle - fp -> debugInfo fp cradle + Debug useMultiStyle files -> do + absFiles <- traverse makeAbsolute files + debugFiles absFiles useMultiStyle cradle Flags files -> case files of -- TODO force optparse to acquire one [] -> error "too few arguments" @@ -102,3 +129,16 @@ Root -> rootInfo cradle Version -> return progVersion putStr res + +debugFiles :: [FilePath] -> UseLoadStyle -> Cradle Void -> IO String +debugFiles fps useLoadStyle cradle = case useLoadStyle of + UseSingleFile -> debugSingle + UseMultiFile -> debugBulk + where + debugSingle = case fps of + [] -> debugInfo (cradleRootDir cradle) LoadFile cradle + _ -> concat <$> traverse (\fp -> debugInfo fp LoadFile cradle) fps + + debugBulk = case fps of + [] -> debugInfo (cradleRootDir cradle) (LoadWithContext []) cradle + fp:otherFps -> debugInfo fp (LoadWithContext otherFps) cradle diff --git a/hie-bios.cabal b/hie-bios.cabal --- a/hie-bios.cabal +++ b/hie-bios.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: hie-bios -Version: 0.17.0 +Version: 0.18.0 Author: Matthew Pickering Maintainer: Matthew Pickering License: BSD-3-Clause @@ -146,7 +146,7 @@ tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/src/Lib.hs tests/projects/failing-multi-repl-cabal-project/NotInPath.hs -tested-with: GHC ==9.6.7 || ==9.8.4 || ==9.10.1 || ==9.12.2 +tested-with: GHC ==9.6.7 || ==9.8.4 || ==9.10.1 || ==9.12.2 || ==9.14.1 Library Default-Language: Haskell2010 @@ -186,13 +186,13 @@ cryptohash-sha1 >= 0.11.100 && < 0.12, directory >= 1.3.0 && < 1.4, filepath >= 1.4.1 && < 1.6, - time >= 1.8.0 && < 1.15, + time >= 1.8.0 && < 1.16, extra >= 1.6.14 && < 1.9, prettyprinter ^>= 1.6 || ^>= 1.7.0, - ghc >= 9.2.1 && < 9.13, + ghc >= 9.2.1 && < 9.15, transformers >= 0.5.2 && < 0.7, temporary >= 1.2 && < 1.4, - template-haskell >= 2.18 && <2.24, + template-haskell >= 2.18 && <2.25, text >= 1.2.3 && < 2.2, unix-compat >= 0.5.1 && < 0.8, unordered-containers >= 0.2.9 && < 0.3, @@ -207,14 +207,14 @@ Main-Is: Main.hs Other-Modules: Paths_hie_bios autogen-modules: Paths_hie_bios - GHC-Options: -Wall +RTS -A32M -RTS + GHC-Options: -Wall HS-Source-Dirs: exe Build-Depends: base >= 4.16 && < 5 , co-log-core , directory , filepath , hie-bios - , optparse-applicative >= 0.18.1 && < 0.20 + , optparse-applicative >= 0.17.1 && < 0.20 , prettyprinter test-suite parser-tests @@ -253,9 +253,13 @@ ghc hs-source-dirs: tests/ - ghc-options: -threaded -Wall main-is: BiosTests.hs other-modules: Utils + + ghc-options: -threaded -Wall + -- There seems to be a race condition on windows + if !os(windows) + ghc-options: -rtsopts "-with-rtsopts=-N" Source-Repository head Type: git diff --git a/src/HIE/Bios/Cradle/Cabal.hs b/src/HIE/Bios/Cradle/Cabal.hs --- a/src/HIE/Bios/Cradle/Cabal.hs +++ b/src/HIE/Bios/Cradle/Cabal.hs @@ -20,6 +20,7 @@ import System.Directory import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) import Control.Monad +import Control.Monad.Extra (concatMapM) import Control.Monad.IO.Class import Data.Aeson ((.:)) import qualified Data.Aeson as Aeson @@ -35,7 +36,6 @@ import System.Info.Extra (isWindows) import System.IO.Temp import Data.Version -import Data.Tuple.Extra (fst3, snd3, thd3) import HIE.Bios.Config import HIE.Bios.Environment (getCacheDir) @@ -174,7 +174,7 @@ let cmd = prettyCmdSpec (cmdspec cabalProc) let errorMsg = "Failed to run " <> cmd <> " in directory \"" <> workDir <> "\". Consult the logs for full command and error." throwCE CradleError - { cradleErrorDependencies = deps <> extraDeps + { cradleErrorDependencies = nubOrd (deps <> extraDeps) , cradleErrorExitCode = ExitFailure code , cradleErrorStderr = [errorMsg] <> prettyProcessErrorDetails errorDetails , cradleErrorLoadingFiles = loadingFiles @@ -187,7 +187,7 @@ -- root of the component, so we are right in trivial cases at least. deps <- liftIO $ cabalCradleDependencies projectFile workDir workDir throwCE CradleError - { cradleErrorDependencies = deps <> extraDeps + { cradleErrorDependencies = nubOrd (deps <> extraDeps) , cradleErrorExitCode = ExitSuccess , cradleErrorStderr = ["Failed to parse result of calling cabal"] <> prettyProcessErrorDetails errorDetails , cradleErrorLoadingFiles = loadingFiles @@ -202,7 +202,7 @@ ComponentOptions { componentOptions = final_args , componentRoot = componentDir - , componentDependencies = deps <> extraDeps + , componentDependencies = nubOrd (deps <> extraDeps) } where -- | Run the given cabal process to obtain ghc options. @@ -256,14 +256,14 @@ processCabalLoadStyle :: MonadIO m => LogAction IO (WithSeverity Log) -> ResolvedCradles a -> CradleProjectConfig -> [Char] -> Maybe FilePath -> [Char] -> LoadStyle -> m ([FilePath], [FilePath], [FilePath]) processCabalLoadStyle l cradles projectFile workDir mc fp loadStyle = do let fpModule = fromMaybe (fixTargetPath fp) mc - let (cabalArgs, loadingFiles, extraDeps) = case loadStyle of - LoadFile -> ([fpModule], [fp], []) - LoadWithContext fps -> - let allModulesFpsDeps = ((fpModule, fp, []) : moduleFilesFromSameProject fps) - allModules = nubOrd $ fst3 <$> allModulesFpsDeps - allFiles = nubOrd $ snd3 <$> allModulesFpsDeps - allFpsDeps = nubOrd $ concatMap thd3 allModulesFpsDeps - in (["--keep-temp-files", "--enable-multi-repl"] ++ allModules, allFiles, allFpsDeps) + (cabalArgs, loadingFiles, extraDeps) <- case loadStyle of + LoadFile -> pure ([fpModule], [fp], []) + LoadWithContext fps -> do + (modPairs, mergedDeps) <- moduleFilesFromSameProject fps + let allModPairs = nubOrd $ (fpModule, fp) : modPairs + allModules = nubOrd $ fmap fst allModPairs + allFiles = nubOrd $ fmap snd allModPairs + pure (["--enable-multi-repl"] ++ allModules, allFiles, mergedDeps) liftIO $ l <& LogComputedCradleLoadStyle "cabal" loadStyle `WithSeverity` Info liftIO $ l <& LogCabalLoad fp mc (prefix <$> resolvedCradles cradles) loadingFiles `WithSeverity` Debug @@ -275,15 +275,24 @@ fixTargetPath x | isWindows && hasDrive x = makeRelative workDir x | otherwise = x - moduleFilesFromSameProject fps = - [ (fromMaybe (fixTargetPath file) old_mc, file, deps) - | file <- fps, - -- Lookup the component for the old file - Just (ResolvedCradle {concreteCradle = ConcreteCabal ct, cradleDeps = deps}) <- [selectCradle prefix file (resolvedCradles cradles)], - -- Only include this file if the old component is in the same project - (projectConfigFromMaybe (cradleRoot cradles) (cabalProjectFile ct)) == projectFile, - let old_mc = cabalComponent ct - ] + -- Return (moduleTarget,file) pairs for each context file, plus a merged dependency list across all of them. + moduleFilesFromSameProject :: MonadIO m => [FilePath] -> m ([(FilePath, FilePath)], [FilePath]) + moduleFilesFromSameProject fps = do + -- First, select eligible files and collect their componentDir and YAML deps + let selected = + [ (file, depsYaml, prefix rc, cabalComponent ct) + | file <- fps + , Just rc@(ResolvedCradle {concreteCradle = ConcreteCabal ct, cradleDeps = depsYaml}) <- [selectCradle prefix file (resolvedCradles cradles)] + , (projectConfigFromMaybe (cradleRoot cradles) (cabalProjectFile ct)) == projectFile + ] + -- Compute dynamic deps + let compDirs = nubOrd $ takeDirectory fp : [ takeDirectory f | (f, _, _, _) <- selected ] + dynDeps <- concatMapM (liftIO . cabalCradleDependenciesEnclosing projectFile (cradleRoot cradles)) compDirs + -- Combine YAML deps with dynamic deps + let mergedDeps = nubOrd $ dynDeps ++ concat [ depsYaml | (_, depsYaml, _ , _) <- selected ] + let modPairs = [ (fromMaybe (fixTargetPath file) old_mc, file) + | (file, _, _, old_mc) <- selected ] + pure (modPairs, mergedDeps) cabalLoadFilesWithRepl :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> [String] -> CradleLoadResultT IO CreateProcess cabalLoadFilesWithRepl l projectFile workDir args = do @@ -314,6 +323,43 @@ let cabalFiles = map (relFp ) cabalFiles' return $ map normalise $ cabalFiles ++ projectLocationOrDefault projectFile +-- | @'cabalCradleDependenciesEnclosing' projectFile rootDir startDir@. +-- Find cradle dependency files by walking upwards from a starting directory. +-- +-- This is similar to 'cabalCradleDependencies', but instead of looking only in a +-- specific component directory, it searches for @.cabal@ files in @startDir@ and +-- its ancestor directories, stopping at (and not traversing above) @rootDir@ or +-- the filesystem root. All discovered @.cabal@ files are returned relative to +-- @rootDir@, along with the cabal project configuration files determined by +-- 'projectLocationOrDefault'. +-- +-- Inputs +-- - projectFile: the cradle's cabal project configuration (explicit file or default). +-- - rootDir: absolute cradle root; used as the boundary for the upward search and +-- to relativize returned paths. +-- - startDir: directory from which to begin searching for enclosing @.cabal@ files. +-- +-- Output +-- - A list of normalised, relative file paths that should be watched to trigger +-- a reload when changed. +cabalCradleDependenciesEnclosing :: CradleProjectConfig -> FilePath -> FilePath -> IO [FilePath] +cabalCradleDependenciesEnclosing projectFile rootDir fp = do + cabalFiles' <- findCabalFilesEnclosing fp + let relCabalFiles = map (makeRelative rootDir) cabalFiles' + return $ map normalise $ relCabalFiles ++ projectLocationOrDefault projectFile + where + -- find the cabal file upwards from fp to rootDir + findCabalFilesEnclosing :: FilePath -> IO [FilePath] + findCabalFilesEnclosing dir = do + cfs <- map (dir ) <$> findCabalFiles dir + if not (null cfs) + then return cfs + else + let parentDir = takeDirectory dir + in if parentDir == dir || length parentDir < length rootDir + then return [] + else findCabalFilesEnclosing parentDir + processCabalWrapperArgs :: [String] -> Maybe (FilePath, [String]) processCabalWrapperArgs args = case args of @@ -332,8 +378,13 @@ -- ---------------------------------------------------------------------------- cabalLoadFilesBefore315 :: LogAction IO (WithSeverity Log) -> ProgramVersions -> CradleProjectConfig -> [Char] -> [String] -> CradleLoadResultT IO CreateProcess -cabalLoadFilesBefore315 l progVersions projectFile workDir args = do +cabalLoadFilesBefore315 l progVersions projectFile workDir args' = do let cabalCommand = "v2-repl" + cabal_version <- liftIO $ runCachedIO $ cabalVersion progVersions + + let args = case cabal_version of + Just v | v < makeVersion [3,15] -> "--keep-temp-files" : args' + _ -> args' cabalProcess l progVersions projectFile workDir cabalCommand args `modCradleError` \err -> do deps <- cabalCradleDependencies projectFile workDir workDir pure $ err {cradleErrorDependencies = cradleErrorDependencies err ++ deps} diff --git a/src/HIE/Bios/Environment.hs b/src/HIE/Bios/Environment.hs --- a/src/HIE/Bios/Environment.hs +++ b/src/HIE/Bios/Environment.hs @@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards, CPP #-} -module HIE.Bios.Environment (initSession, getRuntimeGhcLibDir, getRuntimeGhcVersion, makeDynFlagsAbsolute, makeTargetsAbsolute, getCacheDir, addCmdOpts) where +module HIE.Bios.Environment (initSession, initSession', getRuntimeGhcLibDir, getRuntimeGhcVersion, makeDynFlagsAbsolute, makeTargetsAbsolute, getCacheDir, addCmdOpts) where import GHC (GhcMonad) import qualified GHC as G @@ -21,18 +21,30 @@ import HIE.Bios.Types import qualified HIE.Bios.Ghc.Gap as Gap +import qualified System.OsPath as OsPath + -- | Start a GHC session and set some sensible options for tooling to use. -- Creates a folder in the cache directory to cache interface files to make -- reloading faster. initSession :: (GhcMonad m) => ComponentOptions -> m [G.Target] -initSession ComponentOptions {..} = do +initSession = initSession' False + +initSession' :: (GhcMonad m) + => Bool + -> ComponentOptions + -> m [G.Target] +initSession' workAroundThreadUnsafety ComponentOptions {..} = do df <- G.getSessionDynFlags -- Create a unique folder per set of different GHC options, assuming that each different set of -- GHC options will create incompatible interface files. - let opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack componentOptions) + let + -- There seems to be a race condition when writing interface files + hash_args = (if workAroundThreadUnsafety then (componentRoot :) else id) componentOptions + opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init $ map B.pack hash_args + cache_dir <- liftIO $ getCacheDir opts_hash -- Add the user specified options to a fresh GHC session. (df', targets) <- addCmdOpts componentOptions df @@ -161,16 +173,20 @@ $ df { G.importPaths = map makeAbs (G.importPaths df) , G.packageDBFlags = - map (Gap.overPkgDbRef makeAbs) (G.packageDBFlags df) + map (Gap.overPkgDbRef makeAbsOs) (G.packageDBFlags df) } where makeAbs = -#if __GLASGOW_HASKELL__ >= 903 case G.workingDirectory df of Just fp -> ((root fp) ) Nothing -> -#endif (root ) + + makeAbsOs p = + case G.workingDirectory df of + Just fp -> Gap.unsafeEncodeUtf (root fp) OsPath. p + Nothing -> + Gap.unsafeEncodeUtf root OsPath. p -- -------------------------------------------------------- diff --git a/src/HIE/Bios/Ghc/Api.hs b/src/HIE/Bios/Ghc/Api.hs --- a/src/HIE/Bios/Ghc/Api.hs +++ b/src/HIE/Bios/Ghc/Api.hs @@ -7,6 +7,7 @@ , withDynFlags -- For test purposes , initSessionWithMessage + , initSessionWithMessage' ) where import GHC (LoadHowMuch(..), DynFlags, GhcMonad) @@ -48,8 +49,15 @@ => Maybe G.Messager -> ComponentOptions -> (m G.SuccessFlag, ComponentOptions) -initSessionWithMessage msg compOpts = (do - targets <- initSession compOpts +initSessionWithMessage = initSessionWithMessage' False + +initSessionWithMessage' :: (GhcMonad m) + => Bool + -> Maybe G.Messager + -> ComponentOptions + -> (m G.SuccessFlag, ComponentOptions) +initSessionWithMessage' workAroundThreadUnsafety msg compOpts = (do + targets <- initSession' workAroundThreadUnsafety compOpts G.setTargets targets -- Get the module graph using the function `getModuleGraph` mod_graph <- G.depanal [] True diff --git a/src/HIE/Bios/Ghc/Gap.hs b/src/HIE/Bios/Ghc/Gap.hs --- a/src/HIE/Bios/Ghc/Gap.hs +++ b/src/HIE/Bios/Ghc/Gap.hs @@ -41,6 +41,9 @@ , HIE.Bios.Ghc.Gap.parseDynamicFlags -- * Platform constants , hostIsDynamic + -- * OsPath Compat + , unsafeEncodeUtf + , unsafeDecodeUtf -- * misc , getTyThing , fixInfo @@ -73,14 +76,16 @@ import qualified GHC.Platform.Ways as Platform import qualified GHC.Runtime.Loader as DynamicLoading (initializePlugins) import qualified GHC.Tc.Types as Tc +import GHC.Unit.Types (UnitId) import GHC.Utils.Logger import GHC.Utils.Outputable import qualified GHC.Utils.Ppr as Ppr import qualified GHC.Driver.Make as G +import System.OsPath (OsPath) +import qualified System.OsPath as OsPath +import Data.Maybe (fromMaybe) +import GHC.Stack.Types (HasCallStack) -#if __GLASGOW_HASKELL__ > 903 -import GHC.Unit.Types (UnitId) -#endif #if __GLASGOW_HASKELL__ < 904 import qualified GHC.Driver.Main as G #endif @@ -136,21 +141,22 @@ set_hsc_dflags :: DynFlags -> HscEnv -> HscEnv set_hsc_dflags dflags hsc_env = hsc_env { G.hsc_dflags = dflags } -overPkgDbRef :: (FilePath -> FilePath) -> G.PackageDBFlag -> G.PackageDBFlag +overPkgDbRef :: (OsPath -> OsPath) -> G.PackageDBFlag -> G.PackageDBFlag overPkgDbRef f (G.PackageDB pkgConfRef) = G.PackageDB $ case pkgConfRef of - G.PkgDbPath fp -> G.PkgDbPath (f fp) + G.PkgDbPath fp -> +#if __GLASGOW_HASKELL__ >= 915 + G.PkgDbPath (f fp) +#else + G.PkgDbPath (unsafeDecodeUtf $ f $ unsafeEncodeUtf fp) +#endif + conf -> conf overPkgDbRef _f db = db ---------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 903 guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe G.Phase -> m G.Target guessTarget a b c = G.guessTarget a b c -#else -guessTarget :: GhcMonad m => String -> a -> Maybe G.Phase -> m G.Target -guessTarget a _ b = G.guessTarget a b -#endif ---------------------------------------------------------------- @@ -180,9 +186,7 @@ G.IncludeSpecs (map f $ G.includePathsQuote (includePaths df)) (map f $ G.includePathsGlobal (includePaths df)) -#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) (map f $ G.includePathsQuoteImplicit (includePaths df)) -#endif } ---------------------------------------------------------------- @@ -195,11 +199,7 @@ setSession env noopLogger :: LogAction -#if __GLASGOW_HASKELL__ >= 903 noopLogger = (\_wr _s _ss _m -> return ()) -#else -noopLogger = (\_df _wr _s _ss _m -> return ()) -#endif -- -------------------------------------------------------- -- Doc Compat functions @@ -217,11 +217,7 @@ -- -------------------------------------------------------- numLoadedPlugins :: HscEnv -> Int -#if __GLASGOW_HASKELL__ >= 903 numLoadedPlugins = length . Plugins.pluginsWithArgs . hsc_plugins -#else -numLoadedPlugins = length . Plugins.plugins -#endif initializePluginsForModSummary :: HscEnv -> ModSummary -> IO (Int, [G.ModuleName], ModSummary) initializePluginsForModSummary hsc_env' mod_summary = do @@ -292,3 +288,18 @@ hostIsDynamic :: Bool hostIsDynamic = Platform.hostIsDynamic + +-- -------------------------------------------------------- +-- OsPath Compat +-- -------------------------------------------------------- + +unsafeEncodeUtf :: HasCallStack => FilePath -> OsPath +unsafeEncodeUtf fp = +#if MIN_VERSION_filepath(1,5,0) + OsPath.unsafeEncodeUtf fp +#else + fromMaybe (error "unsafeEncodeUtf") $ OsPath.encodeUtf fp +#endif + +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath +unsafeDecodeUtf = fromMaybe (error "unsafeDecodeUtf") . OsPath.decodeUtf diff --git a/src/HIE/Bios/Ghc/Load.hs b/src/HIE/Bios/Ghc/Load.hs --- a/src/HIE/Bios/Ghc/Load.hs +++ b/src/HIE/Bios/Ghc/Load.hs @@ -20,12 +20,7 @@ import qualified GHC.Driver.Main as G import qualified HIE.Bios.Ghc.Gap as Gap -#if __GLASGOW_HASKELL__ > 903 import GHC.Fingerprint -#endif -#if __GLASGOW_HASKELL__ < 903 -import Data.Time.Clock -#endif data Log = LogLoaded FilePath FilePath @@ -118,16 +113,9 @@ -- fool the recompilation checker so that we can get the typechecked modules updateTime :: MonadIO m => [Target] -> ModuleGraph -> m ModuleGraph updateTime ts graph = liftIO $ do -#if __GLASGOW_HASKELL__ < 903 - cur_time <- getCurrentTime -#endif let go ms | any (msTargetIs ms) ts = -#if __GLASGOW_HASKELL__ >= 903 ms {ms_hs_hash = fingerprint0} -#else - ms {ms_hs_date = cur_time} -#endif | otherwise = ms pure $ Gap.mapMG go graph diff --git a/src/HIE/Bios/Ghc/Logger.hs b/src/HIE/Bios/Ghc/Logger.hs --- a/src/HIE/Bios/Ghc/Logger.hs +++ b/src/HIE/Bios/Ghc/Logger.hs @@ -24,10 +24,8 @@ import HIE.Bios.Ghc.Api (withDynFlags) import qualified HIE.Bios.Ghc.Gap as Gap -#if __GLASGOW_HASKELL__ >= 903 import GHC.Types.Error import GHC.Driver.Errors.Types -#endif ---------------------------------------------------------------- @@ -46,9 +44,7 @@ appendLogRef :: DynFlags -> Gap.PprStyle -> LogRef -> LogAction appendLogRef df style (LogRef ref) _ -#if __GLASGOW_HASKELL__ < 903 - _ sev -#elif __GLASGOW_HASKELL__ < 905 +#if __GLASGOW_HASKELL__ < 905 (MCDiagnostic sev _) #else (MCDiagnostic sev _ _) @@ -56,6 +52,7 @@ src msg = do let !l = ppMsg src sev df style msg modifyIORef ref (\b -> b . (l:)) +appendLogRef _ _ _ _ _ _ _ = pure () ---------------------------------------------------------------- @@ -88,14 +85,9 @@ sourceError err = do dflag <- getSessionDynFlags style <- getStyle dflag -#if __GLASGOW_HASKELL__ >= 903 let ret = unlines . errBagToStrList dflag style . getMessages . srcErrorMessages $ err -#else - let ret = unlines . errBagToStrList dflag style . srcErrorMessages $ err -#endif return (Left ret) -#if __GLASGOW_HASKELL__ >= 903 errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope GhcMessage) -> [String] errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList @@ -108,19 +100,6 @@ msg = pprLocMsgEnvelope (defaultDiagnosticOpts @GhcMessage) err #else msg = pprLocMsgEnvelope err -#endif - -- fixme -#else -errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope DecoratedSDoc) -> [String] -errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList - - -ppErrMsg :: DynFlags -> Gap.PprStyle -> MsgEnvelope DecoratedSDoc -> String -ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext - where - spn = errMsgSpan err - msg = pprLocMsgEnvelope err - -- fixme #endif ppMsg :: SrcSpan -> G.Severity-> DynFlags -> Gap.PprStyle -> SDoc -> String diff --git a/src/HIE/Bios/Internal/Debug.hs b/src/HIE/Bios/Internal/Debug.hs --- a/src/HIE/Bios/Internal/Debug.hs +++ b/src/HIE/Bios/Internal/Debug.hs @@ -26,11 +26,12 @@ -- Otherwise, shows the error message and exit-code. debugInfo :: Show a => FilePath + -> LoadStyle -> Cradle a -> IO String -debugInfo fp cradle = unlines <$> do +debugInfo fp loadStyle cradle = unlines <$> do let logger = cradleLogger cradle - res <- getCompilerOptions fp LoadFile cradle + res <- getCompilerOptions fp loadStyle cradle canonFp <- canonicalizePath fp conf <- findConfig canonFp crdl <- findCradle' logger canonFp diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -15,17 +15,20 @@ import qualified Test.Tasty.Ingredients as Tasty import HIE.Bios import HIE.Bios.Cradle -import Control.Monad ( forM_ ) +import Control.Monad (forM_) +import Control.Monad.Extra (unlessM) +import Control.Monad.IO.Class +import Data.Foldable (for_) import Data.List ( sort, isPrefixOf ) import Data.Typeable import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import System.Directory import System.FilePath ((), makeRelative) import System.Info.Extra (isWindows) -import Control.Monad.Extra (unlessM) +import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout) import qualified HIE.Bios.Ghc.Gap as Gap -import Control.Monad.IO.Class + argDynamic :: [String] argDynamic = ["-dynamic" | Gap.hostIsDynamic] @@ -55,6 +58,7 @@ -- to avoid recompilation. main :: IO () main = do + for_ [stderr, stdout] (`hSetBuffering` LineBuffering) writeStackYamlFiles stackDep <- checkToolIsAvailable "stack" cabalDep <- checkToolIsAvailable "cabal" @@ -78,7 +82,7 @@ initCradle "doesNotExist.hs" assertCradle isMultiCradle step "Attempt to load symlinked module A" - inCradleRootDir $ do + do loadComponentOptions "./a/A.hs" assertComponentOptions $ \opts -> componentOptions opts `shouldMatchList` ["a"] <> argDynamic @@ -87,20 +91,25 @@ initCradle "doesNotExist.hs" assertCradle isMultiCradle step "Attempt to load symlinked module A" - inCradleRootDir $ do - liftIO $ createDirectoryLink "./a" "./b" - liftIO $ unlessM (doesFileExist "./b/A.hs") $ + do + cradle <- askCradle + let rooted = (cradleRootDir cradle ) + liftIO $ createDirectoryLink (rooted "a") (rooted "./b") + liftIO $ unlessM (doesFileExist $ rooted "b/A.hs") $ assertFailure "Test invariant broken, this file must exist." loadComponentOptions "./b/A.hs" assertComponentOptions $ \opts -> componentOptions opts `shouldMatchList` ["b"] <> argDynamic + , biosTestCase "Can not load symlinked module that is ignored" $ runTestEnv "./symlink-test" $ do initCradle "doesNotExist.hs" assertCradle isMultiCradle step "Attempt to load symlinked module A" - inCradleRootDir $ do - liftIO $ createDirectoryLink "./a" "./c" - liftIO $ unlessM (doesFileExist "./c/A.hs") $ + do + cradle <- askCradle + let rooted = (cradleRootDir cradle ) + liftIO $ createDirectoryLink (rooted "./a") (rooted "./c") + liftIO $ unlessM (doesFileExist $ rooted "c/A.hs") $ assertFailure "Test invariant broken, this file must exist." loadComponentOptions "./c/A.hs" assertLoadNone @@ -124,11 +133,11 @@ cradleErrorExitCode @?= ExitSuccess cradleErrorDependencies `shouldMatchList` [] length cradleErrorStderr @?= 1 - let errorCtx = head cradleErrorStderr - -- On windows, this error message contains '"' around the executable name - if isWindows - then "Couldn't execute \"myGhc\"" `isPrefixOf` errorCtx @? "Error message should contain error information" - else "Couldn't execute myGhc" `isPrefixOf` errorCtx @? "Error message should contain error information" + forM_ cradleErrorStderr $ \errorCtx -> + -- On windows, this error message contains '"' around the executable name + if isWindows + then "Couldn't execute \"myGhc\"" `isPrefixOf` errorCtx @? "Error message should contain error information" + else "Couldn't execute myGhc" `isPrefixOf` errorCtx @? "Error message should contain error information" , biosTestCase "simple-bios-shell" $ runTestEnv "./simple-bios-shell" $ do testDirectoryM isBiosCradle "B.hs" , biosTestCase "simple-bios-shell-deps" $ runTestEnv "./simple-bios-shell" $ do @@ -193,6 +202,47 @@ , "cabal.project" , "cabal.project.local" ] + , biosTestCase "nested-cabal multi-mode includes enclosing deps for extra files" $ runTestEnv "./nested-cabal" $ do + -- Initialize cradle first, since capability checks use the current cradle. + initCradle "sub-comp/Lib.hs" + assertCradle isCabalCradle + multiSupported <- isCabalMultipleCompSupported' + if multiSupported + then do + loadComponentOptionsMultiStyle "sub-comp/Lib.hs" ["MyLib.hs"] + assertComponentOptions $ \opts -> do + -- Expect both the main component's cabal file and the enclosing cabal for the extra file, + -- plus project files. + componentDependencies opts `shouldMatchList` + [ "sub-comp" "sub-comp.cabal" + , "nested-cabal.cabal" + , "cabal.project" + , "cabal.project.local" + ] + else do + -- On older cabal/ghc combos, multi-repl isn't supported; just ensure load succeeds. + loadComponentOptions "sub-comp/Lib.hs" + _ <- assertLoadSuccess + pure () + , biosTestCase "nested-cabal multi-mode includes enclosing deps when extra file is subcomp" $ runTestEnv "./nested-cabal" $ do + -- Initialize cradle at the top level, then treat the sub-component file as an extra file. + initCradle "MyLib.hs" + assertCradle isCabalCradle + multiSupported <- isCabalMultipleCompSupported' + if multiSupported + then do + loadComponentOptionsMultiStyle "MyLib.hs" ["sub-comp/Lib.hs"] + assertComponentOptions $ \opts -> do + componentDependencies opts `shouldMatchList` + [ "nested-cabal.cabal" + , "sub-comp" "sub-comp.cabal" + , "cabal.project" + , "cabal.project.local" + ] + else do + loadComponentOptions "MyLib.hs" + _ <- assertLoadSuccess + pure () , biosTestCase "multi-cabal" $ runTestEnv "./multi-cabal" $ do {- tests if both components can be loaded -} testDirectoryM isCabalCradle "app/Main.hs" @@ -261,6 +311,20 @@ -- This test doesn't hurt for other cases as well, so we enable it for -- all configurations. testDirectoryM isCabalCradle "src/MyLib.hs" + , biosTestCase "force older Cabal version in custom setup with multi mode" $ runTestEnv "cabal-with-custom-setup" $ do + -- Specifically tests whether cabal 3.16 works as expected with + -- an older lib:Cabal version that doesn't support '--with-repl'. + -- This test doesn't hurt for other cases as well, so we enable it for + -- all configurations. + let target = "src/MyLib.hs" + initCradle target + assertCradle isCabalCradle + loadRuntimeGhcLibDir + assertLibDirVersion + loadRuntimeGhcVersion + assertGhcVersion + -- suffices to force loading cabal's `--enable-multi-repl` codepath + loadFileGhcMultiStyle target [] ] ] where @@ -464,7 +528,7 @@ -- | This option, when set to 'True', specifies that we should run in the -- «list tests» mode newtype IgnoreToolDeps = IgnoreToolDeps Bool - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord) instance Tasty.IsOption IgnoreToolDeps where defaultValue = IgnoreToolDeps False @@ -498,6 +562,7 @@ ignoreOnUnsupportedGhc :: TestTree -> TestTree ignoreOnUnsupportedGhc tt = - -- Currently, all GHC versions are supported! Yay! - tt - +#if (defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,14,0,0)) + ignoreTestBecause "Not supported on GHC 9.14" +#endif + tt diff --git a/tests/Utils.hs b/tests/Utils.hs --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -46,8 +46,8 @@ loadComponentOptionsMultiStyle, loadRuntimeGhcLibDir, loadRuntimeGhcVersion, - inCradleRootDir, loadFileGhc, + loadFileGhcMultiStyle, isCabalMultipleCompSupported', -- * Assertion helpers @@ -297,7 +297,7 @@ loadComponentOptionsMultiStyle :: FilePath -> [FilePath] -> TestM () loadComponentOptionsMultiStyle fp fps = do a_fp <- normFile fp - a_fps <- mapM normFile fps + a_fps <- traverse normFile fps crd <- askCradle step $ "Initialise flags for: " <> fp <> " and " <> show fps clr <- liftIO $ getCompilerOptions a_fp (LoadWithContext a_fps) crd @@ -324,15 +324,6 @@ versions <- liftIO $ makeVersions (cradleLogger cr) root ((runGhcCmd . cradleOptsProg) cr) liftIO $ isCabalMultipleCompSupported versions -inCradleRootDir :: TestM a -> TestM a -inCradleRootDir act = do - crd <- askCradle - prev <- liftIO getCurrentDirectory - liftIO $ setCurrentDirectory (cradleRootDir crd) - a <- act - liftIO $ setCurrentDirectory prev - pure a - loadFileGhc :: FilePath -> TestM () loadFileGhc fp = do libdir <- askOrLoadLibDir @@ -343,7 +334,26 @@ opts <- assertLoadSuccess liftIO $ G.runGhc (Just libdir) $ do - let (ini, _) = initSessionWithMessage (Just G.batchMsg) opts + let (ini, _) = initSessionWithMessage' True (Just G.batchMsg) opts + sf <- ini + case sf of + -- Test resetting the targets + Succeeded -> do + liftIO $ stepF "Set target files" + setTargetFiles mempty [(a_fp, a_fp)] + Failed -> liftIO $ assertFailure "Module loading failed" + +loadFileGhcMultiStyle :: FilePath -> [FilePath] -> TestM () +loadFileGhcMultiStyle fp extraFps = do + libdir <- askOrLoadLibDir + a_fp <- normFile fp + stepF <- askStep + step "Cradle load" + loadComponentOptionsMultiStyle fp extraFps + opts <- assertLoadSuccess + liftIO $ + G.runGhc (Just libdir) $ do + let (ini, _) = initSessionWithMessage' True (Just G.batchMsg) opts sf <- ini case sf of -- Test resetting the targets