diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,21 @@ # ChangeLog hie-bios +* Rename `findFileUpwards` as `findFileUpwardsPredicate` and implement + `findFileUpward` which does have better performance guarantees. + +## 2025-07-09 - 0.16.0 + +### Bugfix + +* Always specify '--with-hc-pkg' with cabal [#465](https://github.com/haskell/hie-bios/pull/465) + +### Changes + +* Add regression test for [hie-bios/pull/465](https://github.com/haskell/hie-bios/pull/465) [#468](https://github.com/haskell/hie-bios/pull/468) +* Cabal cradle needs to use --with-repl option [#466](https://github.com/haskell/hie-bios/pull/466) +* fix: rewrite findFileUpwards as a non predicate function [#464](https://github.com/haskell/hie-bios/pull/464) +* Add support for bios multi-cradles [#437](https://github.com/haskell/hie-bios/pull/437) + ## 2025-04-25 - 0.15.0 * Use consistent logging for test cases [#461](https://github.com/haskell/hie-bios/pull/461) 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.15.0 +Version: 0.16.0 Author: Matthew Pickering Maintainer: Matthew Pickering License: BSD-3-Clause @@ -15,18 +15,20 @@ extra-doc-files: ChangeLog.md Extra-Source-Files: README.md wrappers/cabal + wrappers/cabal-with-repl wrappers/cabal.hs + wrappers/cabal-with-repl.hs tests/configs/*.yaml tests/projects/cabal-with-ghc/cabal-with-ghc.cabal tests/projects/cabal-with-ghc/cabal.project tests/projects/cabal-with-ghc/hie.yaml tests/projects/cabal-with-ghc/src/MyLib.hs tests/projects/cabal-with-ghc-and-project/cabal-with-ghc.cabal - tests/projects/cabal-with-ghc-and-project/cabal.project.9.2.8 + tests/projects/cabal-with-ghc-and-project/cabal.project.extra tests/projects/cabal-with-ghc-and-project/hie.yaml tests/projects/cabal-with-ghc-and-project/src/MyLib.hs tests/projects/cabal-with-project/cabal-with-project.cabal - tests/projects/cabal-with-project/cabal.project.9.2.8 + tests/projects/cabal-with-project/cabal.project.extra tests/projects/cabal-with-project/hie.yaml tests/projects/cabal-with-project/src/MyLib.hs tests/projects/symlink-test/a/A.hs @@ -47,7 +49,7 @@ tests/projects/multi-cabal-with-project/appA/src/Lib.hs tests/projects/multi-cabal-with-project/appB/appB.cabal tests/projects/multi-cabal-with-project/appB/src/Lib.hs - tests/projects/multi-cabal-with-project/cabal.project.9.2.8 + tests/projects/multi-cabal-with-project/cabal.project.extra tests/projects/multi-cabal-with-project/hie.yaml tests/projects/monorepo-cabal/cabal.project tests/projects/monorepo-cabal/hie.yaml @@ -144,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.4.8 || ==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 Library Default-Language: Haskell2010 @@ -154,9 +156,15 @@ HIE.Bios.Config HIE.Bios.Config.YAML HIE.Bios.Cradle + HIE.Bios.Cradle.Cabal + HIE.Bios.Cradle.ProgramVersions + HIE.Bios.Cradle.ProjectConfig + HIE.Bios.Cradle.Resolved + HIE.Bios.Cradle.Utils HIE.Bios.Environment HIE.Bios.Internal.Debug HIE.Bios.Flags + HIE.Bios.Process HIE.Bios.Types HIE.Bios.Ghc.Api HIE.Bios.Ghc.Check @@ -199,14 +207,14 @@ Main-Is: Main.hs Other-Modules: Paths_hie_bios autogen-modules: Paths_hie_bios - GHC-Options: -Wall + GHC-Options: -Wall +RTS -A32M -RTS HS-Source-Dirs: exe Build-Depends: base >= 4.16 && < 5 , co-log-core , directory , filepath , hie-bios - , optparse-applicative >= 0.18.1 && < 0.19 + , optparse-applicative >= 0.18.1 && < 0.20 , prettyprinter test-suite parser-tests diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -20,70 +19,45 @@ , isDefaultCradle , isOtherCradle , getCradle - , readProcessWithOutputs - , readProcessWithCwd + , Process.readProcessWithOutputs + , Process.readProcessWithCwd , makeCradleResult -- | Cradle project configuration types , CradleProjectConfig(..) - - -- expose to tests - , makeVersions - , isCabalMultipleCompSupported - , ProgramVersions ) where -import Control.Applicative ((<|>), optional) -import Control.DeepSeq -import Control.Exception (handleJust) -import qualified Data.Yaml as Yaml -import Data.Void -import Data.Char (isSpace) -import System.Exit -import System.Directory hiding (findFile) import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) +import Control.Applicative ((<|>)) import Control.Monad -import Control.Monad.Extra (unlessM) +import Control.Monad.IO.Class import Control.Monad.Trans.Cont import Control.Monad.Trans.Maybe -import Control.Monad.IO.Class -import Data.Aeson ((.:)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson +import qualified Data.Yaml as Yaml +import Data.Version +import Data.Void import Data.Bifunctor (first) -import qualified Data.ByteString as BS import Data.Conduit.Process -import qualified Data.Conduit.Combinators as C -import qualified Data.Conduit as C -import qualified Data.Conduit.Text as C -import qualified Data.HashMap.Strict as Map -import Data.Maybe (fromMaybe, maybeToList) +import Data.Maybe (fromMaybe) import Data.List -import Data.List.Extra (trimEnd, nubOrd) import Data.Ord (Down(..)) import qualified Data.Text as T -import qualified Data.Text.Encoding as T import System.Environment +import System.Exit import System.FilePath -import System.PosixCompat.Files -import System.Info.Extra (isWindows) -import System.IO (hClose, hGetContents, hSetBuffering, BufferMode(LineBuffering), withFile, IOMode(..)) -import System.IO.Error (isPermissionError) +import System.Directory +import System.IO (hClose, hPutStr) import System.IO.Temp import HIE.Bios.Config -import HIE.Bios.Environment (getCacheDir) import HIE.Bios.Types hiding (ActionName(..)) -import HIE.Bios.Wrappers +import qualified HIE.Bios.Process as Process import qualified HIE.Bios.Types as Types import qualified HIE.Bios.Ghc.Gap as Gap - -import GHC.Fingerprint (fingerprintString) -import GHC.ResponseFile (escapeArgs) - -import Data.Version -import Data.IORef -import Text.ParserCombinators.ReadP (readP_to_S) -import Data.Tuple.Extra (fst3, snd3, thd3) +import HIE.Bios.Cradle.ProjectConfig +import HIE.Bios.Cradle.Utils +import HIE.Bios.Cradle.Cabal as Cabal +import HIE.Bios.Cradle.Resolved +import HIE.Bios.Cradle.ProgramVersions ---------------------------------------------------------------- @@ -129,93 +103,6 @@ where cs = resolveCradleTree wdir cc - --- | The actual type of action we will be using to process a file -data ConcreteCradle a - = ConcreteCabal CabalType - | ConcreteStack StackType - | ConcreteBios Callable (Maybe Callable) (Maybe FilePath) - | ConcreteDirect [String] - | ConcreteNone - | ConcreteOther a - deriving Show - - --- | ConcreteCradle augmented with information on which file the --- cradle applies -data ResolvedCradle a - = ResolvedCradle - { prefix :: FilePath -- ^ the prefix to match files - , cradleDeps :: [FilePath] -- ^ accumulated dependencies - , concreteCradle :: ConcreteCradle a - } deriving Show - --- | The final cradle config that specifies the cradle for --- each prefix we know how to handle -data ResolvedCradles a - = ResolvedCradles - { cradleRoot :: FilePath - , resolvedCradles :: [ResolvedCradle a] -- ^ In order of decreasing specificity - , cradleProgramVersions :: ProgramVersions - } - -data ProgramVersions = - ProgramVersions { cabalVersion :: CachedIO (Maybe Version) - , stackVersion :: CachedIO (Maybe Version) - , ghcVersion :: CachedIO (Maybe Version) - } - -newtype CachedIO a = CachedIO (IORef (Either (IO a) a)) - -makeCachedIO :: IO a -> IO (CachedIO a) -makeCachedIO act = CachedIO <$> newIORef (Left act) - -runCachedIO :: CachedIO a -> IO a -runCachedIO (CachedIO ref) = - readIORef ref >>= \case - Right x -> pure x - Left act -> do - x <- act - writeIORef ref (Right x) - pure x - -makeVersions :: LogAction IO (WithSeverity Log) -> FilePath -> ([String] -> IO (CradleLoadResult String)) -> IO ProgramVersions -makeVersions l wdir ghc = do - cabalVersion <- makeCachedIO $ getCabalVersion l wdir - stackVersion <- makeCachedIO $ getStackVersion l wdir - ghcVersion <- makeCachedIO $ getGhcVersion ghc - pure ProgramVersions{..} - -getCabalVersion :: LogAction IO (WithSeverity Log) -> FilePath -> IO (Maybe Version) -getCabalVersion l wdir = do - res <- readProcessWithCwd l wdir "cabal" ["--numeric-version"] "" - case res of - CradleSuccess stdo -> - pure $ versionMaybe stdo - _ -> pure Nothing - -getStackVersion :: LogAction IO (WithSeverity Log) -> FilePath -> IO (Maybe Version) -getStackVersion l wdir = do - res <- readProcessWithCwd l wdir "stack" ["--numeric-version"] "" - case res of - CradleSuccess stdo -> - pure $ versionMaybe stdo - _ -> pure Nothing - -getGhcVersion :: ([String] -> IO (CradleLoadResult String)) -> IO (Maybe Version) -getGhcVersion ghc = do - res <- ghc ["--numeric-version"] - case res of - CradleSuccess stdo -> - pure $ versionMaybe stdo - _ -> pure Nothing - -versionMaybe :: String -> Maybe Version -versionMaybe xs = case reverse $ readP_to_S parseVersion xs of - [] -> Nothing - (x:_) -> Just (fst x) - - addActionDeps :: [FilePath] -> CradleLoadResult ComponentOptions -> CradleLoadResult ComponentOptions addActionDeps deps = cradleLoadResult @@ -301,7 +188,7 @@ case concreteCradle cradle of ConcreteCabal t -> cabalCradle l cs root (cabalComponent t) (projectConfigFromMaybe root (cabalProjectFile t)) ConcreteStack t -> stackCradle l root (stackComponent t) (projectConfigFromMaybe root (stackYaml t)) - ConcreteBios bios deps mbGhc -> biosCradle l root bios deps mbGhc + ConcreteBios bios deps mbGhc -> biosCradle l cs root bios deps mbGhc ConcreteDirect xs -> directCradle l root xs ConcreteNone -> noneCradle ConcreteOther a -> buildCustomCradle a @@ -364,7 +251,7 @@ return (configDir configFileName) yamlConfigDirectory :: FilePath -> MaybeT IO FilePath -yamlConfigDirectory = findFileUpwards (configFileName ==) +yamlConfigDirectory = Process.findFileUpwards configFileName readCradleConfig :: Yaml.FromJSON b => FilePath -> IO (CradleConfig b) readCradleConfig yamlHie = do @@ -454,7 +341,7 @@ --------------------------------------------------------------- -- | The multi cradle selects a cradle based on the filepath - +-- -- Canonicalize the relative paths present in the multi-cradle and -- also order the paths by most specific first. In the cradle selection -- function we want to choose the most specific cradle possible. @@ -463,14 +350,6 @@ sortOn (Down . prefix) <$> mapM (\c -> (\abs_fp -> c {prefix = abs_fp}) <$> makeAbsolute (cur_dir prefix c)) cs -selectCradle :: (a -> FilePath) -> FilePath -> [a] -> Maybe a -selectCradle _ _ [] = Nothing -selectCradle k cur_fp (c: css) = - if k c `isPrefixOf` cur_fp - then Just c - else selectCradle k cur_fp css - - ------------------------------------------------------------------------- directCradle :: LogAction IO (WithSeverity Log) -> FilePath -> [String] -> CradleAction a @@ -489,39 +368,63 @@ -- | Find a cradle by finding an executable `hie-bios` file which will -- be executed to find the correct GHC options to use. -biosCradle :: LogAction IO (WithSeverity Log) -> FilePath -> Callable -> Maybe Callable -> Maybe FilePath -> CradleAction a -biosCradle l wdir biosCall biosDepsCall mbGhc +biosCradle :: LogAction IO (WithSeverity Log) -> ResolvedCradles b -> FilePath -> Callable -> Maybe Callable -> Maybe FilePath -> CradleAction a +biosCradle l rc wdir biosCall biosDepsCall mbGhc = CradleAction { actionName = Types.Bios - , runCradle = biosAction wdir biosCall biosDepsCall l - , runGhcCmd = \args -> readProcessWithCwd l wdir (fromMaybe "ghc" mbGhc) args "" + , runCradle = biosAction rc wdir biosCall biosDepsCall l + , runGhcCmd = \args -> Process.readProcessWithCwd l wdir (fromMaybe "ghc" mbGhc) args "" } biosWorkDir :: FilePath -> MaybeT IO FilePath -biosWorkDir = findFileUpwards (".hie-bios" ==) +biosWorkDir = Process.findFileUpwards ".hie-bios" biosDepsAction :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe Callable -> FilePath -> LoadStyle -> IO [FilePath] -biosDepsAction l wdir (Just biosDepsCall) fp _prevs = do - biosDeps' <- callableToProcess biosDepsCall (Just fp) -- TODO multi pass the previous files too - (ex, sout, serr, [(_, args)]) <- readProcessWithOutputs [hie_bios_output] l wdir biosDeps' +biosDepsAction l wdir (Just biosDepsCall) fp loadStyle = do + let fps = case loadStyle of + LoadFile -> [fp] + LoadWithContext old_fps -> fp : old_fps + (ex, sout, serr, [(_, args)]) <- + runContT (withCallableToProcess biosDepsCall fps) $ \biosDeps' -> + Process.readProcessWithOutputs [hie_bios_output] l wdir biosDeps' case ex of ExitFailure _ -> error $ show (ex, sout, serr) ExitSuccess -> return $ fromMaybe [] args biosDepsAction _ _ Nothing _ _ = return [] biosAction - :: FilePath + :: ResolvedCradles a + -> FilePath -> Callable -> Maybe Callable -> LogAction IO (WithSeverity Log) -> FilePath -> LoadStyle -> IO (CradleLoadResult ComponentOptions) -biosAction wdir bios bios_deps l fp loadStyle = do - logCradleHasNoSupportForLoadWithContext l loadStyle "bios" - bios' <- callableToProcess bios (Just fp) -- TODO pass all the files instead of listToMaybe +biosAction rc wdir bios bios_deps l fp loadStyle = do + ghc_version <- liftIO $ runCachedIO $ ghcVersion $ cradleProgramVersions rc + determinedLoadStyle <- case ghc_version of + Just ghc + -- Multi-component supported from ghc 9.4 + -- We trust the assertion for a bios program, as we have no way of + -- checking its version + | LoadWithContext _ <- loadStyle -> + if ghc >= makeVersion [9,4] + then pure loadStyle + else do + liftIO $ l <& WithSeverity + (LogLoadWithContextUnsupported "bios" + $ Just "ghc version is too old. We require `ghc >= 9.4`" + ) + Warning + pure LoadFile + _ -> pure LoadFile + let fps = case determinedLoadStyle of + LoadFile -> [fp] + LoadWithContext old_fps -> fp : old_fps (ex, _stdo, std, [(_, res),(_, mb_deps)]) <- - readProcessWithOutputs [hie_bios_output, hie_bios_deps] l wdir bios' + runContT (withCallableToProcess bios fps) $ \bios' -> + Process.readProcessWithOutputs [hie_bios_output, hie_bios_deps] l wdir bios' deps <- case mb_deps of Just x -> return x @@ -532,24 +435,42 @@ -- Removes all duplicates. return $ makeCradleResult (ex, std, wdir, fromMaybe [] res) deps [fp] -callableToProcess :: Callable -> Maybe String -> IO CreateProcess -callableToProcess (Command shellCommand) file = do +withCallableToProcess :: Callable -> [String] -> ContT a IO CreateProcess +withCallableToProcess (Command shellCommand) files = ContT $ \action -> do old_env <- getEnvironment - return $ (shell shellCommand) { env = (: old_env) . (,) hie_bios_arg <$> file } -callableToProcess (Program path) file = do + case files of + [] -> action $ (shell shellCommand) {env = Nothing} + (x : _) -> + runContT (withHieBiosMultiArg files) $ \multi_file -> do + let updated_env = Just $ + [ (hie_bios_multi_arg, multi_file) + , (hie_bios_arg, x) + ] ++ + old_env + action $ (shell shellCommand){env = updated_env} +withCallableToProcess (Program path) files = ContT $ \action -> do canon_path <- canonicalizePath path - return $ proc canon_path (maybeToList file) - ------------------------------------------------------------------------- + old_env <- getEnvironment + case files of + [] -> action $ (proc canon_path []){env = Nothing} + (x : _) -> + runContT (withHieBiosMultiArg files) $ \multi_file -> do + let updated_env = Just $ + (hie_bios_multi_arg, multi_file) : old_env + action $ (proc canon_path [x]){env = updated_env} -projectFileProcessArgs :: CradleProjectConfig -> [String] -projectFileProcessArgs (ExplicitConfig prjFile) = ["--project-file", prjFile] -projectFileProcessArgs NoExplicitConfig = [] +withHieBiosMultiArg :: [String] -> ContT a IO FilePath +withHieBiosMultiArg files = ContT $ \action -> do + withSystemTempFile hie_bios_multi_arg $ \file h -> do + case files of + [] -> hClose h >> action file + (f0 : rest) -> do + hPutStr h f0 + forM_ rest $ \f -> hPutStr h "\x00" >> hPutStr h f + hClose h + action file -projectLocationOrDefault :: CradleProjectConfig -> [FilePath] -projectLocationOrDefault = \case - NoExplicitConfig -> ["cabal.project", "cabal.project.local"] - (ExplicitConfig prjFile) -> [prjFile, prjFile <.> "local"] +------------------------------------------------------------------------ -- |Cabal Cradle -- Works for new-build by invoking `v2-repl`. @@ -558,442 +479,13 @@ = CradleAction { actionName = Types.Cabal , runCradle = \fp -> runCradleResultT . cabalAction cs wdir mc l projectFile fp - , runGhcCmd = \args -> runCradleResultT $ do - let vs = cradleProgramVersions cs - callCabalPathForCompilerPath l vs wdir projectFile >>= \case - Just p -> readProcessWithCwd_ l wdir p args "" - Nothing -> do - buildDir <- liftIO $ cabalBuildDir 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 <- cabalProcess l vs projectFile wdir "v2-exec" $ ["ghc", "-v0", "--"] ++ args - readProcessWithCwd' l cabalProc "" + , runGhcCmd = runCabalGhcCmd cs wdir l projectFile } - --- | 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) -> ProgramVersions -> CradleProjectConfig -> FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess -cabalProcess l vs cabalProject workDir command args = do - (ghcDirs, ghcPkgPath) <- callCabalPathForCompilerPath l vs workDir cabalProject >>= \case - Just p -> do - libdir <- readProcessWithCwd_ l workDir p ["--print-libdir"] "" - pure ((p, trimEnd libdir), Nothing) - Nothing -> do - ghcDirs@(ghcBin, libdir) <- cabalGhcDirs l cabalProject workDir - ghcPkgPath <- liftIO $ withGhcPkgTool ghcBin libdir - pure (ghcDirs, Just ghcPkgPath) - - 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 <- getCleanEnvironment - pure $ processEnvironment ghcDirs ++ environment - - setupCabalCommand :: Maybe FilePath -> IO CreateProcess - setupCabalCommand ghcPkgPath = do - wrapper_fp <- withGhcWrapperTool l ("ghc", []) workDir - buildDir <- cabalBuildDir workDir - let hcPkgArgs = case ghcPkgPath of - Nothing -> [] - Just p -> ["--with-hc-pkg", p] - - extraCabalArgs = - [ "--builddir=" <> buildDir - , command - , "--with-compiler", wrapper_fp - ] - <> hcPkgArgs - <> projectFileProcessArgs cabalProject - pure $ proc "cabal" (extraCabalArgs ++ args) - --- | 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 :: FilePath -> FilePath -> IO FilePath -withGhcPkgTool ghcPathAbs libdir = do - let ghcName = takeFileName ghcPathAbs - -- TODO: check for existence - ghcPkgPath = guessGhcPkgFromGhc ghcName - if isWindows - then pure ghcPkgPath - else withWrapperTool 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'. - withWrapperTool 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) - cacheFile "ghc-pkg" srcHash $ \wrapperFp -> writeFile wrapperFp contents - - -- Escape the filepath and trim excess newlines added by 'escapeArgs' - escapeFilePath fp = trimEnd $ escapeArgs [fp] - --- | @'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 - --- |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 - - -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 - --- | GHC process information. --- Consists of the filepath to the ghc executable and --- arguments to the executable. -type GhcProc = (FilePath, [String]) - --- | 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) -> GhcProc -> FilePath -> IO FilePath -withGhcWrapperTool l (mbGhc, ghcArgs) wdir = do - let wrapperContents = if isWindows then cabalWrapperHs else cabalWrapper - withExtension fp = if isWindows then fp <.> "exe" else fp - srcHash = show (fingerprintString wrapperContents) - cacheFile (withExtension "wrapper") srcHash $ \wrapper_fp -> - if isWindows - then - withSystemTempDirectory "hie-bios" $ \ tmpDir -> do - let wrapper_hs = wrapper_fp -<.> "hs" - writeFile wrapper_hs wrapperContents - let ghcArgsWithExtras = ghcArgs ++ ["-rtsopts=ignore", "-outputdir", tmpDir, "-o", wrapper_fp, wrapper_hs] - let ghcProc = (proc mbGhc ghcArgsWithExtras) - { cwd = Just wdir - } - l <& LogCreateProcessRun ghcProc `WithSeverity` Debug - readCreateProcess ghcProc "" >>= putStr - else writeFile wrapper_fp wrapperContents - --- | Create and cache a file in hie-bios's cache directory. --- --- @'cacheFile' fpName srcHash populate@. 'fpName' is the pattern name of the --- cached file you want to create. 'srcHash' is the hash that is appended to --- the file pattern and is expected to change whenever you want to invalidate --- the cache. --- --- If the cached file's 'srcHash' changes, then a new file is created, but --- the old cached file name will not be deleted. --- --- If the file does not exist yet, 'populate' is invoked with cached file --- location and it is expected that the caller persists the given filepath in --- the File System. -cacheFile :: FilePath -> String -> (FilePath -> IO ()) -> IO FilePath -cacheFile fpName srcHash populate = do - cacheDir <- getCacheDir "" - createDirectoryIfMissing True cacheDir - let newFpName = cacheDir (dropExtensions fpName <> "-" <> srcHash) <.> takeExtensions fpName - unlessM (doesFileExist newFpName) $ do - populate newFpName - setMode newFpName - pure newFpName - where - setMode wrapper_fp = setFileMode wrapper_fp accessModes - --- | Given the root directory, get the build dir we are using for cabal --- In the `hie-bios` cache directory -cabalBuildDir :: FilePath -> IO FilePath -cabalBuildDir workDir = do - abs_work_dir <- makeAbsolute workDir - let dirHash = show (fingerprintString abs_work_dir) - getCacheDir ("dist-" <> filter (not . isSpace) (takeBaseName abs_work_dir)<>"-"<>dirHash) - --- | 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 <- readProcessWithCwd_ l workDir "cabal" - (["exec"] ++ - projectFileArgs ++ - ["-v0", "--", "ghc", "--print-libdir"] - ) - "" - exe <- 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 - -callCabalPathForCompilerPath :: LogAction IO (WithSeverity Log) -> ProgramVersions -> FilePath -> CradleProjectConfig -> CradleLoadResultT IO (Maybe FilePath) -callCabalPathForCompilerPath l vs workDir projectFile = do - isCabalPathSupported vs >>= \case - False -> pure Nothing - True -> do - let - args = ["path", "--output-format=json"] <> projectFileProcessArgs projectFile - bs = BS.fromStrict . T.encodeUtf8 . T.pack - parse_compiler_path = Aeson.parseEither ((.: "compiler") >=> (.: "path")) <=< Aeson.eitherDecode - - compiler_info <- 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 - -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 - -cabalAction - :: ResolvedCradles a - -> FilePath - -> Maybe String - -> LogAction IO (WithSeverity Log) - -> CradleProjectConfig - -> FilePath - -> LoadStyle - -> CradleLoadResultT IO ComponentOptions -cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp loadStyle = do - multiCompSupport <- isCabalMultipleCompSupported vs - -- determine which load style is supported by this cabal cradle. - determinedLoadStyle <- case loadStyle of - LoadWithContext _ | not multiCompSupport -> do - liftIO $ - l - <& WithSeverity - ( LogLoadWithContextUnsupported "cabal" $ - Just "cabal or ghc version is too old. We require `cabal >= 3.11` and `ghc >= 9.4`" - ) - Warning - pure LoadFile - _ -> pure loadStyle - - let fpModule = fromMaybe (fixTargetPath fp) mc - let (cabalArgs, loadingFiles, extraDeps) = case determinedLoadStyle 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) - - liftIO $ l <& LogComputedCradleLoadStyle "cabal" determinedLoadStyle `WithSeverity` Info - liftIO $ l <& LogCabalLoad fp mc (prefix <$> cs) loadingFiles `WithSeverity` Debug - - let cabalCommand = "v2-repl" - - cabalProc <- - cabalProcess l vs projectFile workDir cabalCommand cabalArgs `modCradleError` \err -> do - deps <- cabalCradleDependencies projectFile workDir workDir - pure $ err {cradleErrorDependencies = cradleErrorDependencies err ++ deps} - - (ex, output, stde, [(_, maybeArgs)]) <- liftIO $ readProcessWithOutputs [hie_bios_output] l workDir cabalProc - let args = fromMaybe [] maybeArgs - - let errorDetails = - [ "Failed command: " <> prettyCmdSpec (cmdspec cabalProc), - unlines output, - unlines stde, - unlines args, - "Process Environment:" - ] - <> prettyProcessEnv cabalProc - - when (ex /= ExitSuccess) $ do - deps <- liftIO $ cabalCradleDependencies projectFile workDir workDir - let cmd = show (["cabal", cabalCommand] <> cabalArgs) - let errorMsg = "Failed to run " <> cmd <> " in directory \"" <> workDir <> "\". Consult the logs for full command and error." - throwCE (CradleError deps ex ([errorMsg] <> errorDetails) loadingFiles) - - 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 (deps <> extraDeps) ex (["Failed to parse result of calling cabal"] <> errorDetails) loadingFiles) - Just (componentDir, final_args) -> do - deps <- liftIO $ cabalCradleDependencies projectFile workDir componentDir - CradleLoadResultT $ pure $ makeCradleResult (ex, stde, componentDir, final_args) (deps <> extraDeps) loadingFiles - where - -- 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 - 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 cs], - -- Only include this file if the old component is in the same project - (projectConfigFromMaybe root (cabalProjectFile ct)) == projectFile, - let old_mc = cabalComponent ct - ] - -removeInteractive :: [String] -> [String] -removeInteractive = filter (/= "--interactive") - --- | Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. -data InRTS = OutsideRTS | InsideRTS - --- | Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. --- --- >>> removeRTS ["option1", "+RTS -H32m -RTS", "option2"] --- ["option1", "option2"] --- --- >>> removeRTS ["option1", "+RTS", "-H32m", "-RTS", "option2"] --- ["option1", "option2"] --- --- >>> removeRTS ["option1", "+RTS -H32m"] --- ["option1"] --- --- >>> removeRTS ["option1", "+RTS -H32m", "-RTS", "option2"] --- ["option1", "option2"] --- --- >>> removeRTS ["option1", "+RTS -H32m", "-H32m -RTS", "option2"] --- ["option1", "option2"] -removeRTS :: [String] -> [String] -removeRTS = go OutsideRTS - where - go :: InRTS -> [String] -> [String] - go _ [] = [] - go OutsideRTS (y:ys) - | "+RTS" `isPrefixOf` y = go (if "-RTS" `isSuffixOf` y then OutsideRTS else InsideRTS) ys - | otherwise = y : go OutsideRTS ys - go InsideRTS (y:ys) = go (if "-RTS" `isSuffixOf` y then OutsideRTS else InsideRTS) ys - - -removeVerbosityOpts :: [String] -> [String] -removeVerbosityOpts = filter ((&&) <$> (/= "-v0") <*> (/= "-w")) - - cabalWorkDir :: FilePath -> MaybeT IO FilePath cabalWorkDir wdir = - findFileUpwards (== "cabal.project") wdir - <|> findFileUpwards (\fp -> takeExtension fp == ".cabal") wdir - - ------------------------------------------------------------------------- - --- | Explicit data-type for project configuration location. --- It is basically a 'Maybe' type, but helps to document the API --- and helps to avoid incorrect usage. -data CradleProjectConfig - = NoExplicitConfig - | ExplicitConfig FilePath - deriving (Eq, Show) - --- | Create an explicit project configuration. Expects a working directory --- followed by an optional name of the project configuration. -projectConfigFromMaybe :: FilePath -> Maybe FilePath -> CradleProjectConfig -projectConfigFromMaybe _wdir Nothing = NoExplicitConfig -projectConfigFromMaybe wdir (Just fp) = ExplicitConfig (wdir fp) + Process.findFileUpwards "cabal.project" wdir + <|> Process.findFileUpwardsPredicate (\fp -> takeExtension fp == ".cabal") wdir ------------------------------------------------------------------------ @@ -1015,8 +507,8 @@ , runGhcCmd = \args -> runCradleResultT $ do -- Setup stack silently, since stack might print stuff to stdout in some cases (e.g. on Win) -- Issue 242 from HLS: https://github.com/haskell/haskell-language-server/issues/242 - _ <- readProcessWithCwd_ l wdir "stack" (stackYamlProcessArgs syaml <> ["setup", "--silent"]) "" - readProcessWithCwd_ l wdir "stack" + _ <- Process.readProcessWithCwd_ l wdir "stack" (stackYamlProcessArgs syaml <> ["setup", "--silent"]) "" + Process.readProcessWithCwd_ l wdir "stack" (stackYamlProcessArgs syaml <> ["exec", "ghc", "--"] <> args) "" } @@ -1048,17 +540,17 @@ -> IO (CradleLoadResult ComponentOptions) stackAction workDir mc syaml l fp loadStyle = do logCradleHasNoSupportForLoadWithContext l loadStyle "stack" - let ghcProcArgs = ("stack", stackYamlProcessArgs syaml <> ["exec", "ghc", "--"]) + let ghcProc args = proc "stack" (stackYamlProcessArgs syaml <> ["exec", "ghc", "--"] <> args) -- Same wrapper works as with cabal - wrapper_fp <- withGhcWrapperTool l ghcProcArgs workDir + wrapper_fp <- withGhcWrapperTool l ghcProc workDir (ex1, _stdo, stde, [(_, maybeArgs)]) <- - readProcessWithOutputs [hie_bios_output] l workDir + Process.readProcessWithOutputs [hie_bios_output] l workDir $ stackProcess syaml $ ["repl", "--no-nix-pure", "--with-ghc", wrapper_fp] <> [ comp | Just comp <- [mc] ] (ex2, pkg_args, stdr, _) <- - readProcessWithOutputs [hie_bios_output] l workDir + Process.readProcessWithOutputs [hie_bios_output] l workDir $ stackProcess syaml ["path", "--ghc-package-path"] let split_pkgs = concatMap splitSearchPath pkg_args @@ -1100,9 +592,7 @@ stackExecutable = MaybeT $ findExecutable "stack" stackWorkDir :: FilePath -> MaybeT IO FilePath -stackWorkDir = findFileUpwards isStack - where - isStack name = name == "stack.yaml" +stackWorkDir = Process.findFileUpwards "stack.yaml" {- -- Support removed for 0.3 but should be added back in the future @@ -1112,7 +602,7 @@ -- rulesHaskellWorkDir :: FilePath -> MaybeT IO FilePath rulesHaskellWorkDir fp = - findFileUpwards (== "WORKSPACE") fp + findFileUpwards "WORKSPACE" fp rulesHaskellCradle :: FilePath -> Cradle rulesHaskellCradle wdir = @@ -1178,106 +668,7 @@ return (makeCradleResult (ex, stde, words args) o_deps ) -} ------------------------------------------------------------------------------- --- Utilities - --- | Searches upwards for the first directory containing a file to match --- the predicate. -findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath -findFileUpwards p dir = do - cnts <- - liftIO - $ handleJust - -- Catch permission errors - (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing) - pure - (findFile p dir) - - case cnts of - [] | dir' == dir -> fail "No cabal files" - | otherwise -> findFileUpwards p dir' - _ : _ -> return dir - where dir' = takeDirectory dir - --- | Sees if any file in the directory matches the predicate -findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath] -findFile p dir = do - b <- doesDirectoryExist dir - if b then getFiles >>= filterM doesPredFileExist else return [] - where - getFiles = filter p <$> getDirectoryContents dir - doesPredFileExist file = doesFileExist $ dir file - --- | Some environments (e.g. stack exec) include GHC_PACKAGE_PATH. --- Cabal v2 *will* complain, even though or precisely because it ignores them. --- Unset them from the environment to sidestep this -getCleanEnvironment :: IO [(String, String)] -getCleanEnvironment = do - Map.toList . Map.delete "GHC_PACKAGE_PATH" . Map.fromList <$> getEnvironment - -type Outputs = [OutputName] -type OutputName = String - --- | Call a given process with temp files for the process to write to. --- * The process can discover the temp files paths by reading the environment. --- * The contents of the temp files are returned by this function, if any. --- * The logging function is called every time the process emits anything to stdout or stderr. --- it can be used to report progress of the process to a user. --- * The process is executed in the given directory. -readProcessWithOutputs - :: Outputs -- ^ Names of the outputs produced by this process - -> LogAction IO (WithSeverity Log) -- ^ Output of the process is emitted as logs. - -> FilePath -- ^ Working directory. Process is executed in this directory. - -> CreateProcess -- ^ Parameters for the process to be executed. - -> IO (ExitCode, [String], [String], [(OutputName, Maybe [String])]) -readProcessWithOutputs outputNames l workDir cp = flip runContT return $ do - old_env <- liftIO getCleanEnvironment - output_files <- traverse (withOutput old_env) outputNames - - let process = cp { env = Just $ output_files ++ fromMaybe old_env (env cp), - cwd = Just workDir - } - - -- Windows line endings are not converted so you have to filter out `'r` characters - let loggingConduit = C.decodeUtf8 C..| C.lines C..| C.filterE (/= '\r') - C..| C.map T.unpack C..| C.iterM (\msg -> l <& LogProcessOutput msg `WithSeverity` Debug) C..| C.sinkList - liftIO $ l <& LogCreateProcessRun process `WithSeverity` Info - (ex, stdo, stde) <- liftIO $ sourceProcessWithStreams process mempty loggingConduit loggingConduit - - res <- forM output_files $ \(name,path) -> - liftIO $ (name,) <$> readOutput path - - return (ex, stdo, stde, res) - - where - readOutput :: FilePath -> IO (Maybe [String]) - readOutput path = do - haveFile <- doesFileExist path - if haveFile - then withFile path ReadMode $ \handle -> do - hSetBuffering handle LineBuffering - !res <- force <$> hGetContents handle - return $ Just $ lines $ filter (/= '\r') res - else - return Nothing - - withOutput :: [(String,String)] -> OutputName -> ContT a IO (OutputName, String) - withOutput env' name = - case lookup name env' of - Just file@(_:_) -> ContT $ \action -> do - removeFileIfExists file - action (name, file) - _ -> ContT $ \action -> withSystemTempFile name $ \ file h -> do - hClose h - removeFileIfExists file - action (name, file) - -removeFileIfExists :: FilePath -> IO () -removeFileIfExists f = do - yes <- doesFileExist f - when yes (removeFile f) - makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> [FilePath] -> CradleLoadResult ComponentOptions makeCradleResult (ex, err, componentDir, gopts) deps loadingFiles = case ex of @@ -1288,38 +679,7 @@ -- | Calls @ghc --print-libdir@, with just whatever's on the PATH. runGhcCmdOnPath :: LogAction IO (WithSeverity Log) -> FilePath -> [String] -> IO (CradleLoadResult String) -runGhcCmdOnPath l wdir args = readProcessWithCwd l wdir "ghc" args "" - -- case mResult of - -- Nothing - --- | Wrapper around 'readCreateProcess' that sets the working directory and --- clears the environment, suitable for invoking cabal/stack and raw ghc commands. -readProcessWithCwd :: LogAction IO (WithSeverity Log) -> FilePath -> FilePath -> [String] -> String -> IO (CradleLoadResult String) -readProcessWithCwd l dir cmd args stdin = runCradleResultT $ readProcessWithCwd_ l dir cmd args stdin - -readProcessWithCwd_ :: LogAction IO (WithSeverity Log) -> FilePath -> FilePath -> [String] -> String -> CradleLoadResultT IO String -readProcessWithCwd_ l dir cmd args stdin = do - cleanEnv <- liftIO getCleanEnvironment - let createdProc' = (proc cmd args) { cwd = Just dir, env = Just cleanEnv } - readProcessWithCwd' l createdProc' stdin - --- | Wrapper around 'readCreateProcessWithExitCode', wrapping the result in --- a 'CradleLoadResult'. Provides better error messages than raw 'readCreateProcess'. -readProcessWithCwd' :: LogAction IO (WithSeverity Log) -> CreateProcess -> String -> CradleLoadResultT IO String -readProcessWithCwd' l createdProcess stdin = do - mResult <- liftIO $ optional $ readCreateProcessWithExitCode createdProcess stdin - liftIO $ l <& LogCreateProcessRun createdProcess `WithSeverity` Debug - let cmdString = prettyCmdSpec $ cmdspec createdProcess - case mResult of - Just (ExitSuccess, stdo, _) -> pure stdo - Just (exitCode, stdo, stde) -> throwCE $ - CradleError [] exitCode - (["Error when calling " <> cmdString, stdo, stde] <> prettyProcessEnv createdProcess) - [] - Nothing -> throwCE $ - CradleError [] ExitSuccess - (["Couldn't execute " <> cmdString] <> prettyProcessEnv createdProcess) - [] +runGhcCmdOnPath l wdir args = Process.readProcessWithCwd l wdir "ghc" args "" -- | Log that the cradle has no supported for loading with context, if and only if -- 'LoadWithContext' was requested. diff --git a/src/HIE/Bios/Cradle/Cabal.hs b/src/HIE/Bios/Cradle/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Cradle/Cabal.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module HIE.Bios.Cradle.Cabal + ( + -- * Cabal Cradle interface + cabalAction, + runCabalGhcCmd, + -- * Locations + findCabalFiles, + -- * Wrappers + withGhcWrapperTool, + -- * Argument processing + processCabalWrapperArgs, + -- * Exposed for tests + isCabalMultipleCompSupported, + )where + +import Data.Char (isSpace) +import System.Exit +import System.Directory +import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) +import Control.Monad +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 Data.Tuple.Extra (fst3, snd3, thd3) + +import HIE.Bios.Config +import HIE.Bios.Environment (getCacheDir) +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 ` (for exe:cabal <3.15 or lib:Cabal <3.15) + +In this approach, we generate a 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 ` (for exe:cabal >=3.15 and lib:Cabal >=3.15) + +The is notably simpler than the , as `--with-repl` invokes + *only* as the final GHCi process, not for compiling dependencies or +executing preprocessors. + +Thus, merely needs to log all arguments that are passed to . + +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 and `cabal repl --with-compiler --with-hc-pkg `. + +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 -> + FilePath -> + LoadStyle -> + 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. + determinedLoadStyle <- case loadStyle of + LoadWithContext _ | not multiCompSupport -> do + liftIO $ + l + <& WithSeverity + ( LogLoadWithContextUnsupported "cabal" $ + 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) <- processCabalLoadStyle l cradles projectFile workDir mc fp determinedLoadStyle + + cabalFeatures <- determineCabalLoadFeature progVersions + let + -- Used for @cabal >= 3.15@ but @lib:Cabal <3.15@, in custom setups. + mkFallbackCabalProc = cabalLoadFilesBefore315 l progVersions projectFile workDir cabalArgs + cabalProc <- case cabalFeatures of + CabalWithRepl -> cabalLoadFilesWithRepl l projectFile workDir cabalArgs + CabalWithGhcShimWrapper -> cabalLoadFilesBefore315 l progVersions projectFile workDir cabalArgs + + mResult <- runCabalToGetGhcOptions cabalProc mkFallbackCabalProc + case mResult of + Left (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 = 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 = 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 cabalFeatures of + CabalWithRepl -> liftIO $ expandGhcOptionResponseFile ghc_args + CabalWithGhcShimWrapper -> pure ghc_args + CradleLoadResultT $ pure $ CradleSuccess + ComponentOptions + { componentOptions = final_args + , componentRoot = componentDir + , componentDependencies = deps <> extraDeps + } + where + -- | Run the given cabal process to obtain ghc options. + -- In the special case of 'cabal >= 3.15' but 'lib:Cabal <3.15' (via custom-setups), + -- we gracefully fall back to the given action to create an alternative cabal process which + -- we use to find the ghc options. + runCabalToGetGhcOptions :: + Process.CreateProcess -> + CradleLoadResultT IO Process.CreateProcess -> + CradleLoadResultT IO + (Either + (Int, ProcessErrorDetails) + ([String], ProcessErrorDetails) + ) + runCabalToGetGhcOptions cabalProc mkFallbackCabalProc = 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{} | isCabalLibraryInProjectTooOld stde -> do + liftIO $ l <& WithSeverity (LogCabalLibraryTooOld stde) Debug + fallbackCabalProc <- mkFallbackCabalProc + runCabalToGetGhcOptions fallbackCabalProc mkFallbackCabalProc + ExitFailure code -> do + + pure $ Left (code, errorDetails) + ExitSuccess -> + pure $ Right (args, errorDetails) + + +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 vs wdir projectFile >>= \case + Just p -> Process.readProcessWithCwd_ l wdir p args "" + Nothing -> do + buildDir <- liftIO $ cabalBuildDir 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 vs projectFile wdir args + Process.readProcessWithCwd' l cabalProc "" + +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) + + liftIO $ l <& LogComputedCradleLoadStyle "cabal" loadStyle `WithSeverity` Info + liftIO $ l <& LogCabalLoad fp mc (prefix <$> resolvedCradles cradles) loadingFiles `WithSeverity` Debug + pure (cabalArgs, loadingFiles, extraDeps) + where + -- 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 + 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 + ] + +cabalLoadFilesWithRepl :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> [String] -> CradleLoadResultT IO CreateProcess +cabalLoadFilesWithRepl l projectFile workDir args = do + let cabalCommand = "v2-repl" + + newEnvironment <- liftIO Process.getCleanEnvironment + wrapper_fp <- liftIO $ withReplWrapperTool l (proc "ghc") workDir + pure (proc "cabal" ([cabalCommand, "--keep-temp-files", "--with-repl", wrapper_fp] <> projectFileProcessArgs projectFile <> args)) + { 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 + +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) -> ProgramVersions -> CradleProjectConfig -> [Char] -> [String] -> CradleLoadResultT IO CreateProcess +cabalLoadFilesBefore315 l progVersions projectFile workDir args = do + let cabalCommand = "v2-repl" + cabalProcess l progVersions projectFile workDir cabalCommand 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) -> ProgramVersions -> CradleProjectConfig -> FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess +cabalProcess l vs cabalProject workDir command args = do + ghcDirs@(ghcBin, libdir) <- callCabalPathForCompilerPath l 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 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 (proc "ghc") workDir + buildDir <- cabalBuildDir 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 :: FilePath -> FilePath -> IO FilePath +withGhcPkgTool 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) + cacheFile "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) -> GhcProc -> FilePath -> IO FilePath +withGhcWrapperTool l mkGhcCall wdir = do + withWrapperTool l 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) -> GhcProc -> FilePath -> IO FilePath +withReplWrapperTool l mkGhcCall wdir = + withWrapperTool l mkGhcCall wdir "repl-wrapper" cabalWithReplWrapperHs cabalWithReplWrapper + +withWrapperTool :: LogAction IO (WithSeverity Log) -> GhcProc -> String -> FilePath -> String -> String -> IO FilePath +withWrapperTool l 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) + cacheFile (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 root directory, get the build dir we are using for cabal +-- In the `hie-bios` cache directory +cabalBuildDir :: FilePath -> IO FilePath +cabalBuildDir workDir = do + abs_work_dir <- makeAbsolute workDir + let dirHash = show (fingerprintString abs_work_dir) + getCacheDir ("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) -> ProgramVersions -> CradleProjectConfig -> FilePath -> [String] -> CradleLoadResultT IO CreateProcess +cabalExecGhc l vs projectFile wdir args = do + cabalProcess l vs projectFile wdir "v2-exec" $ ["ghc", "-v0", "--"] ++ args + +callCabalPathForCompilerPath :: LogAction IO (WithSeverity Log) -> ProgramVersions -> FilePath -> CradleProjectConfig -> CradleLoadResultT IO (Maybe FilePath) +callCabalPathForCompilerPath l vs workDir projectFile = do + isCabalPathSupported vs >>= \case + False -> pure Nothing + True -> do + let + args = ["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 CabalLoadFeature + = CabalWithRepl + | CabalWithGhcShimWrapper + +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 + +-- | 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 = + "constraint from --with-repl requires >=3.15" `isInfixOf` unlines 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 diff --git a/src/HIE/Bios/Cradle/ProgramVersions.hs b/src/HIE/Bios/Cradle/ProgramVersions.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Cradle/ProgramVersions.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +module HIE.Bios.Cradle.ProgramVersions + ( ProgramVersions(..) + , makeVersions + , runCachedIO + ) where + + +import HIE.Bios.Types +import qualified HIE.Bios.Process as Process + +import Colog.Core (LogAction (..), WithSeverity (..)) +import Data.Version +import Data.IORef +import Text.ParserCombinators.ReadP (readP_to_S) + +data ProgramVersions = + ProgramVersions { cabalVersion :: CachedIO (Maybe Version) + , stackVersion :: CachedIO (Maybe Version) + , ghcVersion :: CachedIO (Maybe Version) + } + +newtype CachedIO a = CachedIO (IORef (Either (IO a) a)) + +makeCachedIO :: IO a -> IO (CachedIO a) +makeCachedIO act = CachedIO <$> newIORef (Left act) + +runCachedIO :: CachedIO a -> IO a +runCachedIO (CachedIO ref) = + readIORef ref >>= \case + Right x -> pure x + Left act -> do + x <- act + writeIORef ref (Right x) + pure x + +makeVersions :: LogAction IO (WithSeverity Log) -> FilePath -> ([String] -> IO (CradleLoadResult String)) -> IO ProgramVersions +makeVersions l wdir ghc = do + cabalVersion <- makeCachedIO $ getCabalVersion l wdir + stackVersion <- makeCachedIO $ getStackVersion l wdir + ghcVersion <- makeCachedIO $ getGhcVersion ghc + pure ProgramVersions{..} + +getCabalVersion :: LogAction IO (WithSeverity Log) -> FilePath -> IO (Maybe Version) +getCabalVersion l wdir = do + res <- Process.readProcessWithCwd l wdir "cabal" ["--numeric-version"] "" + case res of + CradleSuccess stdo -> + pure $ versionMaybe stdo + _ -> pure Nothing + +getStackVersion :: LogAction IO (WithSeverity Log) -> FilePath -> IO (Maybe Version) +getStackVersion l wdir = do + res <- Process.readProcessWithCwd l wdir "stack" ["--numeric-version"] "" + case res of + CradleSuccess stdo -> + pure $ versionMaybe stdo + _ -> pure Nothing + +getGhcVersion :: ([String] -> IO (CradleLoadResult String)) -> IO (Maybe Version) +getGhcVersion ghc = do + res <- ghc ["--numeric-version"] + case res of + CradleSuccess stdo -> + pure $ versionMaybe stdo + _ -> pure Nothing + +versionMaybe :: String -> Maybe Version +versionMaybe xs = case reverse $ readP_to_S parseVersion xs of + [] -> Nothing + (x:_) -> Just (fst x) diff --git a/src/HIE/Bios/Cradle/ProjectConfig.hs b/src/HIE/Bios/Cradle/ProjectConfig.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Cradle/ProjectConfig.hs @@ -0,0 +1,17 @@ +module HIE.Bios.Cradle.ProjectConfig where + +import System.FilePath + +-- | Explicit data-type for project configuration location. +-- It is basically a 'Maybe' type, but helps to document the API +-- and helps to avoid incorrect usage. +data CradleProjectConfig + = NoExplicitConfig + | ExplicitConfig FilePath + deriving (Eq, Show) + +-- | Create an explicit project configuration. Expects a working directory +-- followed by an optional name of the project configuration. +projectConfigFromMaybe :: FilePath -> Maybe FilePath -> CradleProjectConfig +projectConfigFromMaybe _wdir Nothing = NoExplicitConfig +projectConfigFromMaybe wdir (Just fp) = ExplicitConfig (wdir fp) diff --git a/src/HIE/Bios/Cradle/Resolved.hs b/src/HIE/Bios/Cradle/Resolved.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Cradle/Resolved.hs @@ -0,0 +1,35 @@ +module HIE.Bios.Cradle.Resolved + ( ResolvedCradles(..) + , ResolvedCradle(..) + , ConcreteCradle(..) + ) where + +import HIE.Bios.Cradle.ProgramVersions +import HIE.Bios.Config + +-- | The final cradle config that specifies the cradle for +-- each prefix we know how to handle +data ResolvedCradles a = ResolvedCradles + { cradleRoot :: FilePath + , resolvedCradles :: [ResolvedCradle a] -- ^ In order of decreasing specificity + , cradleProgramVersions :: ProgramVersions + } + +-- | 'ConcreteCradle' augmented with information on which file the +-- cradle applies +data ResolvedCradle a = ResolvedCradle + { prefix :: FilePath -- ^ the prefix to match files + , cradleDeps :: [FilePath] -- ^ accumulated dependencies + , concreteCradle :: ConcreteCradle a + } deriving Show + +-- | The actual type of action we will be using to process a file +data ConcreteCradle a + = ConcreteCabal CabalType + | ConcreteStack StackType + | ConcreteBios Callable (Maybe Callable) (Maybe FilePath) + | ConcreteDirect [String] + | ConcreteNone + | ConcreteOther a + deriving Show + diff --git a/src/HIE/Bios/Cradle/Utils.hs b/src/HIE/Bios/Cradle/Utils.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Cradle/Utils.hs @@ -0,0 +1,108 @@ +module HIE.Bios.Cradle.Utils + ( + -- * Helper for process errors + ProcessErrorDetails(..) + , prettyProcessErrorDetails + -- * Cradle utils + , selectCradle + -- * Processing of ghc-options + , removeInteractive + , removeRTS + , removeVerbosityOpts + , expandGhcOptionResponseFile + ) + where + +import HIE.Bios.Types (prettyCmdSpec) + +import Data.List +import System.Process.Extra +import GHC.ResponseFile (expandResponse) + +-- ---------------------------------------------------------------------------- +-- Process error details +-- ---------------------------------------------------------------------------- + +data ProcessErrorDetails = ProcessErrorDetails + { processCmd :: CmdSpec + -- ^ The 'CmdSpec' of the command. + , processStdout :: [String] + -- ^ The stdout of the command. + , processStderr :: [String] + -- ^ The stderr of the command. + , processGhcOptions :: [String] + -- ^ The ghc-options that were obtained via the command + , processHieBiosEnvironment :: [(String, String)] + -- ^ Environment variables populated by 'hie-bios' and their respective value. + } + +prettyProcessErrorDetails :: ProcessErrorDetails -> [String] +prettyProcessErrorDetails p = + [ "Failed command: " <> prettyCmdSpec (processCmd p), + unlines (processStdout p), + unlines (processStderr p), + unlines (processGhcOptions p), + "Process Environment:" + ] <> [ key <> ": " <> value + | (key, value) <- processHieBiosEnvironment p + ] + +-- ---------------------------------------------------------------------------- +-- Cradle utils +-- ---------------------------------------------------------------------------- + +-- | Given a list of cradles, try to find the most likely cradle that +-- this 'FilePath' belongs to. +selectCradle :: (a -> FilePath) -> FilePath -> [a] -> Maybe a +selectCradle _ _ [] = Nothing +selectCradle k cur_fp (c: css) = + if k c `isPrefixOf` cur_fp + then Just c + else selectCradle k cur_fp css + + +-- ---------------------------------------------------------------------------- +-- Cradle utils +-- ---------------------------------------------------------------------------- + +removeInteractive :: [String] -> [String] +removeInteractive = filter (/= "--interactive") + +-- | Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. +data InRTS = OutsideRTS | InsideRTS + +-- | Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. +-- +-- >>> removeRTS ["option1", "+RTS -H32m -RTS", "option2"] +-- ["option1", "option2"] +-- +-- >>> removeRTS ["option1", "+RTS", "-H32m", "-RTS", "option2"] +-- ["option1", "option2"] +-- +-- >>> removeRTS ["option1", "+RTS -H32m"] +-- ["option1"] +-- +-- >>> removeRTS ["option1", "+RTS -H32m", "-RTS", "option2"] +-- ["option1", "option2"] +-- +-- >>> removeRTS ["option1", "+RTS -H32m", "-H32m -RTS", "option2"] +-- ["option1", "option2"] +removeRTS :: [String] -> [String] +removeRTS = go OutsideRTS + where + go :: InRTS -> [String] -> [String] + go _ [] = [] + go OutsideRTS (y:ys) + | "+RTS" `isPrefixOf` y = go (if "-RTS" `isSuffixOf` y then OutsideRTS else InsideRTS) ys + | otherwise = y : go OutsideRTS ys + go InsideRTS (y:ys) = go (if "-RTS" `isSuffixOf` y then OutsideRTS else InsideRTS) ys + + +removeVerbosityOpts :: [String] -> [String] +removeVerbosityOpts = filter ((&&) <$> (/= "-v0") <*> (/= "-w")) + +expandGhcOptionResponseFile :: [String] -> IO [String] +expandGhcOptionResponseFile args = do + expanded_args <- expandResponse args + pure $ removeInteractive expanded_args + diff --git a/src/HIE/Bios/Process.hs b/src/HIE/Bios/Process.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Process.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +module HIE.Bios.Process + ( CreateProcess(..) + -- * Run processes with extra environment variables + , readProcessWithCwd + , readProcessWithCwd_ + , readProcessWithCwd' + , readProcessWithOutputs + , getCleanEnvironment + -- * File Caching + , cacheFile + -- * Find file utilities + , findFileUpwards + , findFileUpwardsPredicate + , findFile + ) + where + +import Control.Applicative (optional) +import Control.DeepSeq +import Control.Exception (handleJust) +import System.Exit +import System.Directory hiding (findFile) +import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) +import Control.Monad +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Data.Conduit.Process +import qualified Data.Conduit.Combinators as C +import qualified Data.Conduit as C +import qualified Data.Conduit.Text as C +import qualified Data.HashMap.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import System.Environment +import System.FilePath +import System.IO (hClose, hGetContents, hSetBuffering, BufferMode(LineBuffering), withFile, IOMode(..)) +import System.IO.Error (isPermissionError) +import System.IO.Temp + +import HIE.Bios.Types +import Control.Monad.Extra (unlessM) +import System.PosixCompat (setFileMode, accessModes) +import HIE.Bios.Environment (getCacheDir) + +-- | Wrapper around 'readCreateProcess' that sets the working directory and +-- clears the environment, suitable for invoking cabal/stack and raw ghc commands. +readProcessWithCwd :: LogAction IO (WithSeverity Log) -> FilePath -> FilePath -> [String] -> String -> IO (CradleLoadResult String) +readProcessWithCwd l dir cmd args stdin = runCradleResultT $ readProcessWithCwd_ l dir cmd args stdin + +readProcessWithCwd_ :: LogAction IO (WithSeverity Log) -> FilePath -> FilePath -> [String] -> String -> CradleLoadResultT IO String +readProcessWithCwd_ l dir cmd args stdin = do + cleanEnv <- liftIO getCleanEnvironment + let createdProc' = (proc cmd args) { cwd = Just dir, env = Just cleanEnv } + readProcessWithCwd' l createdProc' stdin + +-- | Wrapper around 'readCreateProcessWithExitCode', wrapping the result in +-- a 'CradleLoadResult'. Provides better error messages than raw 'readCreateProcess'. +readProcessWithCwd' :: LogAction IO (WithSeverity Log) -> CreateProcess -> String -> CradleLoadResultT IO String +readProcessWithCwd' l createdProcess stdin = do + mResult <- liftIO $ optional $ readCreateProcessWithExitCode createdProcess stdin + liftIO $ l <& LogCreateProcessRun createdProcess `WithSeverity` Debug + let cmdString = prettyCmdSpec $ cmdspec createdProcess + case mResult of + Just (ExitSuccess, stdo, _) -> pure stdo + Just (exitCode, stdo, stde) -> throwCE $ + CradleError [] exitCode + (["Error when calling " <> cmdString, stdo, stde] <> prettyProcessEnv createdProcess) + [] + Nothing -> throwCE $ + CradleError [] ExitSuccess + (["Couldn't execute " <> cmdString] <> prettyProcessEnv createdProcess) + [] + + +-- | Some environments (e.g. stack exec) include GHC_PACKAGE_PATH. +-- Cabal v2 *will* complain, even though or precisely because it ignores them. +-- Unset them from the environment to sidestep this +getCleanEnvironment :: IO [(String, String)] +getCleanEnvironment = do + Map.toList . Map.delete "GHC_PACKAGE_PATH" . Map.fromList <$> getEnvironment + +type Outputs = [OutputName] +type OutputName = String + +-- | Call a given process with temp files for the process to write to. +-- * The process can discover the temp files paths by reading the environment. +-- * The contents of the temp files are returned by this function, if any. +-- * The logging function is called every time the process emits anything to stdout or stderr. +-- it can be used to report progress of the process to a user. +-- * The process is executed in the given directory. +readProcessWithOutputs + :: Outputs -- ^ Names of the outputs produced by this process + -> LogAction IO (WithSeverity Log) -- ^ Output of the process is emitted as logs. + -> FilePath -- ^ Working directory. Process is executed in this directory. + -> CreateProcess -- ^ Parameters for the process to be executed. + -> IO (ExitCode, [String], [String], [(OutputName, Maybe [String])]) +readProcessWithOutputs outputNames l workDir cp = flip runContT return $ do + old_env <- liftIO getCleanEnvironment + output_files <- traverse (withOutput old_env) outputNames + + let process = cp { env = Just $ output_files ++ fromMaybe old_env (env cp), + cwd = Just workDir + } + + -- Windows line endings are not converted so you have to filter out `'r` characters + let loggingConduit = C.decodeUtf8 C..| C.lines C..| C.filterE (/= '\r') + C..| C.map T.unpack C..| C.iterM (\msg -> l <& LogProcessOutput msg `WithSeverity` Debug) C..| C.sinkList + liftIO $ l <& LogCreateProcessRun process `WithSeverity` Info + (ex, stdo, stde) <- liftIO $ sourceProcessWithStreams process mempty loggingConduit loggingConduit + + res <- forM output_files $ \(name,path) -> + liftIO $ (name,) <$> readOutput path + + return (ex, stdo, stde, res) + + where + readOutput :: FilePath -> IO (Maybe [String]) + readOutput path = do + haveFile <- doesFileExist path + if haveFile + then withFile path ReadMode $ \handle -> do + hSetBuffering handle LineBuffering + !res <- force <$> hGetContents handle + return $ Just $ lines $ filter (/= '\r') res + else + return Nothing + + withOutput :: [(String,String)] -> OutputName -> ContT a IO (OutputName, String) + withOutput env' name = + case lookup name env' of + Just file@(_:_) -> ContT $ \action -> do + removeFileIfExists file + action (name, file) + _ -> ContT $ \action -> withSystemTempFile name $ \ file h -> do + hClose h + removeFileIfExists file + action (name, file) + +-- | Create and cache a file in hie-bios's cache directory. +-- +-- @'cacheFile' fpName srcHash populate@. 'fpName' is the pattern name of the +-- cached file you want to create. 'srcHash' is the hash that is appended to +-- the file pattern and is expected to change whenever you want to invalidate +-- the cache. +-- +-- If the cached file's 'srcHash' changes, then a new file is created, but +-- the old cached file name will not be deleted. +-- +-- If the file does not exist yet, 'populate' is invoked with cached file +-- location and it is expected that the caller persists the given filepath in +-- the File System. +cacheFile :: FilePath -> String -> (FilePath -> IO ()) -> IO FilePath +cacheFile fpName srcHash populate = do + cacheDir <- getCacheDir "" + createDirectoryIfMissing True cacheDir + let newFpName = cacheDir (dropExtensions fpName <> "-" <> srcHash) <.> takeExtensions fpName + unlessM (doesFileExist newFpName) $ do + populate newFpName + setMode newFpName + pure newFpName + where + setMode wrapper_fp = setFileMode wrapper_fp accessModes + +------------------------------------------------------------------------------ +-- Utilities + + +-- | Searches upwards for the first directory containing a file. +findFileUpwards :: FilePath -> FilePath -> MaybeT IO FilePath +findFileUpwards filename dir = do + cnts <- + liftIO + $ handleJust + -- Catch permission errors + (\(e :: IOError) -> if isPermissionError e then Just False else Nothing) + pure + (doesFileExist (dir filename)) + case cnts of + False | dir' == dir -> fail "No cabal files" + | otherwise -> findFileUpwards filename dir' + True -> return dir + where dir' = takeDirectory dir + +-- | Searches upwards for the first directory containing a file to match +-- the predicate. +-- +-- *WARNING*, this scans all the files of all the directories upward. If +-- appliable, prefer to use 'findFileUpwards' +findFileUpwardsPredicate :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath +findFileUpwardsPredicate p dir = do + cnts <- + liftIO + $ handleJust + -- Catch permission errors + (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing) + pure + (findFile p dir) + + case cnts of + [] | dir' == dir -> fail "No cabal files" + | otherwise -> findFileUpwardsPredicate p dir' + _ : _ -> return dir + where dir' = takeDirectory dir + +-- | Sees if any file in the directory matches the predicate +findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +findFile p dir = do + b <- doesDirectoryExist dir + if b then getFiles >>= filterM doesPredFileExist else return [] + where + getFiles = filter p <$> getDirectoryContents dir + doesPredFileExist file = doesFileExist $ dir file + +removeFileIfExists :: FilePath -> IO () +removeFileIfExists f = do + yes <- doesFileExist f + when yes (removeFile f) + diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs --- a/src/HIE/Bios/Types.hs +++ b/src/HIE/Bios/Types.hs @@ -16,7 +16,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Text as T import Prettyprinter -import System.Process.Extra (CreateProcess (env, cmdspec), CmdSpec (..)) +import System.Process.Extra (CreateProcess (env, cmdspec), CmdSpec (..), showCommandForUser) ---------------------------------------------------------------- -- Environment variables used by hie-bios. @@ -49,6 +49,12 @@ hie_bios_arg :: String hie_bios_arg = "HIE_BIOS_ARG" +-- | Environment variable pointing to the multiple source files location that +-- caused the cradle action to be executed. Differs from hie_bios_arg for +-- backwards compatibility. +hie_bios_multi_arg :: String +hie_bios_multi_arg = "HIE_BIOS_MULTI_ARG" + -- | Environment variable pointing to a filepath to which dependencies -- of a cradle can be written to by the cradle action. hie_bios_deps :: String @@ -100,6 +106,7 @@ | LogComputedCradleLoadStyle !T.Text !LoadStyle | LogLoadWithContextUnsupported !T.Text !(Maybe T.Text) | LogCabalLoad !FilePath !(Maybe String) ![FilePath] ![FilePath] + | LogCabalLibraryTooOld [String] | LogCabalPath !T.Text deriving (Show) @@ -142,6 +149,9 @@ <> line <> indent 4 "from project: " <+> pretty projectFile <> line <> indent 4 "with prefixes:" <+> pretty prefixes <> line <> indent 4 "with actual loading files:" <+> pretty crs + pretty (LogCabalLibraryTooOld err) = + "'lib:Cabal' is too old to use '--with-repl' flag. Requires 'lib:Cabal' >= 3.15. Original error:" <> line + <> vcat (fmap pretty err) pretty (LogCabalPath err) = "Could not parse json output of 'cabal path': " <> line <> indent 4 (pretty err) @@ -310,12 +320,18 @@ -- | Prettify 'CmdSpec', so we can show the command to a user prettyCmdSpec :: CmdSpec -> String prettyCmdSpec (ShellCommand s) = s -prettyCmdSpec (RawCommand cmd args) = cmd ++ " " ++ unwords args +prettyCmdSpec (RawCommand cmd args) = showCommandForUser cmd args -- | Pretty print hie-bios's relevant environment variables. prettyProcessEnv :: CreateProcess -> [String] prettyProcessEnv p = [ key <> ": " <> value + | (key, value) <- hieBiosProcessEnv p + ] + +hieBiosProcessEnv :: CreateProcess -> [(String, String)] +hieBiosProcessEnv p = + [ (key, value) | (key, value) <- fromMaybe [] (env p) , key `elem` [ hie_bios_output , hie_bios_ghc diff --git a/src/HIE/Bios/Wrappers.hs b/src/HIE/Bios/Wrappers.hs --- a/src/HIE/Bios/Wrappers.hs +++ b/src/HIE/Bios/Wrappers.hs @@ -1,17 +1,24 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} -module HIE.Bios.Wrappers (cabalWrapper, cabalWrapperHs) where +{-# LANGUAGE TemplateHaskell #-} -import Data.FileEmbed -#if __GLASGOW_HASKELL__ >= 903 - hiding (makeRelativeToProject) -#endif -import Language.Haskell.TH.Syntax +module HIE.Bios.Wrappers ( + cabalWrapper, + cabalWithReplWrapper, + cabalWrapperHs, + cabalWithReplWrapperHs, +) where +import Data.FileEmbed ( embedStringFile ) +import Language.Haskell.TH.Syntax ( makeRelativeToProject ) + cabalWrapper :: String cabalWrapper = $(makeRelativeToProject "wrappers/cabal" >>= embedStringFile) cabalWrapperHs :: String cabalWrapperHs = $(makeRelativeToProject "wrappers/cabal.hs" >>= embedStringFile) +cabalWithReplWrapper :: String +cabalWithReplWrapper = $(makeRelativeToProject "wrappers/cabal-with-repl" >>= embedStringFile) + +cabalWithReplWrapperHs :: String +cabalWithReplWrapperHs = $(makeRelativeToProject "wrappers/cabal-with-repl.hs" >>= embedStringFile) diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -18,9 +18,10 @@ import Control.Monad ( forM_ ) import Data.List ( sort, isPrefixOf ) import Data.Typeable +import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import System.Directory import System.FilePath ((), makeRelative) -import System.Exit (ExitCode(ExitSuccess, ExitFailure)) +import System.Info.Extra (isWindows) import Control.Monad.Extra (unlessM) import qualified HIE.Bios.Ghc.Gap as Gap import Control.Monad.IO.Class @@ -34,7 +35,7 @@ -- If you change this version, make sure to also update 'cabal.project' -- in 'tests\/projects\/cabal-with-ghc'. extraGhcVersion :: String -extraGhcVersion = "9.2.8" +extraGhcVersion = "9.4.8" extraGhc :: String extraGhc = "ghc-" ++ extraGhcVersion @@ -123,7 +124,11 @@ cradleErrorExitCode @?= ExitSuccess cradleErrorDependencies `shouldMatchList` [] length cradleErrorStderr @?= 1 - "Couldn't execute myGhc" `isPrefixOf` head cradleErrorStderr @? "Error message should contain basic information" + 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" , biosTestCase "simple-bios-shell" $ runTestEnv "./simple-bios-shell" $ do testDirectoryM isBiosCradle "B.hs" , biosTestCase "simple-bios-shell-deps" $ runTestEnv "./simple-bios-shell" $ do @@ -212,6 +217,10 @@ assertLibDirVersionIs extraGhcVersion loadRuntimeGhcVersion assertGhcVersionIs extraGhcVersion + step "Find Component Options" + loadComponentOptions "src/MyLib.hs" + _ <- assertLoadSuccess + pure () ] , testGroup "Cabal cabalProject" [ biosTestCase "cabal-with-project, options propagated" $ runTestEnv "cabal-with-project" $ do @@ -241,7 +250,17 @@ assertLibDirVersionIs extraGhcVersion loadRuntimeGhcVersion assertGhcVersionIs extraGhcVersion + step "Find Component Options" + loadComponentOptions "src/MyLib.hs" + _ <- assertLoadSuccess + pure () ] + , biosTestCase "force older Cabal version in custom setup" $ 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. + testDirectoryM isCabalCradle "src/MyLib.hs" ] ] where @@ -357,7 +376,6 @@ biosTestCase name assertion = askOption @VerboseLogging (\case VerboseLogging verbose -> testCase name (assertion verbose) ) - -- ------------------------------------------------------------------ -- Stack related helper functions diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -25,76 +25,77 @@ main :: IO () main = defaultMain $ - testCase "Parser Tests" $ do - assertParser "cabal-1.yaml" (noDeps (Cabal $ CabalType (Just "lib:hie-bios") Nothing)) - assertParser "stack-config.yaml" (noDeps (Stack $ StackType Nothing Nothing)) - --assertParser "bazel.yaml" (noDeps Bazel) - assertParser "bios-1.yaml" (noDeps (Bios (Program "program") Nothing Nothing)) - assertParser "bios-2.yaml" (noDeps (Bios (Program "program") (Just (Program "dep-program")) Nothing)) - assertParser "bios-3.yaml" (noDeps (Bios (Command "shellcommand") Nothing Nothing)) - assertParser "bios-4.yaml" (noDeps (Bios (Command "shellcommand") (Just (Command "dep-shellcommand")) Nothing)) - assertParser "bios-5.yaml" (noDeps (Bios (Command "shellcommand") (Just (Program "dep-program")) Nothing)) - assertParser "dependencies.yaml" (Config (CradleConfig ["depFile"] (Cabal $ CabalType (Just "lib:hie-bios") Nothing))) - assertParser "direct.yaml" (noDeps (Direct ["list", "of", "arguments"])) - assertParser "none.yaml" (noDeps None) - --assertParser "obelisk.yaml" (noDeps Obelisk) - assertParser "multi.yaml" (noDeps (Multi [("./src", CradleConfig [] (Cabal $ CabalType (Just "lib:hie-bios") Nothing)) + testGroup "Parser Tests" + [ assertParser "cabal-1.yaml" (noDeps (Cabal $ CabalType (Just "lib:hie-bios") Nothing)) + , assertParser "stack-config.yaml" (noDeps (Stack $ StackType Nothing Nothing)) + --, assertParser "bazel.yaml" (noDeps Bazel) + , assertParser "bios-1.yaml" (noDeps (Bios (Program "program") Nothing Nothing)) + , assertParser "bios-2.yaml" (noDeps (Bios (Program "program") (Just (Program "dep-program")) Nothing)) + , assertParser "bios-3.yaml" (noDeps (Bios (Command "shellcommand") Nothing Nothing)) + , assertParser "bios-4.yaml" (noDeps (Bios (Command "shellcommand") (Just (Command "dep-shellcommand")) Nothing)) + , assertParser "bios-5.yaml" (noDeps (Bios (Command "shellcommand") (Just (Program "dep-program")) Nothing)) + , assertParser "dependencies.yaml" (Config (CradleConfig ["depFile"] (Cabal $ CabalType (Just "lib:hie-bios") Nothing))) + , assertParser "direct.yaml" (noDeps (Direct ["list", "of", "arguments"])) + , assertParser "none.yaml" (noDeps None) + --, assertParser "obelisk.yaml" (noDeps Obelisk) + , assertParser "multi.yaml" (noDeps (Multi [("./src", CradleConfig [] (Cabal $ CabalType (Just "lib:hie-bios") Nothing)) ,("./test", CradleConfig [] (Cabal $ CabalType (Just "test") Nothing))])) - assertParser "cabal-multi.yaml" (noDeps (CabalMulti (CabalType Nothing Nothing) + , assertParser "cabal-multi.yaml" (noDeps (CabalMulti (CabalType Nothing Nothing) [("./src", CabalType (Just "lib:hie-bios") Nothing) ,("./", CabalType (Just "lib:hie-bios") Nothing)])) - assertParser "stack-multi.yaml" (noDeps (StackMulti (StackType Nothing Nothing) + , assertParser "stack-multi.yaml" (noDeps (StackMulti (StackType Nothing Nothing) [("./src", StackType (Just "lib:hie-bios") Nothing) ,("./", StackType (Just"lib:hie-bios") Nothing)])) - assertParser "nested-cabal-multi.yaml" (noDeps (Multi [("./test/testdata", CradleConfig [] None) + , assertParser "nested-cabal-multi.yaml" (noDeps (Multi [("./test/testdata", CradleConfig [] None) ,("./", CradleConfig [] ( CabalMulti (CabalType Nothing Nothing) [("./src", CabalType (Just "lib:hie-bios") Nothing) ,("./tests", CabalType (Just "parser-tests") Nothing)]))])) - assertParser "nested-stack-multi.yaml" (noDeps (Multi [("./test/testdata", CradleConfig [] None) + , assertParser "nested-stack-multi.yaml" (noDeps (Multi [("./test/testdata", CradleConfig [] None) ,("./", CradleConfig [] ( StackMulti (StackType Nothing Nothing) [("./src", StackType (Just "lib:hie-bios") Nothing) ,("./tests", StackType (Just "parser-tests") Nothing)]))])) -- Assertions for cabal.project files - assertParser "cabal-with-project.yaml" - (noDeps (Cabal $ CabalType Nothing (Just "cabal.project.9.2.8"))) - assertParser "cabal-with-both.yaml" - (noDeps (Cabal $ CabalType (Just "hie-bios:hie") (Just "cabal.project.9.2.8"))) - assertParser "multi-cabal-with-project.yaml" - (noDeps (CabalMulti (CabalType Nothing (Just "cabal.project.9.2.8")) + , assertParser "cabal-with-project.yaml" + (noDeps (Cabal $ CabalType Nothing (Just "cabal.project.extra"))) + , assertParser "cabal-with-both.yaml" + (noDeps (Cabal $ CabalType (Just "hie-bios:hie") (Just "cabal.project.extra"))) + , assertParser "multi-cabal-with-project.yaml" + (noDeps (CabalMulti (CabalType Nothing (Just "cabal.project.extra")) [("./src", CabalType (Just "lib:hie-bios") Nothing) ,("./vendor", CabalType (Just "parser-tests") Nothing)])) -- Assertions for stack.yaml files - assertParser "stack-with-yaml.yaml" + , assertParser "stack-with-yaml.yaml" (noDeps (Stack $ StackType Nothing (Just "stack-8.8.3.yaml"))) - assertParser "stack-with-both.yaml" + , assertParser "stack-with-both.yaml" (noDeps (Stack $ StackType (Just "hie-bios:hie") (Just "stack-8.8.3.yaml"))) - assertParser "multi-stack-with-yaml.yaml" + , assertParser "multi-stack-with-yaml.yaml" (noDeps (StackMulti (StackType Nothing (Just "stack-8.8.3.yaml")) [("./src", StackType (Just "lib:hie-bios") Nothing) ,("./vendor", StackType (Just "parser-tests") Nothing)])) - assertCustomParser "ch-cabal.yaml" + , assertCustomParser "ch-cabal.yaml" (noDeps (Other CabalHelperCabal $ simpleCabalHelperYaml "cabal")) - assertCustomParser "ch-stack.yaml" + , assertCustomParser "ch-stack.yaml" (noDeps (Other CabalHelperStack $ simpleCabalHelperYaml "stack")) - assertCustomParser "multi-ch.yaml" + , assertCustomParser "multi-ch.yaml" (noDeps (Multi [ ("./src", CradleConfig [] (Other CabalHelperStack $ simpleCabalHelperYaml "stack")) , ("./input", CradleConfig [] (Other CabalHelperCabal $ simpleCabalHelperYaml "cabal")) , ("./test", CradleConfig [] (Cabal $ CabalType (Just "test") Nothing)) , (".", CradleConfig [] None) ])) - assertParserFails "keys-not-unique-fails.yaml" invalidYamlException - assertParser "cabal-empty-config.yaml" (noDeps (Cabal $ CabalType Nothing Nothing)) + , assertParserFails "keys-not-unique-fails.yaml" invalidYamlException + , assertParser "cabal-empty-config.yaml" (noDeps (Cabal $ CabalType Nothing Nothing)) + ] -assertParser :: FilePath -> Config Void -> Assertion -assertParser fp cc = do +assertParser :: FilePath -> Config Void -> TestTree +assertParser fp cc = testCase fp $ do conf <- readConfig (configDir fp) (conf == cc) @? (unlines [("Parser Failed: " ++ fp) , "Expected: " ++ show cc @@ -104,11 +105,11 @@ invalidYamlException (InvalidYaml (Just _)) = True invalidYamlException _ = False -assertParserFails :: Exception e => FilePath -> Selector e -> Assertion -assertParserFails fp es = (readConfig (configDir fp) :: IO (Config Void)) `shouldThrow` es +assertParserFails :: Exception e => FilePath -> Selector e -> TestTree +assertParserFails fp es = testCase fp $ (readConfig (configDir fp) :: IO (Config Void)) `shouldThrow` es -assertCustomParser :: FilePath -> Config CabalHelper -> Assertion -assertCustomParser fp cc = do +assertCustomParser :: FilePath -> Config CabalHelper -> TestTree +assertCustomParser fp cc = testCase fp $ do conf <- readConfig (configDir fp) (conf == cc) @? (unlines [("Parser Failed: " ++ fp) , "Expected: " ++ show cc diff --git a/tests/Utils.hs b/tests/Utils.hs --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -78,6 +78,8 @@ import Data.Void import qualified GHC as G import HIE.Bios.Cradle +import HIE.Bios.Cradle.Cabal (isCabalMultipleCompSupported) +import HIE.Bios.Cradle.ProgramVersions (makeVersions) import HIE.Bios.Environment import HIE.Bios.Flags import HIE.Bios.Ghc.Api @@ -142,7 +144,7 @@ , testRootDir = root' , testLogger = init_logger } - realRoot = testProjectRoots config root + realRoot <- makeAbsolute $ testProjectRoots config root wrapper realRoot $ \root' -> flip evalStateT (mkEnv root') $ do step $ "Run test in: " <> root' act diff --git a/tests/configs/cabal-with-both.yaml b/tests/configs/cabal-with-both.yaml --- a/tests/configs/cabal-with-both.yaml +++ b/tests/configs/cabal-with-both.yaml @@ -1,4 +1,4 @@ cradle: cabal: - cabalProject: "cabal.project.9.2.8" + cabalProject: "cabal.project.extra" component: "hie-bios:hie" diff --git a/tests/configs/cabal-with-project.yaml b/tests/configs/cabal-with-project.yaml --- a/tests/configs/cabal-with-project.yaml +++ b/tests/configs/cabal-with-project.yaml @@ -1,3 +1,3 @@ cradle: cabal: - cabalProject: "cabal.project.9.2.8" + cabalProject: "cabal.project.extra" diff --git a/tests/configs/multi-cabal-with-project.yaml b/tests/configs/multi-cabal-with-project.yaml --- a/tests/configs/multi-cabal-with-project.yaml +++ b/tests/configs/multi-cabal-with-project.yaml @@ -1,6 +1,6 @@ cradle: cabal: - cabalProject: "cabal.project.9.2.8" + cabalProject: "cabal.project.extra" components: - path: "./src" component: "lib:hie-bios" diff --git a/tests/projects/cabal-with-ghc-and-project/cabal.project.9.2.8 b/tests/projects/cabal-with-ghc-and-project/cabal.project.9.2.8 deleted file mode 100644 --- a/tests/projects/cabal-with-ghc-and-project/cabal.project.9.2.8 +++ /dev/null @@ -1,12 +0,0 @@ -packages: . - --- It is intended that this ghc version is different to at least one ghc version --- that is tested in CI. --- --- Project validates that hie-bios honours this field. --- --- If you change this, make sure to also change the 'extraGhc' constant in --- 'tests/BiosTests.hs'. --- --- Additionally, CI needs a proper setup to execute this test-case. -with-compiler: ghc-9.2.8 diff --git a/tests/projects/cabal-with-ghc-and-project/cabal.project.extra b/tests/projects/cabal-with-ghc-and-project/cabal.project.extra new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-ghc-and-project/cabal.project.extra @@ -0,0 +1,12 @@ +packages: . + +-- It is intended that this ghc version is different to at least one ghc version +-- that is tested in CI. +-- +-- Project validates that hie-bios honours this field. +-- +-- If you change this, make sure to also change the 'extraGhc' constant in +-- 'tests/BiosTests.hs'. +-- +-- Additionally, CI needs a proper setup to execute this test-case. +with-compiler: ghc-9.4.8 diff --git a/tests/projects/cabal-with-ghc-and-project/hie.yaml b/tests/projects/cabal-with-ghc-and-project/hie.yaml --- a/tests/projects/cabal-with-ghc-and-project/hie.yaml +++ b/tests/projects/cabal-with-ghc-and-project/hie.yaml @@ -1,3 +1,3 @@ cradle: cabal: - cabalProject: cabal.project.9.2.8 + cabalProject: cabal.project.extra diff --git a/tests/projects/cabal-with-ghc/cabal.project b/tests/projects/cabal-with-ghc/cabal.project --- a/tests/projects/cabal-with-ghc/cabal.project +++ b/tests/projects/cabal-with-ghc/cabal.project @@ -9,4 +9,4 @@ -- 'tests/BiosTests.hs'. -- -- Additionally, CI needs a proper setup to execute this test-case. -with-compiler: ghc-9.2.8 +with-compiler: ghc-9.4.8 diff --git a/tests/projects/cabal-with-project/cabal.project.9.2.8 b/tests/projects/cabal-with-project/cabal.project.9.2.8 deleted file mode 100644 --- a/tests/projects/cabal-with-project/cabal.project.9.2.8 +++ /dev/null @@ -1,5 +0,0 @@ --- Test file. -packages: ./ - -package cabal-with-project - ghc-options: -O2 diff --git a/tests/projects/cabal-with-project/cabal.project.extra b/tests/projects/cabal-with-project/cabal.project.extra new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-project/cabal.project.extra @@ -0,0 +1,5 @@ +-- Test file. +packages: ./ + +package cabal-with-project + ghc-options: -O2 diff --git a/tests/projects/cabal-with-project/hie.yaml b/tests/projects/cabal-with-project/hie.yaml --- a/tests/projects/cabal-with-project/hie.yaml +++ b/tests/projects/cabal-with-project/hie.yaml @@ -1,3 +1,3 @@ cradle: cabal: - cabalProject: cabal.project.9.2.8 + cabalProject: cabal.project.extra diff --git a/tests/projects/multi-cabal-with-project/cabal.project.9.2.8 b/tests/projects/multi-cabal-with-project/cabal.project.9.2.8 deleted file mode 100644 --- a/tests/projects/multi-cabal-with-project/cabal.project.9.2.8 +++ /dev/null @@ -1,6 +0,0 @@ -packages: ./appA ./appB - --- Only appA gets the config -package appA - ghc-options: -O2 - diff --git a/tests/projects/multi-cabal-with-project/cabal.project.extra b/tests/projects/multi-cabal-with-project/cabal.project.extra new file mode 100644 --- /dev/null +++ b/tests/projects/multi-cabal-with-project/cabal.project.extra @@ -0,0 +1,6 @@ +packages: ./appA ./appB + +-- Only appA gets the config +package appA + ghc-options: -O2 + diff --git a/tests/projects/multi-cabal-with-project/hie.yaml b/tests/projects/multi-cabal-with-project/hie.yaml --- a/tests/projects/multi-cabal-with-project/hie.yaml +++ b/tests/projects/multi-cabal-with-project/hie.yaml @@ -6,11 +6,11 @@ cabal: - path: appA/src component: appA:lib - cabalProject: cabal.project.9.2.8 + cabalProject: cabal.project.extra - path: "appB" config: cradle: cabal: - path: appB/src component: appB:lib - cabalProject: cabal.project.9.2.8 + cabalProject: cabal.project.extra diff --git a/wrappers/cabal-with-repl b/wrappers/cabal-with-repl new file mode 100644 --- /dev/null +++ b/wrappers/cabal-with-repl @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +function out(){ + echo "$1" >> "$HIE_BIOS_OUTPUT" +} + +out "$(pwd)" +for arg in "$@"; do + out "$arg" +done diff --git a/wrappers/cabal-with-repl.hs b/wrappers/cabal-with-repl.hs new file mode 100644 --- /dev/null +++ b/wrappers/cabal-with-repl.hs @@ -0,0 +1,14 @@ +module Main (main) where + +import System.Directory (getCurrentDirectory) +import System.Environment (getArgs, getEnv) +import System.IO (openFile, hClose, hPutStrLn, IOMode(..)) + +main :: IO () +main = do + args <- getArgs + output_file <- getEnv "HIE_BIOS_OUTPUT" + h <- openFile output_file AppendMode + getCurrentDirectory >>= hPutStrLn h + mapM_ (hPutStrLn h) args + hClose h