hie-bios 0.17.0 → 0.18.0
raw patch · 12 files changed
+326/−145 lines, 12 filesdep ~ghcdep ~optparse-applicativedep ~template-haskell
Dependency ranges changed: ghc, optparse-applicative, template-haskell, time
Files
- ChangeLog.md +8/−0
- exe/Main.hs +59/−19
- hie-bios.cabal +12/−8
- src/HIE/Bios/Cradle/Cabal.hs +73/−22
- src/HIE/Bios/Environment.hs +22/−6
- src/HIE/Bios/Ghc/Api.hs +10/−2
- src/HIE/Bios/Ghc/Gap.hs +31/−20
- src/HIE/Bios/Ghc/Load.hs +0/−12
- src/HIE/Bios/Ghc/Logger.hs +2/−23
- src/HIE/Bios/Internal/Debug.hs +3/−2
- tests/BiosTests.hs +84/−19
- tests/Utils.hs +22/−12
ChangeLog.md view
@@ -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)
exe/Main.hs view
@@ -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
hie-bios.cabal view
@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: hie-bios-Version: 0.17.0+Version: 0.18.0 Author: Matthew Pickering <matthewtpickering@gmail.com> Maintainer: Matthew Pickering <matthewtpickering@gmail.com> 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
src/HIE/Bios/Cradle/Cabal.hs view
@@ -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}
src/HIE/Bios/Environment.hs view
@@ -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 -- --------------------------------------------------------
src/HIE/Bios/Ghc/Api.hs view
@@ -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
src/HIE/Bios/Ghc/Gap.hs view
@@ -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
src/HIE/Bios/Ghc/Load.hs view
@@ -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
src/HIE/Bios/Ghc/Logger.hs view
@@ -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
src/HIE/Bios/Internal/Debug.hs view
@@ -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
tests/BiosTests.hs view
@@ -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
tests/Utils.hs view
@@ -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