hie-bios-0.21.0: src/HIE/Bios/Cradle/Cabal.hs
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module HIE.Bios.Cradle.Cabal
(
-- * Cabal Cradle interface
cabalAction,
runCabalGhcCmd,
-- * Locations
findCabalFiles,
-- * Wrappers
withGhcWrapperTool,
-- * Argument processing
processCabalWrapperArgs,
-- * Internals (exposed for tests)
isCabalMultipleCompSupported,
cabalBuildDir,
)
where
import Data.Char (isSpace)
import System.Exit
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
import qualified Data.Aeson.Types as Aeson
import qualified Data.ByteString as BS
import Data.Conduit.Process
import Data.Maybe (fromMaybe)
import Data.List
import Data.List.Extra (trimEnd, nubOrd)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import System.FilePath
import System.Info.Extra (isWindows)
import System.IO.Temp
import Data.Version
import HIE.Bios.Config
import HIE.Bios.Types hiding (ActionName(..))
import HIE.Bios.Wrappers
import qualified HIE.Bios.Process as Process
import HIE.Bios.Cradle.ProjectConfig
import HIE.Bios.Cradle.Utils
import HIE.Bios.Cradle.ProgramVersions
import HIE.Bios.Cradle.Resolved
import HIE.Bios.Process
import GHC.Fingerprint (fingerprintString)
import GHC.ResponseFile (escapeArgs)
{- Note [Finding ghc-options with cabal]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to know how to compile a cabal component with GHC.
There are two main ways to obtain the ghc-options:
1. `cabal --with-ghc <ghc-shim>` (for exe:cabal <3.15 or lib:Cabal <3.15)
In this approach, we generate a <ghc-shim> which is passed to the exe:cabal process.
If a package needs to be compiled, we compile the package with the same GHC process that
exe:cabal would have used.
If the first argument is `--interactive`, then we do not launch the GHCi process,
but record all the arguments for later processing.
2. `cabal --with-repl <repl-shim>` (for exe:cabal >=3.15 and lib:Cabal >=3.15)
The <repl-shim> is notably simpler than the <ghc-shim>, as `--with-repl` invokes
<repl-shim> *only* as the final GHCi process, not for compiling dependencies or
executing preprocessors.
Thus, <repl-shim> merely needs to log all arguments that are passed to <repl-shim>.
This is the simpler, more maintainable approach, with fewer unintended side-effects.
=== Finding the GHC process cabal uses to compile a project with
We want HLS and hie-bios to honour the `with-compiler` field in `cabal.project` files.
Again, we identify two ways to find the exact GHC program that is going to be invoked by cabal.
1. `cabal exec -- ghc --interactive -e System.Environment.getExecutablePath` (for exe:cabal <3.14)
Ignoring a couple of details, we can get the path to the raw executable by asking
the GHCi process for its executable path.
The issue is that on linux, the executable path is insufficient, the GHC executable
invoked by the user is "wrapped" in a shim that specifies the libdir location, e.g.:
> cat /home/hugin/.ghcup/bin/ghc
#!/bin/sh
exedir="/home/hugin/.ghcup/ghc/9.6.7/lib/ghc-9.6.7/bin"
exeprog="./ghc-9.6.7"
executablename="/home/hugin/.ghcup/ghc/9.6.7/lib/ghc-9.6.7/bin/./ghc-9.6.7"
bindir="/home/hugin/.ghcup/ghc/9.6.7/bin"
libdir="/home/hugin/.ghcup/ghc/9.6.7/lib/ghc-9.6.7/lib"
docdir="/home/hugin/.ghcup/ghc/9.6.7/share/doc/ghc-9.6.7"
includedir="/home/hugin/.ghcup/ghc/9.6.7/include"
exec "$executablename" -B"$libdir" ${1+"$@"}
We find the libdir by asking GHC via `cabal exec -- ghc --print-libdir`.
Once we have these two paths, we also need to find the `ghc-pkg` location,
otherwise cabal will use the `ghc-pkg` that is found on PATH, which is not correct
if the user overwrites the compiler field via `with-compiler`.
To find `ghc-pkg`, we assume it is going to be located next to the `libdir`, and then
reconstruct the wrapper shim for `ghc-pkg`.
Then we reconstructed both the ghc and ghc-pkg program that is going to be used by cabal
and can use it in the <ghc-shim> and `cabal repl --with-compiler <ghc-shim> --with-hc-pkg <hc-pkg-shim>`.
Calling `cabal exec` can be very slow on a large codebase, over 1 second per invocation.
2. `cabal path` (for exe:cabal >= 3.14)
We can skip the reconstruction of the GHC shim by using the output of `cabal path --compiler-info`.
This gives us the location of the GHC executable shim, so we don't need to reconstruct any shims.
However, we still have to reconstruct the ghc-pkg shim when using `cabal repl --with-compiler`.
`cabal path` is incredibly fast to invoke, as it circumvents running the cabal solver.
It is easier to maintain as well.
-}
-- | Main entry point into the cabal cradle invocation.
--
-- This function does a lot of work, supporting multiple cabal-install versions and
-- different ways of obtaining the component options.
--
-- See Note [Finding ghc-options with cabal] for a detailed elaboration.
cabalAction ::
ResolvedCradles a ->
FilePath ->
Maybe String ->
LogAction IO (WithSeverity Log) ->
CradleProjectConfig ->
TargetWithContext ->
LoadMode ->
CradleLoadResultT IO ComponentOptions
cabalAction cradles workDir mc l projectFile fp loadStyle = do
let progVersions = cradleProgramVersions cradles
multiCompSupport <- isCabalMultipleCompSupported progVersions
-- determine which load style is supported by this cabal cradle.
determinedLoadMode <- case loadStyle of
LoadFile -> pure LoadFile
-- all other modes need multi component support.
_ | not multiCompSupport -> do
liftIO $
l
<& WithSeverity
( LogLoadModeUnsupported "cabal" loadStyle $
Just "cabal or ghc version is too old. We require `cabal >= 3.11` and `ghc >= 9.4`"
)
Warning
pure LoadFile
_ -> pure loadStyle
(cabalArgs, loadingFiles, extraDeps) <- processCabalLoadMode l cradles progVersions projectFile workDir mc fp determinedLoadMode
mResult <- runCabalToGetGhcOptions progVersions cabalArgs
case mResult of
Left (cabalProc, code, errorDetails) -> do
-- Provide some dependencies an IDE can look for to trigger a reload.
-- Best effort. Assume the working directory is the
-- root of the component, so we are right in trivial cases at least.
deps <- liftIO $ cabalCradleDependencies projectFile workDir workDir
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 = nubOrd (deps <> extraDeps)
, cradleErrorExitCode = ExitFailure code
, cradleErrorStderr = [errorMsg] <> prettyProcessErrorDetails errorDetails
, cradleErrorLoadingFiles = loadingFiles
}
Right (args, errorDetails) -> do
case processCabalWrapperArgs args of
Nothing -> do
-- Provide some dependencies an IDE can look for to trigger a reload.
-- Best effort. Assume the working directory is the
-- root of the component, so we are right in trivial cases at least.
deps <- liftIO $ cabalCradleDependencies projectFile workDir workDir
throwCE CradleError
{ cradleErrorDependencies = nubOrd (deps <> extraDeps)
, cradleErrorExitCode = ExitSuccess
, cradleErrorStderr = ["Failed to parse result of calling cabal"] <> prettyProcessErrorDetails errorDetails
, cradleErrorLoadingFiles = loadingFiles
}
Just (componentDir, ghc_args) -> do
deps <- liftIO $ cabalCradleDependencies projectFile workDir componentDir
final_args <- case loadModeUsesResponseFiles cabalArgs of
UsesResponseFiles -> liftIO $ expandGhcOptionResponseFile ghc_args
NoResponseFiles -> pure ghc_args
CradleLoadResultT $ pure $ CradleSuccess
ComponentOptions
{ componentOptions = final_args
, componentRoot = componentDir
, componentDependencies = nubOrd (deps <> extraDeps)
}
where
-- | Try to obtain the ghc options using cabal.
--
-- First, we try what the user requested and what cabal supports.
-- For example, if the user requested to load multiple components at once, and cabal
-- is recent enough, we try to use @--with-repl --enable-multi-repl@.
-- We detect when certain cabal features are not supported. For example, for old
-- lib:Cabal versions, @--with-repl@ is not supported. In this case, we parse the error message
-- and fall back to the old `CabalWithGhcShimWrapper` version.
-- The ghc shim @--with-ghc@ might work with @--keep-temp-files@ if no custom cabal package is part
-- of the repl session, so we try to load that, and as a last resort, fall back to single component loading.
runCabalToGetGhcOptions ::
ProgramVersions ->
LoadModeTargets ->
CradleLoadResultT IO
(Either
(CreateProcess, Int, ProcessErrorDetails)
([String], ProcessErrorDetails)
)
runCabalToGetGhcOptions progVersions cabalArgs = do
cabalFeatures <- determineCabalLoadFeature progVersions
let
cacheDir = cradleCacheDirResolved cradles
-- The preferred way of loading ghc-options. Requires cabal 3.16
cabalWithReplProc = cabalLoadFilesWithRepl l cacheDir projectFile workDir cabalArgs
-- Legacy way of loading ghc-options.
-- Supports multi-repl and the deprecated single file mode.
cabalWithGhcShimWrapper = cabalLoadFilesBefore315 l cacheDir progVersions projectFile workDir cabalArgs
-- Legacy way of loading ghc-options.
-- This should only be used for project with Custom setups that are older than lib:Cabal 3.16.
cabalWithGhcShimWrapperSingleTarget = cabalLoadFilesBefore315 l cacheDir progVersions projectFile workDir (demoteToSingleLoadModeTarget cabalArgs)
cabalProc <- case cabalFeatures of
CabalWithRepl -> cabalWithReplProc
CabalWithGhcShimWrapper -> cabalWithGhcShimWrapper
loadResult <- getCabalGhcOptions cabalProc
case loadResult of
-- Some fallback
Left (_, _, details)
-- Used for @cabal >= 3.15@ but @lib:Cabal <3.15@, in custom setups.
| isCabalLibraryInProjectTooOld (processStderr details) -> do
liftIO $ l <& WithSeverity (LogWithReplNotSupported (processStderr details)) Debug
shimResult <- getCabalGhcOptions =<< cabalWithGhcShimWrapper
case shimResult of
Left (_, _, shimDetails)
| checkKeepTempFilesIsNotSupported shimDetails -> do
liftIO $ l <& WithSeverity (LogKeepTempFilesNotSupported (processStdout shimDetails <> processStderr shimDetails)) Debug
getCabalGhcOptions =<< cabalWithGhcShimWrapperSingleTarget
_ ->
pure shimResult
| checkKeepTempFilesIsNotSupported details -> do
liftIO $ l <& WithSeverity (LogKeepTempFilesNotSupported (processStdout details <> processStderr details)) Debug
getCabalGhcOptions =<< cabalWithGhcShimWrapperSingleTarget
Left codeAndDetails -> do
pure $ Left codeAndDetails
Right argsAndDetails ->
pure $ Right argsAndDetails
getCabalGhcOptions cabalProc = do
(ex, output, stde, [(_, maybeArgs)]) <- liftIO $ Process.readProcessWithOutputs [hie_bios_output] l workDir cabalProc
let args = fromMaybe [] maybeArgs
let errorDetails = ProcessErrorDetails
{ processCmd = cmdspec cabalProc
, processStdout = output
, processStderr = stde
, processGhcOptions = args
, processHieBiosEnvironment = hieBiosProcessEnv cabalProc
}
case ex of
ExitFailure code -> do
pure $ Left (cabalProc, code, errorDetails)
ExitSuccess ->
pure $ Right (args, errorDetails)
checkKeepTempFilesIsNotSupported details =
-- See https://github.com/haskell/cabal/issues/12178 why we check stdout and stderr.
-- This is a forward compatible check to make sure this won't break accidentally in the future once
-- this ticket is fixed.
isKeepTempFilesNotSupported (processStdout details) || isKeepTempFilesNotSupported (processStderr details)
runCabalGhcCmd :: ResolvedCradles a -> FilePath -> LogAction IO (WithSeverity Log) -> CradleProjectConfig -> [String] -> IO (CradleLoadResult String)
runCabalGhcCmd cs wdir l projectFile args = runCradleResultT $ do
let vs = cradleProgramVersions cs
callCabalPathForCompilerPath l (cradleCacheDirResolved cs) vs wdir projectFile >>= \case
Just p -> Process.readProcessWithCwd_ l wdir p args ""
Nothing -> do
buildDir <- liftIO $ cabalBuildDir (cradleCacheDirResolved cs) wdir
-- Workaround for a cabal-install bug on 3.0.0.0:
-- ./dist-newstyle/tmp/environment.-24811: createDirectory: does not exist (No such file or directory)
liftIO $ createDirectoryIfMissing True (buildDir </> "tmp")
-- Need to pass -v0 otherwise we get "resolving dependencies..."
cabalProc <- cabalExecGhc l (cradleCacheDirResolved cs) vs projectFile wdir args
Process.readProcessWithCwd' l cabalProc ""
processCabalLoadMode :: MonadIO m => LogAction IO (WithSeverity Log) -> ResolvedCradles a -> ProgramVersions -> CradleProjectConfig -> [Char] -> Maybe FilePath -> TargetWithContext -> LoadMode -> m (LoadModeTargets, [FilePath], [FilePath])
processCabalLoadMode l cradles progVersions projectFile workDir mc fpc loadStyle = do
usesResponseFiles <- usesResponseFilesForAllGhcOptions progVersions
(cabalArgs, loadingFiles, extraDeps) <- case loadStyle of
LoadFile -> pure (SingleTarget fpModule usesResponseFiles, [fp], [])
LoadFileWithContext -> do
let fps = targetContext fpc
(modPairs, mergedDeps) <- moduleFilesFromSameProject fps
let
extraModules = fmap fst modPairs
allFiles = fp : fmap snd modPairs
pure (MultipleTargets fpModule extraModules NoExtraComponents usesResponseFiles, allFiles, mergedDeps)
LoadUnitsInferred -> loadUnits usesResponseFiles Inferred
LoadUnitsFromCradle -> loadUnits usesResponseFiles FromCradle
liftIO $ l <& LogComputedCradleLoadMode "cabal" fpc loadStyle `WithSeverity` Info
liftIO $ l <& LogCabalLoad fp mc (prefix <$> resolvedCradles cradles) loadingFiles `WithSeverity` Debug
pure (cabalArgs, nubOrd loadingFiles, extraDeps)
where
fpModule = fromMaybe (fixTargetPath fp) mc
fp = targetFilePath fpc
-- Need to make relative on Windows, due to a Cabal bug with how it
-- parses file targets with a C: drive in it. So we decide to make
-- the paths relative to the working directory.
fixTargetPath x
| isWindows && hasDrive x = makeRelative workDir x
| otherwise = x
-- 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)
cabalComponentsFromSameProject :: MonadIO m => Maybe [String] -> m ([String],[FilePath])
cabalComponentsFromSameProject mToLoad = do
let selected =
[ (comp, prefix rc, depsYaml)
| rc@(ResolvedCradle {concreteCradle = ConcreteCabal ct, cradleDeps = depsYaml}) <- (resolvedCradles cradles)
, Just comp <- [cabalComponent ct]
, maybe True (comp `elem`) mToLoad
, (projectConfigFromMaybe (cradleRoot cradles) (cabalProjectFile ct)) == projectFile
]
let compDirs = nubOrd $ [dir | (_,dir,_) <- selected]
dynDeps <- concatMapM (liftIO . cabalCradleDependenciesEnclosing projectFile (cradleRoot cradles)) compDirs
let mergedDeps = nubOrd $ dynDeps ++ concat [ depsYaml | (_, _, depsYaml) <- selected ]
pure ([comp | (comp,_,_) <- selected], mergedDeps)
loadUnits usesResponseFiles whichUnits0 = do
let
componentsToLoad = do
guard (whichUnits0 == FromCradle)
nubOrd <$> mconcat
[ cs
| ResolvedCradle{concreteCradle = ConcreteCabal
(CabalType {cabalComponentsToLoad = cs})} <- resolvedCradles cradles ]
-- compDeps includes the .cabal files of the specified components (if the prefixes are there and accurate)
-- These are used as dependencies for both Inferred and FromCradle modes.
-- They might not be accurate for `Inferred`, but we have no easy way to query the cabal project for the complete set.
(cradleComponents,compDeps) <- cabalComponentsFromSameProject componentsToLoad
let
whichUnits
| Just units <- componentsToLoad
= (whichUnits0, units)
-- Note we default to Inferred only if componentsToLoad is not declared.
| null cradleComponents = (Inferred , [])
| otherwise = (whichUnits0, cradleComponents)
let fps = targetContext fpc
(modPairs, mergedDeps0) <- moduleFilesFromSameProject fps
let
extraModules = nubOrd $ fmap fst modPairs
allFiles = nubOrd $ fp : fmap snd modPairs
let mergedDeps = mergedDeps0 ++ compDeps
let
extraComponents = case fst whichUnits of
Inferred -> case projectFile of
NoExplicitConfig -> LoadTestsAndBenchmarks
ExplicitConfig{} -> NoExtraComponents
FromCradle -> NoExtraComponents
withExtraTargets targetFiles = case whichUnits of
(Inferred, _) -> "all" : targetFiles
(FromCradle, units) -> units ++ targetFiles
pure (MultipleTargets fpModule (withExtraTargets extraModules) extraComponents usesResponseFiles, fp:allFiles, mergedDeps)
cabalLoadFilesWithRepl :: LogAction IO (WithSeverity Log) -> CacheDir -> CradleProjectConfig -> FilePath -> LoadModeTargets -> CradleLoadResultT IO CreateProcess
cabalLoadFilesWithRepl l cacheDir projectFile workDir args = do
buildDir <- liftIO $ cabalBuildDir cacheDir workDir
newEnvironment <- liftIO Process.getCleanEnvironment
wrapper_fp <- liftIO $ withReplWrapperTool l cacheDir (proc "ghc") workDir
let
cabalCommand = "v2-repl"
cabalArgs =
-- Don't clobber the user's 'dist-newstyle': pass --builddir (#501)
[ "--builddir=" <> buildDir
, cabalCommand, "--with-repl", wrapper_fp
] <> projectFileProcessArgs projectFile <> renderLoadModeTargets CabalWithRepl args
pure $
(proc "cabal" cabalArgs)
{ env = Just newEnvironment
, cwd = Just workDir
}
-- | @'cabalCradleDependencies' projectFile rootDir componentDir@.
-- Compute the dependencies of the cabal cradle based
-- on cabal project configuration, the cradle root and the component directory.
--
-- The @projectFile@ and @projectFile <> ".local"@ are always added to the list
-- of dependencies.
--
-- Directory 'componentDir' is a sub-directory where we look for
-- package specific cradle dependencies, such as a '.cabal' file.
--
-- Found dependencies are relative to 'rootDir'.
cabalCradleDependencies :: CradleProjectConfig -> FilePath -> FilePath -> IO [FilePath]
cabalCradleDependencies projectFile rootDir componentDir = do
let relFp = makeRelative rootDir componentDir
cabalFiles' <- findCabalFiles componentDir
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
(dir: ghc_args) ->
let final_args =
removeVerbosityOpts
$ removeRTS
$ removeInteractive ghc_args
in Just (dir, final_args)
_ -> Nothing
-- ----------------------------------------------------------------------------
-- Legacy cabal commands to obtain ghc-options.
-- These commands are obsolete in the latest cabal version, but we still support
-- them.
-- ----------------------------------------------------------------------------
cabalLoadFilesBefore315 :: LogAction IO (WithSeverity Log) -> CacheDir -> ProgramVersions -> CradleProjectConfig -> [Char] -> LoadModeTargets -> CradleLoadResultT IO CreateProcess
cabalLoadFilesBefore315 l cacheDir progVersions projectFile workDir args = do
let cabalCommand = "v2-repl"
cabalProcess l cacheDir progVersions projectFile workDir cabalCommand (renderLoadModeTargets CabalWithGhcShimWrapper args) `modCradleError` \err -> do
deps <- cabalCradleDependencies projectFile workDir workDir
pure $ err {cradleErrorDependencies = cradleErrorDependencies err ++ deps}
-- | Execute a cabal process in our custom cache-build directory configured
-- with the custom ghc executable.
-- The created process has its working directory set to the given working directory.
--
-- Invokes the cabal process in the given directory.
-- Finds the appropriate @ghc@ version as a fallback and provides the path
-- to the custom ghc wrapper via 'hie_bios_ghc' environment variable which
-- the custom ghc wrapper may use as a fallback if it can not respond to certain
-- queries, such as ghc version or location of the libdir.
cabalProcess :: LogAction IO (WithSeverity Log) -> CacheDir -> ProgramVersions -> CradleProjectConfig -> FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess
cabalProcess l cacheDir vs cabalProject workDir command args = do
ghcDirs@(ghcBin, libdir) <- callCabalPathForCompilerPath l cacheDir vs workDir cabalProject >>= \case
Just p -> do
libdir <- Process.readProcessWithCwd_ l workDir p ["--print-libdir"] ""
pure (p, trimEnd libdir)
Nothing -> cabalGhcDirs l cabalProject workDir
ghcPkgPath <- liftIO $ withGhcPkgTool cacheDir ghcBin libdir
newEnvironment <- liftIO $ setupEnvironment ghcDirs
cabalProc <- liftIO $ setupCabalCommand ghcPkgPath
pure $ (cabalProc
{ env = Just newEnvironment
, cwd = Just workDir
})
where
processEnvironment :: (FilePath, FilePath) -> [(String, String)]
processEnvironment (ghcBin, libdir) =
[(hie_bios_ghc, ghcBin), (hie_bios_ghc_args, "-B" ++ libdir)]
setupEnvironment :: (FilePath, FilePath) -> IO [(String, String)]
setupEnvironment ghcDirs = do
environment <- Process.getCleanEnvironment
pure $ processEnvironment ghcDirs ++ environment
setupCabalCommand :: FilePath -> IO CreateProcess
setupCabalCommand ghcPkgPath = do
wrapper_fp <- withGhcWrapperTool l cacheDir (proc "ghc") workDir
buildDir <- cabalBuildDir cacheDir workDir
let extraCabalArgs =
[ "--builddir=" <> buildDir
, command
, "--with-compiler", wrapper_fp
, "--with-hc-pkg", ghcPkgPath
]
<> projectFileProcessArgs cabalProject
pure $ proc "cabal" (extraCabalArgs ++ args)
-- | Discover the location of the ghc binary 'cabal' is going to use together
-- with its libdir location.
-- The ghc executable is an absolute path, but not necessarily canonicalised
-- or normalised. Additionally, the ghc path returned is likely to be the raw
-- executable, i.e. without the usual wrapper shims on non-windows systems.
-- If you want to use the given ghc executable, you should invoke
-- 'withGhcWrapperTool'.
--
-- If cabal can not figure it out, a 'CradleError' is returned.
cabalGhcDirs :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> CradleLoadResultT IO (FilePath, FilePath)
cabalGhcDirs l cabalProject workDir = do
libdir <- Process.readProcessWithCwd_ l workDir "cabal"
(["exec"] ++
projectFileArgs ++
["-v0", "--", "ghc", "--print-libdir"]
)
""
exe <- Process.readProcessWithCwd_ l workDir "cabal"
-- DON'T TOUCH THIS CODE
-- This works with 'NoImplicitPrelude', with 'RebindableSyntax' and other shenanigans.
-- @-package-env=-@ doesn't work with ghc prior 8.4.x
([ "exec"] ++
projectFileArgs ++
[ "-v0", "--" , "ghc", "-package-env=-", "-ignore-dot-ghci", "-e"
, "Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"
]
)
""
pure (trimEnd exe, trimEnd libdir)
where
projectFileArgs = projectFileProcessArgs cabalProject
-- | Discovers the location of 'ghc-pkg' given the absolute path to 'ghc'
-- and its '$libdir' (obtainable by running @ghc --print-libdir@).
--
-- @'withGhcPkgTool' ghcPathAbs libdir@ guesses the location by looking at
-- the filename of 'ghcPathAbs' and expects that 'ghc-pkg' is right next to it,
-- which is guaranteed by the ghc build system. Most OS's follow this
-- convention.
--
-- On unix, there is a high-chance that the obtained 'ghc' location is the
-- "unwrapped" executable, e.g. the executable without a shim that specifies
-- the '$libdir' and other important constants.
-- As such, the executable 'ghc-pkg' is similarly without a wrapper shim and
-- is lacking certain constants such as 'global-package-db'. It is, therefore,
-- not suitable to pass in to other consumers, such as 'cabal'.
--
-- Here, we restore the wrapper-shims, if necessary, thus the returned filepath
-- can be passed to 'cabal' without further modifications.
withGhcPkgTool :: CacheDir -> FilePath -> FilePath -> IO FilePath
withGhcPkgTool cacheDir ghcPathAbs libdir = do
let ghcName = takeFileName ghcPathAbs
-- TODO: check for existence
ghcPkgPath = guessGhcPkgFromGhc ghcName
if isWindows
then pure ghcPkgPath
else withGhcPkgShim ghcPkgPath
where
ghcDir = takeDirectory ghcPathAbs
guessGhcPkgFromGhc ghcName =
let ghcPkgName = T.replace "ghc" "ghc-pkg" (T.pack ghcName)
in ghcDir </> T.unpack ghcPkgName
-- Only on unix, creates a wrapper script that's hopefully identical
-- to the wrapper script 'ghc-pkg' usually comes with.
--
-- 'ghc-pkg' needs to know the 'global-package-db' location which is
-- passed in via a wrapper shim that basically wraps 'ghc-pkg' and
-- only passes in the correct 'global-package-db'.
-- For an example on how the wrapper script is supposed to look like, take
-- a look at @cat $(which ghc-pkg)@, assuming 'ghc-pkg' is on your $PATH.
--
-- If we used the raw executable, i.e. not wrapped in a shim, then 'cabal'
-- can not use the given 'ghc-pkg'.
withGhcPkgShim ghcPkg = do
let globalPackageDb = libdir </> "package.conf.d"
-- This is the same as the wrapper-shims ghc-pkg usually comes with.
contents = unlines
[ "#!/bin/sh"
, unwords ["exec", escapeFilePath ghcPkg
, "--global-package-db", escapeFilePath globalPackageDb
, "${1+\"$@\"}"
]
]
srcHash = show (fingerprintString contents)
cacheFileIn cacheDir "ghc-pkg" srcHash $ \wrapperFp -> writeFile wrapperFp contents
-- Escape the filepath and trim excess newlines added by 'escapeArgs'
escapeFilePath fp = trimEnd $ escapeArgs [fp]
-- ----------------------------------------------------------------------------
-- Wrapper Tools
-- ----------------------------------------------------------------------------
-- | GHC process that accepts GHC arguments.
type GhcProc = [String] -> CreateProcess
-- | Generate a fake GHC that can be passed to cabal or stack
-- when run with --interactive, it will print out its
-- command-line arguments and exit
withGhcWrapperTool :: LogAction IO (WithSeverity Log) -> CacheDir -> GhcProc -> FilePath -> IO FilePath
withGhcWrapperTool l cacheDir mkGhcCall wdir = do
withWrapperTool l cacheDir mkGhcCall wdir "wrapper" cabalWrapperHs cabalWrapper
-- | Generate a script/binary that can be passed to cabal's '--with-repl'.
-- On windows, this compiles a Haskell file, while on other systems, we persist
-- a haskell source file and ad-hoc compile it with 'GhcProc'.
--
-- 'GhcProc' is unused on other platforms.
--
withReplWrapperTool :: LogAction IO (WithSeverity Log) -> CacheDir -> GhcProc -> FilePath -> IO FilePath
withReplWrapperTool l cacheDir mkGhcCall wdir =
withWrapperTool l cacheDir mkGhcCall wdir "repl-wrapper" cabalWithReplWrapperHs cabalWithReplWrapper
withWrapperTool :: LogAction IO (WithSeverity Log) -> CacheDir -> GhcProc -> String -> FilePath -> String -> String -> IO FilePath
withWrapperTool l cacheDir mkGhcCall wdir baseName windowsWrapper unixWrapper = do
let wrapperContents = if isWindows then windowsWrapper else unixWrapper
withExtension fp = if isWindows then fp <.> "exe" else fp
srcHash = show (fingerprintString wrapperContents)
cacheFileIn cacheDir (withExtension baseName) srcHash $ \wrapper_fp ->
if isWindows
then
withSystemTempDirectory "hie-bios" $ \ tmpDir -> do
let wrapper_hs = wrapper_fp -<.> "hs"
writeFile wrapper_hs wrapperContents
let ghcArgs = ["-rtsopts=ignore", "-outputdir", tmpDir, "-o", wrapper_fp, wrapper_hs]
let ghcProc = (mkGhcCall ghcArgs)
{ cwd = Just wdir
}
l <& LogCreateProcessRun ghcProc `WithSeverity` Debug
readCreateProcess ghcProc "" >>= putStr
else writeFile wrapper_fp wrapperContents
-- ----------------------------------------------------------------------------
-- 'cabal.project' options
-- ----------------------------------------------------------------------------
projectFileProcessArgs :: CradleProjectConfig -> [String]
projectFileProcessArgs (ExplicitConfig prjFile) = ["--project-file", prjFile]
projectFileProcessArgs NoExplicitConfig = []
projectLocationOrDefault :: CradleProjectConfig -> [FilePath]
projectLocationOrDefault = \case
NoExplicitConfig -> ["cabal.project", "cabal.project.local"]
(ExplicitConfig prjFile) -> [prjFile, prjFile <.> "local"]
-- ----------------------------------------------------------------------------
-- cabal locations
-- ----------------------------------------------------------------------------
-- | Given the cache root and the work directory, get the build dir we are
-- using for cabal.
cabalBuildDir :: CacheDir -> FilePath -> IO FilePath
cabalBuildDir (CacheDir cacheDir) workDir = do
abs_work_dir <- makeAbsolute workDir
let dirHash = show (fingerprintString abs_work_dir)
pure $ cacheDir </> ("dist-" <> filter (not . isSpace) (takeBaseName abs_work_dir)<>"-"<>dirHash)
-- |Find .cabal files in the given directory.
--
-- Might return multiple results,biosAction as we can not know in advance
-- which one is important to the user.
findCabalFiles :: FilePath -> IO [FilePath]
findCabalFiles wdir = do
dirContent <- listDirectory wdir
return $ filter ((== ".cabal") . takeExtension) dirContent
-- ----------------------------------------------------------------------------
-- cabal process wrappers and helpers
-- ----------------------------------------------------------------------------
cabalExecGhc :: LogAction IO (WithSeverity Log) -> CacheDir -> ProgramVersions -> CradleProjectConfig -> FilePath -> [String] -> CradleLoadResultT IO CreateProcess
cabalExecGhc l cacheDir vs projectFile wdir args = do
cabalProcess l cacheDir vs projectFile wdir "v2-exec" $ ["ghc", "-v0", "--"] ++ args
callCabalPathForCompilerPath :: LogAction IO (WithSeverity Log) -> CacheDir -> ProgramVersions -> FilePath -> CradleProjectConfig -> CradleLoadResultT IO (Maybe FilePath)
callCabalPathForCompilerPath l cacheDir vs workDir projectFile = do
isCabalPathSupported vs >>= \case
False -> pure Nothing
True -> do
buildDir <- liftIO $ cabalBuildDir cacheDir workDir
let
args = [ "--builddir=" <> buildDir, "path", "--output-format=json" ]
<> projectFileProcessArgs projectFile
bs = BS.fromStrict . T.encodeUtf8 . T.pack
parse_compiler_path = Aeson.parseEither ((.: "compiler") >=> (.: "path")) <=< Aeson.eitherDecode
compiler_info <- Process.readProcessWithCwd_ l workDir "cabal" args ""
case parse_compiler_path (bs compiler_info) of
Left err -> do
liftIO $ l <& WithSeverity (LogCabalPath $ T.pack err) Warning
pure Nothing
Right a -> pure a
-- ----------------------------------------------------------------------------
-- Version and cabal capability checks
-- ----------------------------------------------------------------------------
data LoadUnits = Inferred | FromCradle
deriving Eq
data WithTestsAndBenchmarks
= NoExtraComponents
| LoadTestsAndBenchmarks
data LoadModeTargets
= SingleTarget
String
-- ^ Main Target FilePath or component
UsesResponseFiles
-- ^ Is this going to use top-level response files?
| MultipleTargets
String
-- ^ Main Target FilePath or component
[String]
-- ^ Extra targets to load alongside the main component
WithTestsAndBenchmarks
-- ^ Should we enable tests and benchmarks as well?
UsesResponseFiles
-- ^ Is this going to use top-level response files?
loadModeUsesResponseFiles :: LoadModeTargets -> UsesResponseFiles
loadModeUsesResponseFiles = \ case
SingleTarget _ usesResponseFiles -> usesResponseFiles
MultipleTargets _ _ _ usesResponseFiles -> usesResponseFiles
demoteToSingleLoadModeTarget :: LoadModeTargets -> LoadModeTargets
demoteToSingleLoadModeTarget (MultipleTargets mainTarget _ _ _) = SingleTarget mainTarget NoResponseFiles
demoteToSingleLoadModeTarget (SingleTarget mainTarget _) = SingleTarget mainTarget NoResponseFiles
data CabalLoadFeature
= CabalWithRepl
| CabalWithGhcShimWrapper
data UsesResponseFiles
= UsesResponseFiles
| NoResponseFiles
determineCabalLoadFeature :: MonadIO m => ProgramVersions -> m CabalLoadFeature
determineCabalLoadFeature vs = do
cabal_version <- liftIO $ runCachedIO $ cabalVersion vs
-- determine which load style is supported by this cabal cradle.
case cabal_version of
Just ver
| ver >= makeVersion [3, 15] -> pure CabalWithRepl
| otherwise -> pure CabalWithGhcShimWrapper
_ -> pure CabalWithGhcShimWrapper
-- | As `cabal repl` started to hit maximum cli invocation length, we changed how repl arguments are
-- passed to GHC. In `cabal 3.15`, `cabal 3.16.0.0`, `cabal 3.17` and onwards, ghc options are
-- passed to GHC via response files.
--
-- This breaks HLS release binary distributions before 2.12, as neither HLS nor hie-bios are capable of handling
-- response files at the top-level.
--
-- In particular, `cabal 3.16.0.0` was released with this change and no HLS bindist before 2.12 works
-- with `cabal 3.16.0.0`.
-- To make `cabal 3.16.*` series compatible with released HLS binaries, we reverted the response file
-- change for the ghc options. This change will apply once `cabal 3.16.1.*` is released.
-- Note, in `cabal 3.17`, i.e. cabal HEAD, we still pass the arguments via response files and will do that for the
-- `cabal 3.18` release.
--
-- So, we have a weird matrix now, between some commit in `cabal 3.15` and `cabal 3.16`, ghc arguments
-- are supplied encoded in a response file, while in `>= cabal 3.16.1`, the arguments are passed verbatim.
-- Then, later on in `cabal-3.17`, we use response files again.
--
-- 'usesResponseFilesForAllGhcOptions' encodes all of this history.
usesResponseFilesForAllGhcOptions :: MonadIO m => ProgramVersions -> m UsesResponseFiles
usesResponseFilesForAllGhcOptions vs = do
cabal_version <- liftIO $ runCachedIO $ cabalVersion vs
-- determine which load style is supported by this cabal cradle.
case cabal_version of
Just ver
| ver >= makeVersion [3, 15] && ver <= makeVersion [3, 16, 0, 0] -> pure UsesResponseFiles
| ver >= makeVersion [3, 17] -> pure UsesResponseFiles
| otherwise -> pure NoResponseFiles
_ -> pure NoResponseFiles
renderResponseFileArgs :: UsesResponseFiles -> [[Char]]
renderResponseFileArgs = \ case
UsesResponseFiles -> ["--keep-temp-files"]
NoResponseFiles -> []
-- | When @cabal repl --with-repl@ is called in a project with a custom setup which forces
-- an older @lib:Cabal@ version, then the error message looks roughly like:
--
-- @
-- Error: [Cabal-7107]
-- Could not resolve dependencies:
-- [__0] trying: cabal-with-custom-setup-0.1.0.0 (user goal)
-- [__1] next goal: cabal-with-custom-setup:setup.Cabal (dependency of cabal-with-custom-setup)
-- [__1] rejecting: cabal-with-custom-setup:setup.Cabal; 3.10.3.0/installed-3.10.3.0, ... (constraint from --with-repl requires >=3.15)
-- ...
-- @
--
-- We do a quick and dirty string comparison to check whether the error message looks like it has been caused
-- by using a @lib:Cabal@ version that doesn't support the @--with-repl@ flag.
isCabalLibraryInProjectTooOld :: [String] -> Bool
isCabalLibraryInProjectTooOld stderr =
any ("constraint from --with-repl requires >=3.15" `isInfixOf`) stderr
-- | Some @cabal@ versions don't support @--keep-temp-files@
--
-- @
-- Configuring a-with-custom-0.1.0.0...
-- unrecognized 'repl' option `--keep-temp-files'
-- @
--
-- Can also occur with 'configure'.
--
-- We do a quick and dirty string comparison to check whether the error message looks like it has been caused
-- by using a @--keep-temp-files@ version that doesn't support the @--keep-temp-files@ flag.
isKeepTempFilesNotSupported :: [String] -> Bool
isKeepTempFilesNotSupported stderr =
any (\ line -> all (`isInfixOf` line) ["unrecognized", "option `--keep-temp-files'"]) stderr
isCabalPathSupported :: MonadIO m => ProgramVersions -> m Bool
isCabalPathSupported vs = do
v <- liftIO $ runCachedIO $ cabalVersion vs
pure $ maybe False (>= makeVersion [3,14]) v
isCabalMultipleCompSupported :: MonadIO m => ProgramVersions -> m Bool
isCabalMultipleCompSupported vs = do
cabal_version <- liftIO $ runCachedIO $ cabalVersion vs
ghc_version <- liftIO $ runCachedIO $ ghcVersion vs
-- determine which load style is supported by this cabal cradle.
case (cabal_version, ghc_version) of
(Just cabal, Just ghc) -> pure $ ghc >= makeVersion [9, 4] && cabal >= makeVersion [3, 11]
_ -> pure False
renderWithTestsAndBenchmarks :: WithTestsAndBenchmarks -> [String]
renderWithTestsAndBenchmarks = \ case
NoExtraComponents -> []
LoadTestsAndBenchmarks -> ["--enable-tests", "--enable-benchmarks"]
renderLoadModeTargets :: CabalLoadFeature -> LoadModeTargets -> [String]
renderLoadModeTargets CabalWithGhcShimWrapper = \ case
SingleTarget fp usesResponseFiles ->
-- If cabal version is recent enough, we even need to pass '--keep-temp-files'
-- when loading a single target
fp : renderResponseFileArgs usesResponseFiles
MultipleTargets mainTarget targets withTestsAndBenchmarks _usesResponseFiles ->
"--enable-multi-repl" : "--keep-temp-files" : renderWithTestsAndBenchmarks withTestsAndBenchmarks ++ nubOrd (mainTarget:targets)
renderLoadModeTargets CabalWithRepl = \ case
SingleTarget fp _usesResponseFiles ->
-- We need to pass `--keep-temp-files` here as well as `with-repl` will invoke the script with a response file.
["--keep-temp-files", fp]
MultipleTargets mainTarget targets withTestsAndBenchmarks _usesResponseFiles ->
"--enable-multi-repl" : "--keep-temp-files" : renderWithTestsAndBenchmarks withTestsAndBenchmarks ++ nubOrd (mainTarget:targets)