packages feed

hie-bios 0.15.0 → 0.16.0

raw patch · 29 files changed

+1366/−832 lines, 29 filesdep ~optparse-applicative

Dependency ranges changed: optparse-applicative

Files

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