hie-bios 0.8.1 → 0.9.0

raw patch · 11 files changed

+604/−239 lines, 11 filesdep +taggeddep ~aesondep ~exceptionsdep ~ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: tagged

Dependency ranges changed: aeson, exceptions, ghc, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• hie-bios.cabal +9/−5
• src/HIE/Bios/Cradle.hs +272/−124
• src/HIE/Bios/Types.hs +71/−4
• tests/BiosTests.hs +214/−103
• tests/projects/cabal-with-ghc/cabal-with-ghc.cabal +9/−0
• tests/projects/cabal-with-ghc/cabal.project +12/−0
• tests/projects/cabal-with-ghc/hie.yaml +2/−0
• tests/projects/cabal-with-ghc/src/MyLib.hs +4/−0
• wrappers/cabal +1/−1
• wrappers/cabal.hs +4/−2

@@ -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)

@@ -1,6 +1,6 @@ Cabal-Version:          2.2 Name:                   hie-bios-Version:                0.8.1+Version:                0.9.0 Author:                 Matthew Pickering <matthewtpickering@gmail.com> Maintainer:             Matthew Pickering <matthewtpickering@gmail.com> 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/

@@ -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

@@ -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]

@@ -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+

@@ -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

@@ -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

@@ -0,0 +1,2 @@+cradle:+  cabal:

@@ -0,0 +1,4 @@+module MyLib (someFunc) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"

@@ -10,5 +10,5 @@     out "$arg"   done else-  "ghc" "$@"+  "${HIE_BIOS_GHC:-ghc}" "${HIE_BIOS_GHC_ARGS}" "$@" fi

@@ -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