diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # ChangeLog hie-bios +## 2022-02-25 - 0.9.0 + +* Use the proper GHC version given by cabal [#282](https://github.com/haskell/hie-bios/pull/282) + * In particular, honour the `with-compiler` field in `cabal.project` +* Drop support for GHC 8.4 [#331](https://github.com/haskell/hie-bios/pull/331) + ## 2022-01-06 - 0.8.1 * Add support for GHC 9.0.2 [#322](https://github.com/haskell/hie-bios/pull/322) 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.8.1 +Version: 0.9.0 Author: Matthew Pickering Maintainer: Matthew Pickering License: BSD-3-Clause @@ -17,6 +17,10 @@ wrappers/cabal wrappers/cabal.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/symlink-test/a/A.hs tests/projects/symlink-test/hie.yaml tests/projects/deps-bios-new/A.hs @@ -121,7 +125,7 @@ tests/projects/stack-with-yaml/stack-with-yaml.cabal tests/projects/stack-with-yaml/src/Lib.hs -tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.0.2 || ==9.2.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.0.2 || ==9.2.1 Library Default-Language: Haskell2010 @@ -157,12 +161,11 @@ filepath >= 1.4.1 && < 1.5, time >= 1.8.0 && < 1.13, extra >= 1.6.14 && < 1.8, - exceptions, process >= 1.6.1 && < 1.7, - ghc >= 8.4.1 && < 9.3, + ghc >= 8.6.1 && < 9.3, transformers >= 0.5.2 && < 0.7, temporary >= 1.2 && < 1.4, - text >= 1.2.3 && < 1.3, + text >= 1.2.3 && < 2, unix-compat >= 0.5.1 && < 0.6, unordered-containers >= 0.2.9 && < 0.3, vector >= 0.12.0 && < 0.13, @@ -217,6 +220,7 @@ filepath, directory, temporary, + tagged, ghc hs-source-dirs: 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,7 +1,8 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} module HIE.Bios.Cradle ( findCradle , loadCradle @@ -22,46 +23,48 @@ , makeCradleResult ) where +import Control.Applicative ((<|>), optional) +import Data.Bifunctor (first) +import Control.DeepSeq import Control.Exception (handleJust) import qualified Data.Yaml as Yaml import Data.Void import Data.Char (isSpace) -import Data.Bifunctor (first) -import System.Process import System.Exit -import HIE.Bios.Types hiding (ActionName(..)) -import qualified HIE.Bios.Types as Types -import HIE.Bios.Config -import HIE.Bios.Environment (getCacheDir) -import qualified HIE.Bios.Ghc.Gap as Gap import System.Directory hiding (findFile) +import Control.Monad +import Control.Monad.Extra (unlessM) import Control.Monad.Trans.Cont import Control.Monad.Trans.Maybe -import System.FilePath -import Control.Monad -import System.Info.Extra import Control.Monad.IO.Class -import System.Environment -import Control.Applicative ((<|>), optional) -import System.IO.Temp -import System.IO.Error (isPermissionError) -import Data.List -import Data.Ord (Down(..)) - -import System.PosixCompat.Files -import HIE.Bios.Wrappers -import System.IO -import Control.DeepSeq - 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.Text as T import qualified Data.HashMap.Strict as Map -import Data.Maybe (fromMaybe, maybeToList) -import GHC.Fingerprint (fingerprintString) +import Data.Maybe (fromMaybe, maybeToList) +import Data.List +import Data.List.Extra (trimEnd) +import Data.Ord (Down(..)) +import qualified Data.Text as T +import System.Environment +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.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.Types as Types +import qualified HIE.Bios.Ghc.Gap as Gap + +import GHC.Fingerprint (fingerprintString) +import GHC.ResponseFile (escapeArgs) + hie_bios_output :: String hie_bios_output = "HIE_BIOS_OUTPUT" ---------------------------------------------------------------- @@ -98,7 +101,7 @@ getCradle buildCustomCradle (cc, wdir) = addCradleDeps cradleDeps $ case cradleType cc of Cabal CabalType{ cabalComponent = mc } -> cabalCradle wdir mc CabalMulti dc ms -> - getCradle buildCustomCradle $ + getCradle buildCustomCradle (CradleConfig cradleDeps (Multi [(p, CradleConfig [] (Cabal $ dc <> c)) | (p, c) <- ms]) , wdir) @@ -108,7 +111,7 @@ in stackCradle wdir mc stackYamlConfig StackMulti ds ms -> - getCradle buildCustomCradle $ + getCradle buildCustomCradle (CradleConfig cradleDeps (Multi [(p, CradleConfig [] (Stack $ ds <> c)) | (p, c) <- ms]) , wdir) @@ -129,14 +132,12 @@ addActionDeps :: CradleAction a -> CradleAction a addActionDeps ca = ca { runCradle = \l fp -> - runCradle ca l fp - >>= \case - CradleSuccess (ComponentOptions os' dir ds) -> - pure $ CradleSuccess (ComponentOptions os' dir (ds `union` deps)) - CradleFail err -> - pure $ CradleFail - (err { cradleErrorDependencies = cradleErrorDependencies err `union` deps }) - CradleNone -> pure CradleNone + (cradleLoadResult + CradleNone + (\err -> CradleFail (err { cradleErrorDependencies = cradleErrorDependencies err `union` deps })) + (\(ComponentOptions os' dir ds) -> CradleSuccess (ComponentOptions os' dir (ds `union` deps))) + ) + <$> runCradle ca l fp } -- | Try to infer an appropriate implicit cradle type from stuff we can find in the enclosing directories: @@ -334,7 +335,7 @@ canonicalizeCradles :: IO [(FilePath, CradleConfig b)] canonicalizeCradles = sortOn (Down . fst) - <$> mapM (\(p, c) -> (,c) <$> (makeAbsolute (cur_dir p))) cs + <$> mapM (\(p, c) -> (,c) <$> makeAbsolute (cur_dir p)) cs selectCradle [] = return (CradleFail (CradleError [] ExitSuccess err_msg)) @@ -412,7 +413,7 @@ callableToProcess :: Callable -> Maybe String -> IO CreateProcess callableToProcess (Command shellCommand) file = do old_env <- getEnvironment - return $ (shell shellCommand) { env = (: old_env) <$> (,) hieBiosArg <$> file } + return $ (shell shellCommand) { env = (: old_env) . (,) hieBiosArg <$> file } where hieBiosArg = "HIE_BIOS_ARG" callableToProcess (Program path) file = do @@ -428,19 +429,118 @@ { cradleRootDir = wdir , cradleOptsProg = CradleAction { actionName = Types.Cabal - , runCradle = cabalAction wdir mc - , runGhcCmd = \args -> do - buildDir <- cabalBuildDir wdir + , runCradle = \l f -> runCradleResultT . cabalAction wdir mc l $ f + , runGhcCmd = \args -> runCradleResultT $ 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) - createDirectoryIfMissing True (buildDir "tmp") + liftIO $ createDirectoryIfMissing True (buildDir "tmp") -- Need to pass -v0 otherwise we get "resolving dependencies..." - wrapper_fp <- withCabalWrapperTool ("ghc", []) wdir - readProcessWithCwd - wdir "cabal" (["--builddir="<>buildDir,"v2-exec","--with-compiler", wrapper_fp, "ghc", "-v0", "--"] ++ args) "" + cabalProc <- cabalProcess wdir "v2-exec" $ ["ghc", "-v0", "--"] ++ args + readProcessWithCwd' cabalProc "" } } +-- | 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 :: FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess +cabalProcess workDir command args = do + ghcDirs <- cabalGhcDirs workDir + newEnvironment <- liftIO $ setupEnvironment ghcDirs + cabalProc <- liftIO $ setupCabalCommand ghcDirs + 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 :: (FilePath, FilePath) -> IO CreateProcess + setupCabalCommand (ghcBin, libdir) = do + wrapper_fp <- withGhcWrapperTool ("ghc", []) workDir + buildDir <- cabalBuildDir workDir + ghcPkgPath <- withGhcPkgTool ghcBin libdir + let extraCabalArgs = + [ "--builddir=" <> buildDir + , command + , "--with-compiler", wrapper_fp + , "--with-hc-pkg", ghcPkgPath + ] + 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' rootDir componentDir@. -- Compute the dependencies of the cabal cradle based -- on the cradle root and the component directory. @@ -473,8 +573,7 @@ let final_args = removeVerbosityOpts $ removeRTS - $ removeInteractive - $ ghc_args + $ removeInteractive ghc_args in Just (dir, final_args) _ -> Nothing @@ -483,69 +582,103 @@ -- arguments to the executable. type GhcProc = (FilePath, [String]) --- | Generate a fake GHC that can be passed to cabal +-- | 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 -withCabalWrapperTool :: GhcProc -> FilePath -> IO FilePath -withCabalWrapperTool (mbGhc, ghcArgs) wdir = do - cacheDir <- getCacheDir "" - createDirectoryIfMissing True cacheDir +withGhcWrapperTool :: GhcProc -> FilePath -> IO FilePath +withGhcWrapperTool (mbGhc, ghcArgs) wdir = do let wrapperContents = if isWindows then cabalWrapperHs else cabalWrapper - suffix fp = if isWindows then fp <.> "exe" else fp - let srcHash = show (fingerprintString wrapperContents) - let wrapper_name = "wrapper-" ++ srcHash - let wrapper_fp = suffix $ cacheDir wrapper_name - exists <- doesFileExist wrapper_fp - unless exists $ + withExtension fp = if isWindows then fp <.> "exe" else fp + srcHash = show (fingerprintString wrapperContents) + cacheFile (withExtension "wrapper") srcHash $ \wrapper_fp -> if isWindows - then do + then withSystemTempDirectory "hie-bios" $ \ tmpDir -> do - let wrapper_hs = cacheDir wrapper_name <.> "hs" + let wrapper_hs = wrapper_fp -<.> "hs" writeFile wrapper_hs wrapperContents let ghc = (proc mbGhc $ ghcArgs ++ ["-rtsopts=ignore", "-outputdir", tmpDir, "-o", wrapper_fp, wrapper_hs]) { cwd = Just wdir } readCreateProcess ghc "" >>= putStr else writeFile wrapper_fp wrapperContents - setMode wrapper_fp - pure wrapper_fp + +-- | 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 work_dir = do - abs_work_dir <- makeAbsolute work_dir +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) + getCacheDir ("dist-" <> filter (not . isSpace) (takeBaseName abs_work_dir)<>"-"<>dirHash) -cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions) -cabalAction work_dir mc l fp = do - wrapper_fp <- withCabalWrapperTool ("ghc", []) work_dir - buildDir <- cabalBuildDir work_dir - let cab_args = ["--builddir="<>buildDir,"v2-repl", "--with-compiler", wrapper_fp, fromMaybe (fixTargetPath fp) mc] - (ex, output, stde, [(_,mb_args)]) <- - readProcessWithOutputs [hie_bios_output] l work_dir (proc "cabal" cab_args) - let args = fromMaybe [] mb_args - case processCabalWrapperArgs args of - Nothing -> do - -- Best effort. Assume the working directory is the - -- the root of the component, so we are right in trivial cases at least. - deps <- cabalCradleDependencies work_dir work_dir - pure $ CradleFail (CradleError deps ex - ["Failed to parse result of calling cabal" - , unlines output - , unlines stde - , unlines $ args]) - Just (componentDir, final_args) -> do - deps <- cabalCradleDependencies work_dir componentDir - pure $ makeCradleResult (ex, stde, componentDir, final_args) deps +-- | 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 :: FilePath -> CradleLoadResultT IO (FilePath, FilePath) +cabalGhcDirs workDir = do + libdir <- readProcessWithCwd_ workDir "cabal" ["exec", "-v0", "--", "ghc", "--print-libdir"] "" + exe <- readProcessWithCwd_ workDir "cabal" + ["exec", "-v0", "--", "ghc", "-package-env=-", "-e", "do e <- System.Environment.getExecutablePath ; System.IO.putStr e"] "" + pure (trimEnd exe, trimEnd libdir) + +cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> CradleLoadResultT IO ComponentOptions +cabalAction workDir mc l fp = do + cabalProc <- (cabalProcess workDir "v2-repl" [fromMaybe (fixTargetPath fp) mc]) `modCradleError` \err -> do + deps <- cabalCradleDependencies workDir workDir + pure $ err { cradleErrorDependencies = cradleErrorDependencies err ++ deps } + + (ex, output, stde, [(_, maybeArgs)]) <- liftIO $ readProcessWithOutputs [hie_bios_output] l workDir cabalProc + + let args = fromMaybe [] maybeArgs + 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 workDir workDir + throwCE (CradleError deps ex + ["Failed to parse result of calling cabal" + , unlines output + , unlines stde + , unlines $ args]) + Just (componentDir, final_args) -> do + deps <- liftIO $ cabalCradleDependencies workDir componentDir + CradleLoadResultT $ pure $ makeCradleResult (ex, stde, componentDir, final_args) deps where -- Need to make relative on Windows, due to a Cabal bug with how it -- parses file targets with a C: drive in it fixTargetPath x - | isWindows && hasDrive x = makeRelative work_dir x + | isWindows && hasDrive x = makeRelative workDir x | otherwise = x removeInteractive :: [String] -> [String] @@ -621,14 +754,13 @@ , cradleOptsProg = CradleAction { actionName = Types.Stack , runCradle = stackAction wdir mc syaml - , runGhcCmd = \args -> do + , 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 - stackSetup <- readProcessWithCwd wdir "stack" (stackYamlProcessArgs syaml <> ["setup", "--silent"]) "" - stackSetup `bindIO` \_ -> - readProcessWithCwd wdir "stack" - (stackYamlProcessArgs syaml <> ["exec", "ghc", "--"] <> args) - "" + _ <- readProcessWithCwd_ wdir "stack" (stackYamlProcessArgs syaml <> ["setup", "--silent"]) "" + readProcessWithCwd_ wdir "stack" + (stackYamlProcessArgs syaml <> ["exec", "ghc", "--"] <> args) + "" } } @@ -650,26 +782,26 @@ cabalFiles ++ [relFp "package.yaml", stackYamlLocationOrDefault syaml] stackAction :: FilePath -> Maybe String -> StackYaml -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions) -stackAction work_dir mc syaml l _fp = do +stackAction workDir mc syaml l _fp = do let ghcProcArgs = ("stack", stackYamlProcessArgs syaml <> ["exec", "ghc", "--"]) -- Same wrapper works as with cabal - wrapper_fp <- withCabalWrapperTool ghcProcArgs work_dir - (ex1, _stdo, stde, [(_, mb_args)]) <- - readProcessWithOutputs [hie_bios_output] l work_dir $ + wrapper_fp <- withGhcWrapperTool ghcProcArgs workDir + (ex1, _stdo, stde, [(_, maybeArgs)]) <- + 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 work_dir $ + readProcessWithOutputs [hie_bios_output] l workDir $ stackProcess syaml ["path", "--ghc-package-path"] let split_pkgs = concatMap splitSearchPath pkg_args pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs - args = fromMaybe [] mb_args + args = fromMaybe [] maybeArgs case processCabalWrapperArgs args of Nothing -> do -- Best effort. Assume the working directory is the -- the root of the component, so we are right in trivial cases at least. - deps <- stackCradleDependencies work_dir work_dir syaml + deps <- stackCradleDependencies workDir workDir syaml pure $ CradleFail (CradleError deps ex1 $ [ "Failed to parse result of calling stack" ] @@ -678,7 +810,7 @@ ) Just (componentDir, ghc_args) -> do - deps <- stackCradleDependencies work_dir componentDir syaml + deps <- stackCradleDependencies workDir componentDir syaml pure $ makeCradleResult ( combineExitCodes [ex1, ex2] , stde ++ stdr, componentDir @@ -730,15 +862,15 @@ bazelCommand = $(embedStringFile "wrappers/bazel") rulesHaskellAction :: FilePath -> FilePath -> IO (CradleLoadResult ComponentOptions) -rulesHaskellAction work_dir fp = do +rulesHaskellAction workDir fp = do wrapper_fp <- writeSystemTempFile "wrapper" bazelCommand setFileMode wrapper_fp accessModes - let rel_path = makeRelative work_dir fp + let rel_path = makeRelative workDir fp (ex, args, stde) <- - readProcessWithOutputFile work_dir wrapper_fp [rel_path] [] + readProcessWithOutputFile workDir wrapper_fp [rel_path] [] let args' = filter (/= '\'') args let args'' = filter (/= "\"$GHCI_LOCATION\"") (words args') - deps <- rulesHaskellCradleDependencies work_dir + deps <- rulesHaskellCradleDependencies workDir return $ makeCradleResult (ex, stde, args'') deps @@ -769,11 +901,11 @@ } obeliskAction :: FilePath -> FilePath -> IO (CradleLoadResult ComponentOptions) -obeliskAction work_dir _fp = do +obeliskAction workDir _fp = do (ex, args, stde) <- - readProcessWithOutputFile work_dir "ob" ["ide-args"] [] + readProcessWithOutputFile workDir "ob" ["ide-args"] [] - o_deps <- obeliskCradleDependencies work_dir + o_deps <- obeliskCradleDependencies workDir return (makeCradleResult (ex, stde, words args) o_deps ) -} @@ -808,13 +940,12 @@ 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 +-- | 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 - e <- getEnvironment - return $ Map.toList $ Map.delete "GHC_PACKAGE_PATH" $ Map.fromList e + Map.toList . Map.delete "GHC_PACKAGE_PATH" . Map.fromList <$> getEnvironment type Outputs = [OutputName] type OutputName = String @@ -831,16 +962,17 @@ -> 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 work_dir cp = flip runContT return $ do +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 work_dir + 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 l C..| C.sinkList + let loggingConduit = C.decodeUtf8 C..| C.lines C..| C.filterE (/= '\r') + C..| C.map T.unpack C..| C.iterM l C..| C.sinkList (ex, stdo, stde) <- liftIO $ sourceProcessWithStreams process mempty loggingConduit loggingConduit res <- forM output_files $ \(name,path) -> @@ -890,15 +1022,31 @@ -- case mResult of -- Nothing --- | Wrapper around 'readCreateProcess' that sets the working directory +-- | Wrapper around 'readCreateProcess' that sets the working directory and +-- clears the environment, suitable for invoking cabal/stack and raw ghc commands. readProcessWithCwd :: FilePath -> FilePath -> [String] -> String -> IO (CradleLoadResult String) -readProcessWithCwd dir cmd args stdi = do - cleanEnv <- getCleanEnvironment +readProcessWithCwd dir cmd args stdin = runCradleResultT $ readProcessWithCwd_ dir cmd args stdin + +readProcessWithCwd_ :: FilePath -> FilePath -> [String] -> String -> CradleLoadResultT IO String +readProcessWithCwd_ dir cmd args stdin = do + cleanEnv <- liftIO getCleanEnvironment let createProc = (proc cmd args) { cwd = Just dir, env = Just cleanEnv } - mResult <- optional $ readCreateProcessWithExitCode createProc stdi + readProcessWithCwd' createProc stdin + +-- | Wrapper around 'readCreateProcessWithExitCode', wrapping the result in +-- a 'CradleLoadResult'. Provides better error messages than raw 'readCreateProcess'. +readProcessWithCwd' :: CreateProcess -> String -> CradleLoadResultT IO String +readProcessWithCwd' createdProcess stdin = do + mResult <- liftIO $ optional $ readCreateProcessWithExitCode createdProcess stdin + let cmdString = prettyCmdSpec $ cmdspec createdProcess case mResult of - Just (ExitSuccess, stdo, _) -> pure $ CradleSuccess stdo - Just (exitCode, stdo, stde) -> pure $ CradleFail $ - CradleError [] exitCode ["Error when calling " <> cmd <> " " <> unwords args, stdo, stde] - Nothing -> pure $ CradleFail $ - CradleError [] ExitSuccess ["Couldn't execute " <> cmd <> " " <> unwords args] + Just (ExitSuccess, stdo, _) -> pure stdo + Just (exitCode, stdo, stde) -> throwCE $ + CradleError [] exitCode ["Error when calling " <> cmdString, stdo, stde] + Nothing -> throwCE $ + CradleError [] ExitSuccess ["Couldn't execute " <> cmdString] + +-- | 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 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 @@ -1,6 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE DeriveFoldable #-} @@ -9,6 +12,12 @@ import System.Exit import Control.Exception ( Exception ) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif data BIOSVerbosity = Silent | Verbose @@ -68,6 +77,10 @@ | CradleNone -- ^ No attempt was made to load the cradle. deriving (Functor, Foldable, Traversable, Show, Eq) +cradleLoadResult :: c -> (CradleError -> c) -> (r -> c) -> CradleLoadResult r -> c +cradleLoadResult c _ _ CradleNone = c +cradleLoadResult _ f _ (CradleFail e) = f e +cradleLoadResult _ _ f (CradleSuccess r) = f r instance Applicative CradleLoadResult where pure = CradleSuccess @@ -82,11 +95,65 @@ CradleFail err >>= _ = CradleFail err CradleNone >>= _ = CradleNone -bindIO :: CradleLoadResult a -> (a -> IO (CradleLoadResult b)) -> IO (CradleLoadResult b) -bindIO (CradleSuccess r) k = k r -bindIO (CradleFail err) _ = return $ CradleFail err -bindIO CradleNone _ = return CradleNone +newtype CradleLoadResultT m a = CradleLoadResultT { runCradleResultT :: m (CradleLoadResult a) } +instance Functor f => Functor (CradleLoadResultT f) where + {-# INLINE fmap #-} + fmap f = CradleLoadResultT . (fmap . fmap) f . runCradleResultT + +instance (Monad m, Applicative m) => Applicative (CradleLoadResultT m) where + {-# INLINE pure #-} + pure = CradleLoadResultT . pure . CradleSuccess + {-# INLINE (<*>) #-} + x <*> f = CradleLoadResultT $ do + a <- runCradleResultT x + case a of + CradleSuccess a' -> do + b <- runCradleResultT f + case b of + CradleSuccess b' -> pure (CradleSuccess (a' b')) + CradleFail err -> pure $ CradleFail err + CradleNone -> pure CradleNone + CradleFail err -> pure $ CradleFail err + CradleNone -> pure CradleNone + +instance Monad m => Monad (CradleLoadResultT m) where + {-# INLINE return #-} + return = CradleLoadResultT . return . CradleSuccess + {-# INLINE (>>=) #-} + x >>= f = CradleLoadResultT $ do + val <- runCradleResultT x + case val of + CradleSuccess r -> runCradleResultT . f $ r + CradleFail err -> return $ CradleFail err + CradleNone -> return $ CradleNone +#if !(MIN_VERSION_base(4,13,0)) + fail = CradleLoadResultT . fail + {-# INLINE fail #-} +#endif +#if MIN_VERSION_base(4,9,0) +instance Fail.MonadFail m => Fail.MonadFail (CradleLoadResultT m) where + fail = CradleLoadResultT . Fail.fail + {-# INLINE fail #-} +#endif + +instance MonadTrans CradleLoadResultT where + lift = CradleLoadResultT . liftM CradleSuccess + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (CradleLoadResultT m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +modCradleError :: Monad m => CradleLoadResultT m a -> (CradleError -> m CradleError) -> CradleLoadResultT m a +modCradleError action f = CradleLoadResultT $ do + a <- runCradleResultT action + case a of + CradleFail err -> CradleFail <$> f err + _ -> pure a + +throwCE :: Monad m => CradleError -> CradleLoadResultT m a +throwCE = CradleLoadResultT . return . CradleFail data CradleError = CradleError { cradleErrorDependencies :: [FilePath] diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -2,13 +2,15 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} module Main where import Test.Tasty import Test.Tasty.HUnit -#if __GLASGOW_HASKELL__ < 810 import Test.Tasty.ExpectedFailure -#endif +import qualified Test.Tasty.Options as Tasty +import qualified Test.Tasty.Ingredients as Tasty import qualified GHC as G import HIE.Bios import HIE.Bios.Ghc.Api @@ -18,8 +20,9 @@ import HIE.Bios.Types import Control.Monad.IO.Class import Control.Monad ( forM_, unless ) +import Data.List ( sort, isPrefixOf, isInfixOf ) +import Data.Typeable import Data.Void -import Data.List ( sort, isPrefixOf ) import System.Directory import System.FilePath (addTrailingPathSeparator, makeRelative, () ) import System.Info.Extra ( isWindows ) @@ -31,10 +34,25 @@ argDynamic :: [String] argDynamic = ["-dynamic" | Gap.hostIsDynamic] +-- | This ghc version is assumed to be tested by CI to validate +-- the "with-compiler" field is honoured by hie-bios. +-- +-- If you change this version, make sure to also update 'cabal.project' +-- in 'tests\/projects\/cabal-with-ghc'. +extraGhcVersion :: String +extraGhcVersion = "8.10.7" + +extraGhc :: String +extraGhc = "ghc-" ++ extraGhcVersion + main :: IO () main = do writeStackYamlFiles - defaultMain $ + stackDep <- checkToolIsAvailable "stack" + cabalDep <- checkToolIsAvailable "cabal" + extraGhcDep <- checkToolIsAvailable extraGhc + + defaultMainWithIngredients (ignoreToolTests:defaultIngredients) $ testGroup "Bios-tests" [ testGroup "Find cradle" [ testCaseSteps "simple-cabal" @@ -93,89 +111,10 @@ _ -> assertFailure "Cradle loaded symlink" ] , testGroup "Loading tests" - $ linuxExlusiveTestCases - ++ - [ testCaseSteps "failing-cabal" $ testDirectoryFail isCabalCradle "./tests/projects/failing-cabal" "MyLib.hs" - (\CradleError {..} -> do - cradleErrorExitCode @?= ExitFailure 1 - cradleErrorDependencies `shouldMatchList` ["failing-cabal.cabal", "cabal.project", "cabal.project.local"]) - , testCaseSteps "failing-bios" $ testDirectoryFail isBiosCradle "./tests/projects/failing-bios" "B.hs" - (\CradleError {..} -> do - cradleErrorExitCode @?= ExitFailure 1 - cradleErrorDependencies `shouldMatchList` ["hie.yaml"]) - , testCaseSteps "failing-bios-ghc" $ testGetGhcVersionFail isBiosCradle "./tests/projects/failing-bios-ghc" "B.hs" - (\CradleError {..} -> do - cradleErrorExitCode @?= ExitSuccess - cradleErrorDependencies `shouldMatchList` [] - length cradleErrorStderr @?= 1 - "Couldn't execute myGhc" `isPrefixOf` head cradleErrorStderr @? "Error message should contain basic information" ) - , testCaseSteps "simple-bios-shell" $ testDirectory isBiosCradle "./tests/projects/simple-bios-shell" "B.hs" - , testCaseSteps "simple-bios-shell-deps" $ testLoadCradleDependencies isBiosCradle "./tests/projects/simple-bios-shell" "B.hs" (assertEqual "dependencies" ["hie.yaml"]) - , testCaseSteps "simple-cabal" $ testDirectory isCabalCradle "./tests/projects/simple-cabal" "B.hs" - , testCaseSteps "simple-direct" $ testDirectory isDirectCradle "./tests/projects/simple-direct" "B.hs" - , testCaseSteps "nested-cabal" $ testLoadCradleDependencies isCabalCradle "./tests/projects/nested-cabal" "sub-comp/Lib.hs" - (\deps -> deps `shouldMatchList` ["sub-comp" "sub-comp.cabal", "cabal.project", "cabal.project.local"] - ) - , testCaseSteps "nested-cabal2" $ testLoadCradleDependencies isCabalCradle "./tests/projects/nested-cabal" "MyLib.hs" - (\deps -> deps `shouldMatchList` ["nested-cabal.cabal", "cabal.project", "cabal.project.local"] - ) - , testCaseSteps "multi-direct" {- tests if both components can be loaded -} - $ testDirectory isMultiCradle "./tests/projects/multi-direct" "A.hs" - >> testDirectory isMultiCradle "./tests/projects/multi-direct" "B.hs" - , testCaseSteps "multi-cabal" {- tests if both components can be loaded -} - $ testDirectory isCabalCradle "./tests/projects/multi-cabal" "app/Main.hs" - >> testDirectory isCabalCradle "./tests/projects/multi-cabal" "src/Lib.hs" - , testCaseSteps "monorepo-cabal" {- issue https://github.com/mpickering/hie-bios/issues/200 -} - $ testDirectory isCabalCradle "./tests/projects/monorepo-cabal" "A/Main.hs" - >> testDirectory isCabalCradle "./tests/projects/monorepo-cabal" "B/MyLib.hs" --- TODO: Remove once stack and ghc-8.10.1 play well --- https://github.com/bubba/hie-bios/runs/811271872?check_suite_focus=true -#if __GLASGOW_HASKELL__ < 810 - , expectFailBecause "stack repl does not fail on an invalid cabal file" $ - testCaseSteps "failing-stack" $ testDirectoryFail isStackCradle "./tests/projects/failing-stack" "src/Lib.hs" - (\CradleError {..} -> do - cradleErrorExitCode @?= ExitFailure 1 - cradleErrorDependencies `shouldMatchList` ["failing-stack.cabal", "stack.yaml", "package.yaml"]) - , testCaseSteps "simple-stack" $ testDirectory isStackCradle "./tests/projects/simple-stack" "B.hs" - , testCaseSteps "multi-stack" {- tests if both components can be loaded -} - $ testDirectory isStackCradle "./tests/projects/multi-stack" "app/Main.hs" - >> testDirectory isStackCradle "./tests/projects/multi-stack" "src/Lib.hs" - , testCaseSteps "nested-stack" $ testLoadCradleDependencies isStackCradle "./tests/projects/nested-stack" "sub-comp/Lib.hs" - (\deps -> deps `shouldMatchList` - ["sub-comp" "sub-comp.cabal", "sub-comp" "package.yaml", "stack.yaml"] - ) - , testCaseSteps "nested-stack2" $ testLoadCradleDependencies isStackCradle "./tests/projects/nested-stack" "MyLib.hs" - (\deps -> deps `shouldMatchList` ["nested-stack.cabal", "package.yaml", "stack.yaml"] - ) - , testCaseSteps "stack-with-yaml" {- tests if both components can be loaded -} - $ testDirectory isStackCradle "./tests/projects/stack-with-yaml" "app/Main.hs" - >> testDirectory isStackCradle "./tests/projects/stack-with-yaml" "src/Lib.hs" - , testCaseSteps "multi-stack-with-yaml" {- tests if both components can be loaded -} - $ testDirectory isStackCradle "./tests/projects/multi-stack-with-yaml" "appA/src/Lib.hs" - >> testDirectory isStackCradle "./tests/projects/multi-stack-with-yaml" "appB/src/Lib.hs" - , - -- Test for special characters in the path for parsing of the ghci-scripts. - -- Issue https://github.com/mpickering/hie-bios/issues/162 - testCaseSteps "space stack" - $ testDirectory isStackCradle "./tests/projects/space stack" "A.hs" - >> testDirectory isStackCradle "./tests/projects/space stack" "B.hs" -#endif - ] - , testGroup "Implicit cradle tests" $ - [ testCaseSteps "implicit-cabal" $ - testImplicitCradle "./tests/projects/implicit-cabal" "Main.hs" Cabal - , testCaseSteps "implicit-cabal-no-project" $ - testImplicitCradle "./tests/projects/implicit-cabal-no-project" "Main.hs" Cabal - , testCaseSteps "implicit-cabal-deep-project" $ - testImplicitCradle "./tests/projects/implicit-cabal-deep-project" "foo/Main.hs" Cabal --- TODO: same here -#if __GLASGOW_HASKELL__ < 810 - , testCaseSteps "implicit-stack" $ - testImplicitCradle "./tests/projects/implicit-stack" "Main.hs" Stack - , testCaseSteps "implicit-stack-multi" - $ testImplicitCradle "./tests/projects/implicit-stack-multi" "Main.hs" Stack - >> testImplicitCradle "./tests/projects/implicit-stack-multi" "other-package/Main.hs" Stack -#endif + [ testGroup "bios" biosTestCases + , testGroup "direct" directTestCases + , testGroupWithDependency cabalDep (cabalTestCases extraGhcDep) + , ignoreOnGhc9AndNewer $ testGroupWithDependency stackDep stackTestCases ] ] @@ -190,6 +129,107 @@ | otherwise = [] +cabalTestCases :: ToolDependency -> [TestTree] +cabalTestCases extraGhcDep = + [ testCaseSteps "failing-cabal" $ testDirectoryFail isCabalCradle "./tests/projects/failing-cabal" "MyLib.hs" + (\CradleError {..} -> do + cradleErrorExitCode @?= ExitFailure 1 + cradleErrorDependencies `shouldMatchList` ["failing-cabal.cabal", "cabal.project", "cabal.project.local"]) + , testCaseSteps "simple-cabal" $ testDirectory isCabalCradle "./tests/projects/simple-cabal" "B.hs" + , testCaseSteps "nested-cabal" $ testLoadCradleDependencies isCabalCradle "./tests/projects/nested-cabal" "sub-comp/Lib.hs" + (\deps -> deps `shouldMatchList` ["sub-comp" "sub-comp.cabal", "cabal.project", "cabal.project.local"] + ) + , testCaseSteps "nested-cabal2" $ testLoadCradleDependencies isCabalCradle "./tests/projects/nested-cabal" "MyLib.hs" + (\deps -> deps `shouldMatchList` ["nested-cabal.cabal", "cabal.project", "cabal.project.local"] + ) + , testCaseSteps "multi-cabal" {- tests if both components can be loaded -} + $ testDirectory isCabalCradle "./tests/projects/multi-cabal" "app/Main.hs" + >> testDirectory isCabalCradle "./tests/projects/multi-cabal" "src/Lib.hs" + , testCaseSteps "monorepo-cabal" {- issue https://github.com/mpickering/hie-bios/issues/200 -} + $ testDirectory isCabalCradle "./tests/projects/monorepo-cabal" "A/Main.hs" + >> testDirectory isCabalCradle "./tests/projects/monorepo-cabal" "B/MyLib.hs" + , testGroup "Implicit cradle tests" $ + [ testCaseSteps "implicit-cabal" $ + testImplicitCradle "./tests/projects/implicit-cabal" "Main.hs" Cabal + , testCaseSteps "implicit-cabal-no-project" $ + testImplicitCradle "./tests/projects/implicit-cabal-no-project" "Main.hs" Cabal + , testCaseSteps "implicit-cabal-deep-project" $ + testImplicitCradle "./tests/projects/implicit-cabal-deep-project" "foo/Main.hs" Cabal + ] + , testGroupWithDependency extraGhcDep + [ testCaseSteps "Appropriate ghc and libdir" $ \step -> do + fp <- canonicalizePath "./tests/projects/cabal-with-ghc/src/MyLib.hs" + crd <- initialiseCradle isCabalCradle fp step + step "Get runtime GHC library directory" + testGetGhcLibDir crd extraGhcVersion + step "Get runtime GHC version" + testGetGhcVersion crd extraGhcVersion + ] + ] + +stackTestCases :: [TestTree] +stackTestCases = + [ expectFailBecause "stack repl does not fail on an invalid cabal file" $ + testCaseSteps "failing-stack" $ testDirectoryFail isStackCradle "./tests/projects/failing-stack" "src/Lib.hs" + (\CradleError {..} -> do + cradleErrorExitCode @?= ExitFailure 1 + cradleErrorDependencies `shouldMatchList` ["failing-stack.cabal", "stack.yaml", "package.yaml"]) + , testCaseSteps "simple-stack" $ testDirectory isStackCradle "./tests/projects/simple-stack" "B.hs" + , testCaseSteps "multi-stack" {- tests if both components can be loaded -} + $ testDirectory isStackCradle "./tests/projects/multi-stack" "app/Main.hs" + >> testDirectory isStackCradle "./tests/projects/multi-stack" "src/Lib.hs" + , testCaseSteps "nested-stack" $ testLoadCradleDependencies isStackCradle "./tests/projects/nested-stack" "sub-comp/Lib.hs" + (\deps -> deps `shouldMatchList` + ["sub-comp" "sub-comp.cabal", "sub-comp" "package.yaml", "stack.yaml"] + ) + , testCaseSteps "nested-stack2" $ testLoadCradleDependencies isStackCradle "./tests/projects/nested-stack" "MyLib.hs" + (\deps -> deps `shouldMatchList` ["nested-stack.cabal", "package.yaml", "stack.yaml"] + ) + , testCaseSteps "stack-with-yaml" {- tests if both components can be loaded -} + $ testDirectory isStackCradle "./tests/projects/stack-with-yaml" "app/Main.hs" + >> testDirectory isStackCradle "./tests/projects/stack-with-yaml" "src/Lib.hs" + , testCaseSteps "multi-stack-with-yaml" {- tests if both components can be loaded -} + $ testDirectory isStackCradle "./tests/projects/multi-stack-with-yaml" "appA/src/Lib.hs" + >> testDirectory isStackCradle "./tests/projects/multi-stack-with-yaml" "appB/src/Lib.hs" + , + -- Test for special characters in the path for parsing of the ghci-scripts. + -- Issue https://github.com/mpickering/hie-bios/issues/162 + testCaseSteps "space stack" + $ testDirectory isStackCradle "./tests/projects/space stack" "A.hs" + >> testDirectory isStackCradle "./tests/projects/space stack" "B.hs" + , testGroup "Implicit cradle tests" + [ testCaseSteps "implicit-stack" $ + testImplicitCradle "./tests/projects/implicit-stack" "Main.hs" Stack + , testCaseSteps "implicit-stack-multi" + $ testImplicitCradle "./tests/projects/implicit-stack-multi" "Main.hs" Stack + >> testImplicitCradle "./tests/projects/implicit-stack-multi" "other-package/Main.hs" Stack + ] + ] + +biosTestCases :: [TestTree] +biosTestCases = + [ testCaseSteps "failing-bios" $ testDirectoryFail isBiosCradle "./tests/projects/failing-bios" "B.hs" + (\CradleError {..} -> do + cradleErrorExitCode @?= ExitFailure 1 + cradleErrorDependencies `shouldMatchList` ["hie.yaml"]) + , testCaseSteps "failing-bios-ghc" $ testGetGhcVersionFail isBiosCradle "./tests/projects/failing-bios-ghc" "B.hs" + (\CradleError {..} -> do + cradleErrorExitCode @?= ExitSuccess + cradleErrorDependencies `shouldMatchList` [] + length cradleErrorStderr @?= 1 + "Couldn't execute myGhc" `isPrefixOf` head cradleErrorStderr @? "Error message should contain basic information" ) + , testCaseSteps "simple-bios-shell" $ testDirectory isBiosCradle "./tests/projects/simple-bios-shell" "B.hs" + , testCaseSteps "simple-bios-shell-deps" $ testLoadCradleDependencies isBiosCradle "./tests/projects/simple-bios-shell" "B.hs" (assertEqual "dependencies" ["hie.yaml"]) + ] + +directTestCases :: [TestTree] +directTestCases = + [ testCaseSteps "simple-direct" $ testDirectory isDirectCradle "./tests/projects/simple-direct" "B.hs" + , testCaseSteps "multi-direct" {- tests if both components can be loaded -} + $ testDirectory isMultiCradle "./tests/projects/multi-direct" "A.hs" + >> testDirectory isMultiCradle "./tests/projects/multi-direct" "B.hs" + ] + testDirectory :: (Cradle Void -> Bool) -> FilePath -> FilePath -> (String -> IO ()) -> IO () testDirectory cradlePred rootDir file step = -- We need to copy over the directory to somewhere outside the source tree @@ -199,29 +239,34 @@ fp <- canonicalizePath (rootDir' file) crd <- initialiseCradle cradlePred fp step step "Get runtime GHC library directory" - testGetGhcLibDir crd + testGetGhcLibDir crd VERSION_ghc step "Get runtime GHC version" - testGetGhcVersion crd + testGetGhcVersion crd VERSION_ghc step "Initialise Flags" testLoadFile crd fp step -- | Here we are testing that the cradle's method of obtaining the ghcLibDir -- always works. -testGetGhcLibDir :: Cradle a -> IO () -testGetGhcLibDir crd = do +testGetGhcLibDir :: Cradle a -> String -> IO () +testGetGhcLibDir crd ghcVersion = do libDirRes <- getRuntimeGhcLibDir crd - isSuccess libDirRes @? "Must succeed loading ghc lib directory" - where isSuccess (CradleSuccess _) = True - isSuccess _ = False + isSuccess libDirRes + where + -- heuristically test that the produced $libdir makes sense. + isSuccess (CradleSuccess path) = + ghcVersion `isInfixOf` path @? "Expected \"" ++ ghcVersion + ++ "\" to be infix of: " ++ path + isSuccess _ = + assertFailure "Must succeed loading ghc lib directory" -- | Here we are testing that the cradle's method of getting the runtime ghc -- version is correct - which while testing, should be the version that we have -- built the tests with. This will fail if you compiled the tests with a ghc -- that doesn't equal the ghc on your path though :( -testGetGhcVersion :: Cradle a -> IO () -testGetGhcVersion crd = do +testGetGhcVersion :: Cradle a -> String -> IO () +testGetGhcVersion crd ghcVersion = do version <- getRuntimeGhcVersion crd - version @?= CradleSuccess VERSION_ghc + version @?= CradleSuccess ghcVersion testGetGhcVersionFail :: (Cradle Void -> Bool) -> FilePath -> FilePath -> (CradleError -> Assertion) -> (String -> IO ()) -> IO () testGetGhcVersionFail cradlePred rootDir file cradleFailPred step = @@ -393,10 +438,76 @@ "lts-14.27" -- GHC 8.6.5 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,4,0))) "lts-13.19" -- GHC 8.6.4 -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,4,0))) - "lts-12.26" -- GHC 8.4.4 -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,3,0))) - "lts-12.14" -- GHC 8.4.3 -#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,2,2,0))) - "lts-11.22" -- GHC 8.2.2 #endif + +-- ------------------------------------------------------------------ +-- Most tests have some run-time tool dependencies. +-- We only want to run tests if these tools are available. +-- ------------------------------------------------------------------ + +data ToolDependency = ToolDependency + { toolName :: String + , toolExists :: Bool + } + +checkToolIsAvailable :: String -> IO ToolDependency +checkToolIsAvailable f = do + exists <- maybe False (const True) <$> findExecutable f + pure ToolDependency + { toolName = f + , toolExists = exists + } + +testGroupWithDependency :: ToolDependency -> [TestTree] -> TestTree +testGroupWithDependency td tc = askOption @IgnoreToolDeps (\case + IgnoreToolDeps ignoreToolDep + | ignoreToolDep || toolExists td -> tg + | otherwise -> itg + ) + where + tg = testGroup (toolName td) tc + + itg = + ignoreTestBecause + ("These tests require that the following" ++ + " tool can be found on the path: " ++ toolName td) + tg + +-- ------------------------------------------------------------------ +-- Run test-suite ignoring run-time tool dependencies. +-- Can be used to force CI to run the whole test-suite. +-- Makes sure that the full test-suite is being run on a properly configured +-- environment. +-- ------------------------------------------------------------------ + +-- | This option, when set to 'True', specifies that we should run in the +-- «list tests» mode +newtype IgnoreToolDeps = IgnoreToolDeps Bool + deriving (Eq, Ord, Typeable) + +instance Tasty.IsOption IgnoreToolDeps where + defaultValue = IgnoreToolDeps False + parseValue = fmap IgnoreToolDeps . Tasty.safeReadBool + optionName = pure "ignore-tool-deps" + optionHelp = pure "Run tests whether their tool dependencies exist or not" + optionCLParser = Tasty.flagCLParser Nothing (IgnoreToolDeps True) + +-- | The ingredient that provides the test listing functionality +ignoreToolTests :: Tasty.Ingredient +ignoreToolTests = Tasty.TestManager [Tasty.Option (Proxy :: Proxy IgnoreToolDeps)] $ + \opts _tree -> + case Tasty.lookupOption opts of + IgnoreToolDeps False -> Nothing + IgnoreToolDeps True -> Just $ pure True + +-- ------------------------------------------------------------------ +-- Ignore test group if built with GHC 9 or newer +-- ------------------------------------------------------------------ + +ignoreOnGhc9AndNewer :: TestTree -> TestTree +ignoreOnGhc9AndNewer tt = +#if (defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)) + ignoreTestBecause "Not supported on GHC >= 9" +#endif + tt + diff --git a/tests/projects/cabal-with-ghc/cabal-with-ghc.cabal b/tests/projects/cabal-with-ghc/cabal-with-ghc.cabal new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-ghc/cabal-with-ghc.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.4 +name: cabal-with-ghc +version: 0.1.0.0 + +library + exposed-modules: MyLib + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/projects/cabal-with-ghc/cabal.project b/tests/projects/cabal-with-ghc/cabal.project new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-ghc/cabal.project @@ -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-8.10.7 diff --git a/tests/projects/cabal-with-ghc/hie.yaml b/tests/projects/cabal-with-ghc/hie.yaml new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-ghc/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/tests/projects/cabal-with-ghc/src/MyLib.hs b/tests/projects/cabal-with-ghc/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-ghc/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/wrappers/cabal b/wrappers/cabal --- a/wrappers/cabal +++ b/wrappers/cabal @@ -10,5 +10,5 @@ out "$arg" done else - "ghc" "$@" + "${HIE_BIOS_GHC:-ghc}" "${HIE_BIOS_GHC_ARGS}" "$@" fi diff --git a/wrappers/cabal.hs b/wrappers/cabal.hs --- a/wrappers/cabal.hs +++ b/wrappers/cabal.hs @@ -1,7 +1,8 @@ module Main (main) where +import Data.Maybe (fromMaybe) import System.Directory (getCurrentDirectory) -import System.Environment (getArgs, getEnv) +import System.Environment (getArgs, getEnv, lookupEnv) import System.Exit (exitWith) import System.Process (spawnProcess, waitForProcess) import System.IO (openFile, hClose, hPutStrLn, IOMode(..)) @@ -17,6 +18,7 @@ mapM_ (hPutStrLn h) args hClose h _ -> do - ph <- spawnProcess "ghc" (args) + ghc_path <- fromMaybe "ghc" <$> lookupEnv "HIE_BIOS_GHC" + ph <- spawnProcess ghc_path (args) code <- waitForProcess ph exitWith code