hie-bios 0.15.0 → 0.20.0
raw patch · 46 files changed
Files
- ChangeLog.md +38/−0
- README.md +39/−0
- exe/Main.hs +66/−20
- hie-bios.cabal +253/−232
- src/HIE/Bios/Config.hs +36/−21
- src/HIE/Bios/Config/YAML.hs +20/−13
- src/HIE/Bios/Cradle.hs +173/−773
- src/HIE/Bios/Cradle/Cabal.hs +783/−0
- src/HIE/Bios/Cradle/ProgramVersions.hs +72/−0
- src/HIE/Bios/Cradle/ProjectConfig.hs +17/−0
- src/HIE/Bios/Cradle/Resolved.hs +35/−0
- src/HIE/Bios/Cradle/Utils.hs +79/−0
- src/HIE/Bios/Environment.hs +98/−20
- src/HIE/Bios/Flags.hs +5/−7
- src/HIE/Bios/Ghc/Api.hs +11/−3
- src/HIE/Bios/Ghc/Gap.hs +172/−21
- src/HIE/Bios/Ghc/Load.hs +1/−13
- src/HIE/Bios/Ghc/Logger.hs +2/−23
- src/HIE/Bios/Internal/Debug.hs +5/−3
- src/HIE/Bios/Process.hs +222/−0
- src/HIE/Bios/Types.hs +63/−18
- src/HIE/Bios/Wrappers.hs +15/−8
- tests/BiosTests.hs +301/−87
- tests/ParserTests.hs +75/−57
- tests/Utils.hs +70/−49
- tests/configs/cabal-with-both.yaml +1/−1
- tests/configs/cabal-with-load.yaml +3/−0
- tests/configs/cabal-with-project.yaml +1/−1
- tests/configs/multi-cabal-with-load.yaml +9/−0
- tests/configs/multi-cabal-with-project.yaml +1/−1
- tests/configs/multi-stack-with-load.yaml +9/−0
- tests/configs/single-components.yaml +2/−0
- tests/configs/stack-with-load.yaml +3/−0
- tests/projects/cabal-with-ghc-and-project/cabal.project.9.2.8 +0/−12
- tests/projects/cabal-with-ghc-and-project/cabal.project.extra +12/−0
- tests/projects/cabal-with-ghc-and-project/hie.yaml +1/−1
- tests/projects/cabal-with-ghc/cabal.project +1/−1
- tests/projects/cabal-with-project/cabal.project.9.2.8 +0/−5
- tests/projects/cabal-with-project/cabal.project.extra +5/−0
- tests/projects/cabal-with-project/hie.yaml +1/−1
- tests/projects/multi-cabal-with-project/cabal.project.9.2.8 +0/−6
- tests/projects/multi-cabal-with-project/cabal.project.extra +6/−0
- tests/projects/multi-cabal-with-project/hie.yaml +2/−2
- tests/projects/multi-cabal/multi-cabal.cabal +1/−1
- wrappers/cabal-with-repl +10/−0
- wrappers/cabal-with-repl.hs +14/−0
ChangeLog.md view
@@ -1,5 +1,43 @@ # ChangeLog hie-bios +## 2026-06-30 - 0.20.0++* Hide LoadMode in TestM ([#516](https://github.com/haskell/hie-bios/pull/516))+* "componentsToLoad" field ([#515](https://github.com/haskell/hie-bios/pull/515))+* Fail hard if component(s) field have wrong type ([#513](https://github.com/haskell/hie-bios/pull/513))+* Allow to build with GHC 10.1 ([#510](https://github.com/haskell/hie-bios/pull/510))+* New Load Modes for upfront loading of cradle/project ([#508](https://github.com/haskell/hie-bios/pull/508))+ * Implement full project loading++## 2026-04-15 - 0.19.0++* Pass --builddir to avoid clobbering dist-newstyle ([#503](https://github.com/haskell/hie-bios/pull/503))++## 2026-02-06 - 0.18.0++* Adapt to OsPath change ([#493](https://github.com/haskell/hie-bios/pull/493))+* Parallel test suite ([#487](https://github.com/haskell/hie-bios/pull/487))+* Fix processCabalLoadStyle to include dyn dep for extra files ([#484](https://github.com/haskell/hie-bios/pull/484))+* Improve hie-bios cli interface ([#480](https://github.com/haskell/hie-bios/pull/480))+* Only pass --keep-temp-files once ([#477](https://github.com/haskell/hie-bios/pull/477))++## 2025-08-07 - 0.17.0++* Add support for cabal 3.16.1.0 [#470](https://github.com/haskell/hie-bios/pull/470)++## 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)
README.md view
@@ -552,6 +552,33 @@ , { path: "./tests", component: "parser-tests" } ] } } ``` +## Selecting which components to load++For `cabal` and `stack` cradles, `hie-bios` supports asking for flags to load+the components in the cradle at once. This is much faster than loading+components on-demand at the cost of more memory usage if a component isn't+actually needed. Support is conditional on underlying tool versions, and+`hie-bios` will fall back to legacy loading otherwise.++The optional field `componentsToLoad` specifies which components should be loaded together, it defaults to all the explicitly listed components.++```yaml+cradle:+ cabal:+ componentsToLoad: ["lib:foo"]+ components:+ - {"path": "./src", "component": "lib:foo"}+ - {"path": "./app", "component": "exe:foo"}+```++The elements of `componentsToLoad` do not need to be also listed as individual components, though doing so might improve dependency tracking.++```yaml+cradle:+ stack:+ componentsToLoad: ["foo:lib","foo:exe"]+```+ ## Cradle Dependencies Sometimes it is necessary to reload a component, for example when a package@@ -609,9 +636,21 @@ ```yaml cradle: cabal:+ cabalProject: "optional path to project description"+ componentsToLoad: ["cabal target1","cabal target2"]+ -- one or none of the following component: "optional component name"+ components:+ - path: "path to package dir"+ component: "cabal target" stack:+ stackYaml: "optional path to stack yaml file"+ componentsToLoad: ["stack target1","stack target2"]+ -- one or none of the following component: "optional component name"+ components:+ - path: "path to package dir"+ component: "stack target" bios: program: "program to run" dependency-program: "optional program to run"
exe/Main.hs view
@@ -8,7 +8,7 @@ import Data.Version (showVersion) import Prettyprinter import Options.Applicative-import System.Directory (getCurrentDirectory)+import System.Directory (getCurrentDirectory, makeAbsolute) import System.IO (stdout, hSetEncoding, utf8) import System.FilePath( (</>) ) @@ -16,46 +16,73 @@ import HIE.Bios.Ghc.Check import HIE.Bios.Ghc.Gap as Gap import HIE.Bios.Internal.Debug-import HIE.Bios.Types (LoadStyle(LoadFile))+import HIE.Bios.Types (LoadMode(..), TargetWithContext (..), singleTarget) import Paths_hie_bios+import Data.Void (Void)+import Data.Function ---------------------------------------------------------------- progVersion :: String progVersion = "hie-bios version " ++ showVersion version ++ " compiled by GHC " ++ Gap.ghcVersion ++ "\n" +data UseLoadMode+ = UseSingleFile+ | UseMultiFile+ | UseUnitsInferred+ | UseUnitsFromCradle++data Cli = Cli+ { logLevel :: Maybe L.Severity+ , biosCommand :: Command+ }+ data Command = Check { checkTargetFiles :: [FilePath] } | Flags { flagTargetFiles :: [FilePath] }- | Debug { debugComponents :: FilePath }+ | Debug { debugUseMultiLoadMode :: UseLoadMode, debugComponents :: [FilePath] } | ConfigInfo { configFiles :: [FilePath] } | CradleInfo { cradleFiles :: [FilePath] } | Root | Version -filepathParser :: Parser [FilePath]-filepathParser = some (argument str ( metavar "TARGET_FILES..."))+filepathParser :: Parser FilePath+filepathParser = argument str ( metavar "TARGET_FILES...") -progInfo :: ParserInfo Command-progInfo = info (progParser <**> helper)+progInfo :: ParserInfo Cli+progInfo = info (cliParser <**> helper) ( fullDesc <> progDesc "hie-bios is the way to specify how haskell-language-server and ghcide set up a GHC API session.\ \Delivers the full set of flags to pass to GHC in order to build the project." <> header progVersion <> footer "You can report issues/contribute at https://github.com/mpickering/hie-bios") +cliParser :: Parser Cli+cliParser = Cli+ <$> optional sevParser+ <*> progParser++sevParser :: Parser L.Severity+sevParser =+ flag' L.Debug (short 'v')+ progParser :: Parser Command-progParser = subparser- (command "check" (info (Check <$> filepathParser) (progDesc "Try to load modules into the GHC API."))- <> command "flags" (info (Flags <$> filepathParser) (progDesc "Print out the options that hie-bios thinks you will need to load a file."))- <> command "debug" (info (Debug <$> argument str ( metavar "TARGET_FILES...")) (progDesc "Print out the options that hie-bios thinks you will need to load a file."))- <> command "config" (info (ConfigInfo <$> filepathParser) (progDesc "Print out the cradle config."))- <> command "cradle" (info (CradleInfo <$> filepathParser) (progDesc "."))+progParser = hsubparser+ (command "check" (info (Check <$> some filepathParser) (progDesc "Try to load modules into the GHC API."))+ <> command "flags" (info (Flags <$> some filepathParser) (progDesc "Print out the options that hie-bios thinks you will need to load a file."))+ <> command "debug" (info (Debug <$> loadModeParser <*> many filepathParser) (progDesc "Print out the options that hie-bios thinks you will need to load a file."))+ <> command "config" (info (ConfigInfo <$> some filepathParser) (progDesc "Print out the cradle config location."))+ <> command "cradle" (info (CradleInfo <$> some filepathParser) (progDesc "Print out only the cradle type.")) <> command "root" (info (pure Root) (progDesc "Display the path towards the selected hie.yaml.")) <> command "version" (info (pure Version) (progDesc "Print version and exit.")) ) +loadModeParser :: Parser UseLoadMode+loadModeParser =+ flag UseSingleFile UseMultiFile (long "multi" <> help "Load all targets in bulk if supported")+ <|> flag UseSingleFile UseUnitsInferred (long "inferred-units" <> help "Load all units in bulk if supported")+ <|> flag UseSingleFile UseUnitsFromCradle (long "cradle-units" <> help "Load all units from cradle components in bulk if supported") ---------------------------------------------------------------- @@ -63,11 +90,15 @@ main = do hSetEncoding stdout utf8 cwd <- getCurrentDirectory- cmd <- execParser progInfo+ cli <- execParser progInfo let printLog (L.WithSeverity l sev) = "[" ++ show sev ++ "] " ++ show (pretty l) logger :: forall a . Pretty a => L.LogAction IO (L.WithSeverity a)- logger = L.cmap printLog L.logStringStderr+ logger = L.logStringStderr+ & L.cmap printLog+ & L.cfilter (\msg -> case logLevel cli of+ Nothing -> False+ Just lvl -> L.getSeverity msg >= lvl ) cradle <- -- find cradle does a takeDirectory on the argument, so make it into a file@@ -75,17 +106,17 @@ Just yaml -> loadCradle logger yaml Nothing -> loadImplicitCradle logger (cwd </> "File.hs") - res <- case cmd of+ res <- case biosCommand cli of Check targetFiles -> checkSyntax logger cradle targetFiles- Debug files -> case files of- [] -> debugInfo (cradleRootDir cradle) cradle- fp -> debugInfo fp cradle+ Debug useMultiStyle files -> do+ absFiles <- traverse makeAbsolute files+ debugFiles absFiles useMultiStyle cradle Flags files -> case files of -- TODO force optparse to acquire one [] -> error "too few arguments" _ -> do res <- forM files $ \fp -> do- res <- getCompilerOptions fp LoadFile cradle+ res <- getCompilerOptions (TargetWithContext fp []) LoadFile cradle case res of CradleFail (CradleError _deps _ex err _fps) -> return $ "Failed to show flags for \""@@ -102,3 +133,18 @@ Root -> rootInfo cradle Version -> return progVersion putStr res++debugFiles :: [FilePath] -> UseLoadMode -> Cradle Void -> IO String+debugFiles fps useLoadMode cradle = case useLoadMode of+ UseSingleFile -> debugSingle+ UseMultiFile -> debugBulk LoadFileWithContext+ UseUnitsInferred -> debugBulk LoadUnitsInferred+ UseUnitsFromCradle -> debugBulk LoadUnitsFromCradle+ where+ debugSingle = case fps of+ [] -> debugInfo (singleTarget $ cradleRootDir cradle) LoadFile cradle+ _ -> concat <$> traverse (\fp -> debugInfo (singleTarget fp) LoadFile cradle) fps++ debugBulk mode = case fps of+ [] -> debugInfo (TargetWithContext (cradleRootDir cradle) []) mode cradle+ fp:otherFps -> debugInfo (TargetWithContext fp otherFps) mode cradle
hie-bios.cabal view
@@ -1,254 +1,275 @@-Cabal-Version: 2.2-Name: hie-bios-Version: 0.15.0-Author: Matthew Pickering <matthewtpickering@gmail.com>-Maintainer: Matthew Pickering <matthewtpickering@gmail.com>-License: BSD-3-Clause-License-File: LICENSE-Homepage: https://github.com/haskell/hie-bios-Synopsis: Set up a GHC API session-Description: Set up a GHC API session and obtain flags required to compile a source file--Category: Development-Build-Type: Simple--- No glob syntax until GHC 8.6 because of stack-extra-doc-files: ChangeLog.md-Extra-Source-Files: README.md- wrappers/cabal- wrappers/cabal.hs- tests/configs/*.yaml- tests/projects/cabal-with-ghc/cabal-with-ghc.cabal- tests/projects/cabal-with-ghc/cabal.project- tests/projects/cabal-with-ghc/hie.yaml- tests/projects/cabal-with-ghc/src/MyLib.hs- tests/projects/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/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/hie.yaml- tests/projects/cabal-with-project/src/MyLib.hs- tests/projects/symlink-test/a/A.hs- tests/projects/symlink-test/hie.yaml- tests/projects/deps-bios-new/A.hs- tests/projects/deps-bios-new/B.hs- tests/projects/deps-bios-new/hie-bios.sh- tests/projects/deps-bios-new/hie.yaml- tests/projects/multi-direct/A.hs- tests/projects/multi-direct/B.hs- tests/projects/multi-direct/hie.yaml- tests/projects/multi-cabal/app/Main.hs- tests/projects/multi-cabal/cabal.project- tests/projects/multi-cabal/hie.yaml- tests/projects/multi-cabal/multi-cabal.cabal- tests/projects/multi-cabal/src/Lib.hs- tests/projects/multi-cabal-with-project/appA/appA.cabal- 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/hie.yaml- tests/projects/monorepo-cabal/cabal.project- tests/projects/monorepo-cabal/hie.yaml- tests/projects/monorepo-cabal/A/Main.hs- tests/projects/monorepo-cabal/A/A.cabal- tests/projects/monorepo-cabal/B/MyLib.hs- tests/projects/monorepo-cabal/B/B.cabal- tests/projects/multi-stack/app/Main.hs- tests/projects/multi-stack/cabal.project- tests/projects/multi-stack/hie.yaml- tests/projects/multi-stack/multi-stack.cabal- tests/projects/multi-stack/src/Lib.hs- tests/projects/failing-bios/A.hs- tests/projects/failing-bios/B.hs- tests/projects/failing-bios/hie.yaml- tests/projects/failing-bios-ghc/A.hs- tests/projects/failing-bios-ghc/B.hs- tests/projects/failing-bios-ghc/hie.yaml- tests/projects/failing-cabal/failing-cabal.cabal- tests/projects/failing-cabal/hie.yaml- tests/projects/failing-cabal/MyLib.hs- tests/projects/failing-stack/failing-stack.cabal- tests/projects/failing-stack/hie.yaml- tests/projects/failing-stack/src/Lib.hs- tests/projects/nested-cabal/nested-cabal.cabal- tests/projects/nested-cabal/cabal.project- tests/projects/nested-cabal/hie.yaml- tests/projects/nested-cabal/MyLib.hs- tests/projects/nested-cabal/sub-comp/sub-comp.cabal- tests/projects/nested-cabal/sub-comp/Lib.hs- tests/projects/nested-stack/nested-stack.cabal- tests/projects/nested-stack/hie.yaml- tests/projects/nested-stack/MyLib.hs- tests/projects/nested-stack/sub-comp/sub-comp.cabal- tests/projects/nested-stack/sub-comp/Lib.hs- tests/projects/simple-bios/A.hs- tests/projects/simple-bios/B.hs- tests/projects/simple-bios/hie-bios.sh- tests/projects/simple-bios/hie-bios-deps.sh- tests/projects/simple-bios/hie.yaml- tests/projects/simple-bios-ghc/A.hs- tests/projects/simple-bios-ghc/B.hs- tests/projects/simple-bios-ghc/hie-bios.sh- tests/projects/simple-bios-ghc/hie.yaml- tests/projects/simple-bios-shell/A.hs- tests/projects/simple-bios-shell/B.hs- tests/projects/simple-bios-shell/hie.yaml- tests/projects/simple-cabal/A.hs- tests/projects/simple-cabal/B.hs- tests/projects/simple-cabal/cabal.project- tests/projects/simple-cabal/hie.yaml- tests/projects/simple-cabal/simple-cabal.cabal- tests/projects/simple-direct/A.hs- tests/projects/simple-direct/B.hs- tests/projects/simple-direct/hie.yaml- tests/projects/simple-stack/A.hs- tests/projects/simple-stack/B.hs- tests/projects/simple-stack/cabal.project- tests/projects/simple-stack/hie.yaml- tests/projects/simple-stack/simple-stack.cabal- "tests/projects/space stack/A.hs"- "tests/projects/space stack/B.hs"- "tests/projects/space stack/hie.yaml"- "tests/projects/space stack/stackproj.cabal"- tests/projects/implicit-cabal/cabal.project- tests/projects/implicit-cabal/implicit-cabal.cabal- tests/projects/implicit-cabal/Main.hs- tests/projects/implicit-cabal-no-project/implicit-cabal-no-project.cabal- tests/projects/implicit-cabal-no-project/Main.hs- tests/projects/implicit-cabal-deep-project/README- tests/projects/implicit-cabal-deep-project/implicit-cabal-deep-project.cabal- tests/projects/implicit-cabal-deep-project/Main.hs- tests/projects/implicit-cabal-deep-project/cabal.project- tests/projects/implicit-cabal-deep-project/foo/foo.cabal- tests/projects/implicit-cabal-deep-project/foo/Main.hs- tests/projects/implicit-stack/implicit-stack.cabal- tests/projects/implicit-stack/Main.hs- tests/projects/implicit-stack-multi/implicit-stack-multi.cabal- tests/projects/implicit-stack-multi/Main.hs- tests/projects/implicit-stack-multi/other-package/other-package.cabal- tests/projects/implicit-stack-multi/other-package/Main.hs- tests/projects/multi-stack-with-yaml/appA/appA.cabal- tests/projects/multi-stack-with-yaml/appA/src/Lib.hs- tests/projects/multi-stack-with-yaml/appB/appB.cabal- tests/projects/multi-stack-with-yaml/appB/src/Lib.hs- tests/projects/multi-stack-with-yaml/hie.yaml- tests/projects/stack-with-yaml/app/Main.hs- tests/projects/stack-with-yaml/hie.yaml- tests/projects/stack-with-yaml/stack-with-yaml.cabal- tests/projects/stack-with-yaml/src/Lib.hs- tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/app/Main.hs- tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/multi-repl-cabal-fail.cabal- tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/src/Fail.hs- tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/src/Lib.hs- tests/projects/failing-multi-repl-cabal-project/NotInPath.hs+cabal-version: 2.2+name: hie-bios+version: 0.20.0+author: Matthew Pickering <matthewtpickering@gmail.com>, Hannes Siebenhandl <fendor.haskell@gmail.com>+maintainer: Hannes Siebenhandl <fendor.haskell@gmail.com>+license: BSD-3-Clause+license-file: LICENSE+homepage: https://github.com/haskell/hie-bios+synopsis: Set up a GHC API session+description: Set up a GHC API session and obtain flags required to compile a source file+category: Development+build-type: Simple+extra-doc-files: ChangeLog.md+extra-source-files:+ README.md+ tests/configs/*.yaml+ tests/projects/cabal-with-ghc-and-project/cabal-with-ghc.cabal+ 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-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-project/cabal-with-project.cabal+ 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/deps-bios-new/A.hs+ tests/projects/deps-bios-new/B.hs+ tests/projects/deps-bios-new/hie-bios.sh+ tests/projects/deps-bios-new/hie.yaml+ tests/projects/failing-bios-ghc/A.hs+ tests/projects/failing-bios-ghc/B.hs+ tests/projects/failing-bios-ghc/hie.yaml+ tests/projects/failing-bios/A.hs+ tests/projects/failing-bios/B.hs+ tests/projects/failing-bios/hie.yaml+ tests/projects/failing-cabal/failing-cabal.cabal+ tests/projects/failing-cabal/hie.yaml+ tests/projects/failing-cabal/MyLib.hs+ tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/app/Main.hs+ tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/multi-repl-cabal-fail.cabal+ tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/src/Fail.hs+ tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/src/Lib.hs+ tests/projects/failing-multi-repl-cabal-project/NotInPath.hs+ tests/projects/failing-stack/failing-stack.cabal+ tests/projects/failing-stack/hie.yaml+ tests/projects/failing-stack/src/Lib.hs+ tests/projects/implicit-cabal-deep-project/cabal.project+ tests/projects/implicit-cabal-deep-project/foo/foo.cabal+ tests/projects/implicit-cabal-deep-project/foo/Main.hs+ tests/projects/implicit-cabal-deep-project/implicit-cabal-deep-project.cabal+ tests/projects/implicit-cabal-deep-project/Main.hs+ tests/projects/implicit-cabal-deep-project/README+ tests/projects/implicit-cabal-no-project/implicit-cabal-no-project.cabal+ tests/projects/implicit-cabal-no-project/Main.hs+ tests/projects/implicit-cabal/cabal.project+ tests/projects/implicit-cabal/implicit-cabal.cabal+ tests/projects/implicit-cabal/Main.hs+ tests/projects/implicit-stack-multi/implicit-stack-multi.cabal+ tests/projects/implicit-stack-multi/Main.hs+ tests/projects/implicit-stack-multi/other-package/Main.hs+ tests/projects/implicit-stack-multi/other-package/other-package.cabal+ tests/projects/implicit-stack/implicit-stack.cabal+ tests/projects/implicit-stack/Main.hs+ tests/projects/monorepo-cabal/A/A.cabal+ tests/projects/monorepo-cabal/A/Main.hs+ tests/projects/monorepo-cabal/B/B.cabal+ tests/projects/monorepo-cabal/B/MyLib.hs+ tests/projects/monorepo-cabal/cabal.project+ tests/projects/monorepo-cabal/hie.yaml+ tests/projects/multi-cabal-with-project/appA/appA.cabal+ 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.extra+ tests/projects/multi-cabal-with-project/hie.yaml+ tests/projects/multi-cabal/app/Main.hs+ tests/projects/multi-cabal/cabal.project+ tests/projects/multi-cabal/hie.yaml+ tests/projects/multi-cabal/multi-cabal.cabal+ tests/projects/multi-cabal/src/Lib.hs+ tests/projects/multi-direct/A.hs+ tests/projects/multi-direct/B.hs+ tests/projects/multi-direct/hie.yaml+ tests/projects/multi-stack-with-yaml/appA/appA.cabal+ tests/projects/multi-stack-with-yaml/appA/src/Lib.hs+ tests/projects/multi-stack-with-yaml/appB/appB.cabal+ tests/projects/multi-stack-with-yaml/appB/src/Lib.hs+ tests/projects/multi-stack-with-yaml/hie.yaml+ tests/projects/multi-stack/app/Main.hs+ tests/projects/multi-stack/cabal.project+ tests/projects/multi-stack/hie.yaml+ tests/projects/multi-stack/multi-stack.cabal+ tests/projects/multi-stack/src/Lib.hs+ tests/projects/nested-cabal/cabal.project+ tests/projects/nested-cabal/hie.yaml+ tests/projects/nested-cabal/MyLib.hs+ tests/projects/nested-cabal/nested-cabal.cabal+ tests/projects/nested-cabal/sub-comp/Lib.hs+ tests/projects/nested-cabal/sub-comp/sub-comp.cabal+ tests/projects/nested-stack/hie.yaml+ tests/projects/nested-stack/MyLib.hs+ tests/projects/nested-stack/nested-stack.cabal+ tests/projects/nested-stack/sub-comp/Lib.hs+ tests/projects/nested-stack/sub-comp/sub-comp.cabal+ tests/projects/simple-bios-ghc/A.hs+ tests/projects/simple-bios-ghc/B.hs+ tests/projects/simple-bios-ghc/hie-bios.sh+ tests/projects/simple-bios-ghc/hie.yaml+ tests/projects/simple-bios-shell/A.hs+ tests/projects/simple-bios-shell/B.hs+ tests/projects/simple-bios-shell/hie.yaml+ tests/projects/simple-bios/A.hs+ tests/projects/simple-bios/B.hs+ tests/projects/simple-bios/hie-bios-deps.sh+ tests/projects/simple-bios/hie-bios.sh+ tests/projects/simple-bios/hie.yaml+ tests/projects/simple-cabal/A.hs+ tests/projects/simple-cabal/B.hs+ tests/projects/simple-cabal/cabal.project+ tests/projects/simple-cabal/hie.yaml+ tests/projects/simple-cabal/simple-cabal.cabal+ tests/projects/simple-direct/A.hs+ tests/projects/simple-direct/B.hs+ tests/projects/simple-direct/hie.yaml+ tests/projects/simple-stack/A.hs+ tests/projects/simple-stack/B.hs+ tests/projects/simple-stack/cabal.project+ tests/projects/simple-stack/hie.yaml+ tests/projects/simple-stack/simple-stack.cabal+ "tests/projects/space stack/A.hs"+ "tests/projects/space stack/B.hs"+ "tests/projects/space stack/hie.yaml"+ "tests/projects/space stack/stackproj.cabal"+ tests/projects/stack-with-yaml/app/Main.hs+ tests/projects/stack-with-yaml/hie.yaml+ tests/projects/stack-with-yaml/src/Lib.hs+ tests/projects/stack-with-yaml/stack-with-yaml.cabal+ tests/projects/symlink-test/a/A.hs+ tests/projects/symlink-test/hie.yaml+ wrappers/cabal+ wrappers/cabal-with-repl+ wrappers/cabal-with-repl.hs+ wrappers/cabal.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 || ==9.14.1 -Library- Default-Language: Haskell2010- GHC-Options: -Wall- HS-Source-Dirs: src- Exposed-Modules: HIE.Bios- HIE.Bios.Config- HIE.Bios.Config.YAML- HIE.Bios.Cradle- HIE.Bios.Environment- HIE.Bios.Internal.Debug- HIE.Bios.Flags- HIE.Bios.Types- HIE.Bios.Ghc.Api- HIE.Bios.Ghc.Check- HIE.Bios.Ghc.Doc- HIE.Bios.Ghc.Gap- HIE.Bios.Ghc.Load- HIE.Bios.Ghc.Logger- HIE.Bios.Wrappers- Other-Modules: Paths_hie_bios- autogen-modules: Paths_hie_bios- Build-Depends:- base >= 4.16 && < 5,- aeson >= 1.4.4 && < 2.3,- base16-bytestring >= 0.1.1 && < 1.1,- bytestring >= 0.10.8 && < 0.13,- co-log-core ^>= 0.3.0,- deepseq >= 1.4.3 && < 1.6,- exceptions ^>= 0.10,- cryptohash-sha1 >= 0.11.100 && < 0.12,- directory >= 1.3.0 && < 1.4,- filepath >= 1.4.1 && < 1.6,- time >= 1.8.0 && < 1.15,- extra >= 1.6.14 && < 1.9,- prettyprinter ^>= 1.6 || ^>= 1.7.0,- ghc >= 9.2.1 && < 9.13,- transformers >= 0.5.2 && < 0.7,- temporary >= 1.2 && < 1.4,- template-haskell >= 2.18 && <2.24,- text >= 1.2.3 && < 2.2,- unix-compat >= 0.5.1 && < 0.8,- unordered-containers >= 0.2.9 && < 0.3,- yaml >= 0.10.0 && < 0.12,- file-embed >= 0.0.11 && < 1,- conduit >= 1.3 && < 2,- conduit-extra >= 1.3 && < 2+library+ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: src+ exposed-modules:+ HIE.Bios+ 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.Flags+ HIE.Bios.Ghc.Api+ HIE.Bios.Ghc.Check+ HIE.Bios.Ghc.Doc+ HIE.Bios.Ghc.Gap+ HIE.Bios.Ghc.Load+ HIE.Bios.Ghc.Logger+ HIE.Bios.Internal.Debug+ HIE.Bios.Process+ HIE.Bios.Types+ HIE.Bios.Wrappers + other-modules: Paths_hie_bios+ autogen-modules: Paths_hie_bios+ build-depends:+ aeson >=1.4.4 && <2.4,+ base >=4.16 && <5,+ base16-bytestring >=0.1.1 && <1.1,+ bytestring >=0.10.8 && <0.13,+ co-log-core ^>=0.3.0,+ conduit >=1.3 && <2,+ conduit-extra >=1.3 && <2,+ containers >=0.6.2 && <0.9,+ cryptohash-sha1 >=0.11.100 && <0.12,+ deepseq >=1.4.3 && <1.6,+ directory >=1.3.0 && <1.4,+ exceptions ^>=0.10,+ extra >=1.6.14 && <1.9,+ file-embed >=0.0.11 && <1,+ filepath >=1.4.1 && <1.6,+ ghc >=9.2.1 && <10.2,+ prettyprinter ^>=1.6 || ^>=1.7.0,+ template-haskell >=2.18 && <2.25,+ temporary >=1.2 && <1.4,+ text >=1.2.3 && <2.2,+ time >=1.8.0 && <1.17,+ transformers >=0.5.2 && <0.7,+ unix-compat >=0.5.1 && <0.8,+ unordered-containers >=0.2.9 && <0.3,+ yaml >=0.10.0 && <0.12, -Executable hie-bios- Default-Language: Haskell2010- Main-Is: Main.hs- Other-Modules: Paths_hie_bios- autogen-modules: Paths_hie_bios- GHC-Options: -Wall- HS-Source-Dirs: exe- Build-Depends: base >= 4.16 && < 5- , co-log-core- , directory- , filepath- , hie-bios- , optparse-applicative >= 0.18.1 && < 0.19- , prettyprinter+executable hie-bios+ default-language: Haskell2010+ main-is: Main.hs+ other-modules: Paths_hie_bios+ autogen-modules: Paths_hie_bios+ ghc-options: -Wall+ hs-source-dirs: exe+ build-depends:+ base >=4.16 && <5,+ co-log-core,+ directory,+ filepath,+ hie-bios,+ optparse-applicative >=0.17.1 && <0.20,+ prettyprinter, test-suite parser-tests type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends:- base,- aeson,- filepath,- hie-bios,- tasty,- tasty-hunit,- yaml+ aeson,+ base,+ filepath,+ hie-bios,+ tasty,+ tasty-hunit,+ yaml, hs-source-dirs: tests/- ghc-options: -threaded -Wall+ ghc-options:+ -threaded+ -Wall+ main-is: ParserTests.hs test-suite bios-tests type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends:- base,- co-log-core,- extra,- transformers,- tasty,- tasty-hunit,- tasty-expected-failure,- hie-bios,- filepath,- directory,- prettyprinter,- temporary,- text,- ghc+ base,+ co-log-core,+ directory,+ extra,+ filepath,+ ghc,+ hie-bios,+ prettyprinter,+ tasty,+ tasty-expected-failure,+ tasty-hunit,+ temporary,+ text,+ transformers, hs-source-dirs: tests/- ghc-options: -threaded -Wall main-is: BiosTests.hs other-modules: Utils+ ghc-options:+ -threaded+ -Wall -Source-Repository head- Type: git- Location: https://github.com/haskell/hie-bios.git+ -- There seems to be a race condition on windows+ if !os(windows)+ ghc-options:+ -rtsopts+ -with-rtsopts=-N++source-repository head+ type: git+ location: https://github.com/haskell/hie-bios.git
src/HIE/Bios/Config.hs view
@@ -11,10 +11,12 @@ pattern CabalType, cabalComponent, cabalProjectFile,+ cabalComponentsToLoad, StackType, pattern StackType, stackComponent, stackYaml,+ stackComponentsToLoad, CradleTree(..), Callable(..) ) where@@ -67,34 +69,42 @@ -- 'cabal.project'. We allow to override that name to have an HLS specific -- project configuration file. data CabalType- = CabalType_ { _cabalComponent :: !(Last String), _cabalProjectFile :: !(Last FilePath) }+ = CabalType_+ { _cabalComponent :: !(Last String)+ , _cabalProjectFile :: !(Last FilePath)+ , _cabalComponentsToLoad :: !(Maybe [String])+ } deriving (Eq) instance Semigroup CabalType where- CabalType_ cr cpr <> CabalType_ cl cpl = CabalType_ (cr <> cl) (cpr <> cpl)+ CabalType_ cr cpr csr <> CabalType_ cl cpl csl = CabalType_ (cr <> cl) (cpr <> cpl) (csr <> csl) instance Monoid CabalType where- mempty = CabalType_ mempty mempty+ mempty = CabalType_ mempty mempty mempty -pattern CabalType :: Maybe String -> Maybe FilePath -> CabalType-pattern CabalType { cabalComponent, cabalProjectFile } = CabalType_ (Last cabalComponent) (Last cabalProjectFile)+pattern CabalType :: Maybe String -> Maybe FilePath -> Maybe [String] -> CabalType+pattern CabalType { cabalComponent, cabalProjectFile, cabalComponentsToLoad } = CabalType_ (Last cabalComponent) (Last cabalProjectFile) cabalComponentsToLoad {-# COMPLETE CabalType #-} instance Show CabalType where show = show . Cabal data StackType- = StackType_ { _stackComponent :: !(Last String) , _stackYaml :: !(Last String) }+ = StackType_+ { _stackComponent :: !(Last String)+ , _stackYaml :: !(Last String)+ , _stackComponentsToLoad :: !(Maybe [String])+ } deriving (Eq) instance Semigroup StackType where- StackType_ cr yr <> StackType_ cl yl = StackType_ (cr <> cl) (yr <> yl)+ StackType_ cr yr zr <> StackType_ cl yl zl = StackType_ (cr <> cl) (yr <> yl) (zr <> zl) instance Monoid StackType where- mempty = StackType_ mempty mempty+ mempty = StackType_ mempty mempty mempty -pattern StackType :: Maybe String -> Maybe FilePath -> StackType-pattern StackType { stackComponent, stackYaml } = StackType_ (Last stackComponent) (Last stackYaml)+pattern StackType :: Maybe String -> Maybe FilePath -> Maybe [String] -> StackType+pattern StackType { stackComponent, stackYaml, stackComponentsToLoad } = StackType_ (Last stackComponent) (Last stackYaml) stackComponentsToLoad {-# COMPLETE StackType #-} instance Show StackType where@@ -126,7 +136,11 @@ deriving (Eq, Functor) instance Show (CradleTree a) where- show (Cabal comp) = "Cabal {component = " ++ show (cabalComponent comp) ++ "}"+ show (Cabal comp) = concat $+ [ "Cabal { component = ", show (cabalComponent comp)+ , ", projectFile = ", show (cabalProjectFile comp)+ , "}"+ ] show (CabalMulti d a) = "CabalMulti {defaultCabal = " ++ show d ++ ", subCabalComponents = " ++ show a ++ "}" show (Stack comp) = "Stack {component = " ++ show (stackComponent comp) ++ ", stackYaml = " ++ show (stackYaml comp) ++ "}" show (StackMulti d a) = "StackMulti {defaultStack = " ++ show d ++ ", subStackComponents = " ++ show a ++ "}"@@ -159,20 +173,21 @@ toCradleTree :: YAML.CradleComponent a -> CradleTree a toCradleTree (YAML.Multi cpts) = Multi $ (\(YAML.MultiSubComponent fp' cfg) -> (fp', cradle $ fromYAMLConfig cfg)) <$> cpts-toCradleTree (YAML.Stack (YAML.StackConfig yaml cpts)) =+toCradleTree (YAML.Stack (YAML.StackConfig yaml csToLoad cpts)) = case cpts of- YAML.NoComponent -> Stack $ StackType Nothing yaml- (YAML.SingleComponent c) -> Stack $ StackType (Just c) yaml- (YAML.ManyComponents cs) -> StackMulti (StackType Nothing yaml)+ YAML.NoComponent -> Stack $ StackType Nothing yaml csToLoad+ (YAML.SingleComponent c) -> Stack $ StackType (Just c) yaml csToLoad+ (YAML.ManyComponents cs) -> StackMulti (StackType Nothing yaml csToLoad) ((\(YAML.StackComponent fp' c cYAML) ->- (fp', StackType (Just c) cYAML)) <$> cs)-toCradleTree (YAML.Cabal (YAML.CabalConfig prjFile cpts)) =+ (fp', StackType (Just c) cYAML+ Nothing)) <$> cs)+toCradleTree (YAML.Cabal (YAML.CabalConfig prjFile csToLoad cpts)) = case cpts of- YAML.NoComponent -> Cabal $ CabalType Nothing prjFile- (YAML.SingleComponent c) -> Cabal $ CabalType (Just c) prjFile- (YAML.ManyComponents cs) -> CabalMulti (CabalType Nothing prjFile)+ YAML.NoComponent -> Cabal $ CabalType Nothing prjFile csToLoad+ (YAML.SingleComponent c) -> Cabal $ CabalType (Just c) prjFile csToLoad+ (YAML.ManyComponents cs) -> CabalMulti (CabalType Nothing prjFile csToLoad) ((\(YAML.CabalComponent fp' c cPrjFile) ->- (fp', CabalType (Just c) cPrjFile)) <$> cs)+ (fp', CabalType (Just c) cPrjFile Nothing)) <$> cs) toCradleTree (YAML.Direct cfg) = Direct (YAML.arguments cfg) toCradleTree (YAML.Bios cfg) = Bios (toCallable $ YAML.callable cfg) (toCallable <$> YAML.depsCallable cfg)
src/HIE/Bios/Config/YAML.hs view
@@ -24,8 +24,9 @@ import Control.Applicative ((<|>)) import Data.Aeson #if MIN_VERSION_aeson(2,0,0)-import Data.Aeson.KeyMap (keys)+import Data.Aeson.KeyMap (keys,lookup) #else+import Data.HashMap.Strict (lookup) import qualified Data.HashMap.Strict as Map import qualified Data.Text as T #endif@@ -33,6 +34,7 @@ import qualified Data.Char as C (toLower) import Data.List ((\\)) import GHC.Generics (Generic)+import Prelude hiding (lookup) #if !MIN_VERSION_aeson(2,0,0) -- | Backwards compatible type-def for Key@@ -103,16 +105,18 @@ data CabalConfig = CabalConfig { cabalProject :: Maybe FilePath+ , cabalComponentsToLoad :: Maybe [String] , cabalComponents :: OneOrManyComponents CabalComponent } instance FromJSON CabalConfig where- parseJSON v@(Array _) = CabalConfig Nothing . ManyComponents <$> parseJSON v- parseJSON v@(Object obj) = (checkObjectKeys ["cabalProject", "component", "components"] obj)+ parseJSON v@(Array _) = CabalConfig Nothing Nothing . ManyComponents <$> parseJSON v+ parseJSON v@(Object obj) = (checkObjectKeys ["cabalProject", "component", "components", "componentsToLoad"] obj) *> (CabalConfig <$> obj .:? "cabalProject"+ <*> obj .:? "componentsToLoad" <*> parseJSON v)- parseJSON Null = pure $ CabalConfig Nothing NoComponent+ parseJSON Null = pure $ CabalConfig Nothing Nothing NoComponent parseJSON v = typeMismatch "CabalConfig" v data CabalComponent@@ -133,6 +137,7 @@ data StackConfig = StackConfig { stackYaml :: Maybe FilePath+ , stackComponentsToLoad :: Maybe [String] , stackComponents :: OneOrManyComponents StackComponent } @@ -143,13 +148,14 @@ } instance FromJSON StackConfig where- parseJSON v@(Array _) = StackConfig Nothing . ManyComponents <$> parseJSON v- parseJSON v@(Object obj) = (checkObjectKeys ["component", "components", "stackYaml"] obj)+ parseJSON v@(Array _) = StackConfig Nothing Nothing . ManyComponents <$> parseJSON v+ parseJSON v@(Object obj) = (checkObjectKeys ["component", "components", "stackYaml", "componentsToLoad"] obj) *> (StackConfig <$> obj .:? "stackYaml"+ <*> obj .:? "componentsToLoad" <*> parseJSON v )- parseJSON Null = pure $ StackConfig Nothing NoComponent+ parseJSON Null = pure $ StackConfig Nothing Nothing NoComponent parseJSON v = typeMismatch "StackConfig" v instance FromJSON StackComponent where@@ -166,12 +172,13 @@ | ManyComponents [component] | NoComponent -instance FromJSON component => FromJSON (OneOrManyComponents component) where- parseJSON =- let parseComponents o = (parseSingleComponent o <|> parseSubComponents o <|> pure NoComponent)- parseSingleComponent o = SingleComponent <$> o .: "component"- parseSubComponents o = ManyComponents <$> o .: "components"- in withObject "Components" parseComponents+instance FromJSON a => FromJSON (OneOrManyComponents a) where+ parseJSON (Object obj)+ | Just v <- lookup "component" obj = SingleComponent <$> parseJSON v+ | Just v <- lookup "components" obj = ManyComponents <$> parseJSON v+ | otherwise = pure NoComponent+ parseJSON Null = pure NoComponent+ parseJSON v = typeMismatch "OneOrManyComponents" v data DirectConfig = DirectConfig { arguments :: [String] }
src/HIE/Bios/Cradle.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -20,70 +19,46 @@ , 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+import Data.List.Extra (nubOrd) ---------------------------------------------------------------- @@ -120,102 +95,17 @@ loadCradleWithOpts :: (Yaml.FromJSON b, Show a) => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> IO (Cradle a) loadCradleWithOpts l buildCustomCradle wfile = do cradleConfig <- readCradleConfig wfile+ l <& WithSeverity (LogAny $ T.pack $ "Cradle Config: " ++ show cradleConfig) Debug getCradle l buildCustomCradle (cradleConfig, takeDirectory wfile) getCradle :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> (CradleConfig b, FilePath) -> IO (Cradle a) getCradle l buildCustomCradle (cc, wdir) = do rcs <- canonicalizeResolvedCradles wdir cs+ liftIO $ l <& WithSeverity (LogAny . T.pack $ "Resolved Cradles " ++ show ((fmap . fmap) (const ()) rcs)) Debug resolvedCradlesToCradle l buildCustomCradle wdir rcs 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@@ -239,10 +129,11 @@ versions <- makeVersions logger root run_ghc_cmd let rcs = ResolvedCradles root cs versions cradleActions = [ (c, resolveCradleAction logger buildCustomCradle rcs root c) | c <- cs ]- err_msg fp+ err_msg (TargetWithContext fp fps) = ["Multi Cradle: No prefixes matched" , "pwd: " ++ root , "filepath: " ++ fp+ , "context: " ++ intercalate ", " fps , "prefixes:" ] ++ [show (prefix pf, actionName cc) | (pf, cc) <- cradleActions] pure $ Cradle@@ -250,12 +141,12 @@ , cradleLogger = logger , cradleOptsProg = CradleAction { actionName = multiActionName- , runCradle = \fp prev -> do- absfp <- makeAbsolute fp+ , runCradle = \fpc prev -> do+ absfp <- makeAbsolute (targetFilePath fpc) case selectCradle (prefix . fst) absfp cradleActions of Just (rc, act) -> do- addActionDeps (cradleDeps rc) <$> runCradle act fp prev- Nothing -> return $ CradleFail $ CradleError [] ExitSuccess (err_msg fp) [fp]+ addActionDeps (cradleDeps rc) <$> runCradle act fpc prev+ Nothing -> return $ CradleFail $ CradleError [] ExitSuccess (err_msg fpc) (targetFilePath fpc: targetContext fpc) , runGhcCmd = run_ghc_cmd } }@@ -297,20 +188,20 @@ resolveCradleAction :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> CradleAction a-resolveCradleAction l buildCustomCradle cs root cradle = addLoadStyleLogToCradleAction $+resolveCradleAction l buildCustomCradle cs root cradle = addLoadModeLogToCradleAction $ 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+ ConcreteStack t -> stackCradle l cs root (stackComponent t) (projectConfigFromMaybe root (stackYaml t))+ ConcreteBios bios deps mbGhc -> biosCradle l cs root bios deps mbGhc ConcreteDirect xs -> directCradle l root xs ConcreteNone -> noneCradle ConcreteOther a -> buildCustomCradle a where -- Add a log message to each loading operation.- addLoadStyleLogToCradleAction crdlAct = crdlAct- { runCradle = \fp ls -> do- l <& LogRequestedCradleLoadStyle (T.pack $ show $ actionName crdlAct) ls `WithSeverity` Debug- runCradle crdlAct fp ls+ addLoadModeLogToCradleAction crdlAct = crdlAct+ { runCradle = \fpc ls -> do+ l <& LogRequestedCradleLoadMode (T.pack $ show $ actionName crdlAct) fpc ls `WithSeverity` Debug+ runCradle crdlAct fpc ls } resolveCradleTree :: FilePath -> CradleConfig a -> [ResolvedCradle a]@@ -342,9 +233,9 @@ where maybeItsBios = (\wdir -> (Bios (Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir fp - maybeItsStack = stackExecutable >> (Stack $ StackType Nothing Nothing,) <$> stackWorkDir fp+ maybeItsStack = stackExecutable >> (Stack $ StackType Nothing Nothing Nothing,) <$> stackWorkDir fp - maybeItsCabal = (Cabal $ CabalType Nothing Nothing,) <$> cabalWorkDir fp+ maybeItsCabal = (Cabal $ CabalType Nothing Nothing Nothing,) <$> cabalWorkDir fp -- maybeItsObelisk = (Obelisk,) <$> obeliskWorkDir fp @@ -364,7 +255,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 +345,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 +354,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@@ -478,7 +361,7 @@ = CradleAction { actionName = Types.Direct , runCradle = \_ loadStyle -> do- logCradleHasNoSupportForLoadWithContext l loadStyle "direct"+ logCradleHasNoSupportForLoadFileWithContext l loadStyle "direct" return (CradleSuccess (ComponentOptions (args ++ argDynamic) wdir [])) , runGhcCmd = runGhcCmdOnPath l wdir }@@ -489,67 +372,124 @@ -- | 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'+-- | shared between @biosDepsAction@ and @biosAction@.+biosFilePaths :: TargetWithContext -> LoadMode -> [FilePath]+biosFilePaths fpc = \case+ LoadFile -> [targetFilePath fpc]+ LoadFileWithContext -> targetAndContext fpc+ -- Exhaustive matching to trigger type errors for datatype changes.+ LoadUnitsInferred -> targetAndContext fpc+ LoadUnitsFromCradle -> targetAndContext fpc++biosDepsAction :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe Callable -> TargetWithContext -> LoadMode -> IO [FilePath]+biosDepsAction l wdir (Just biosDepsCall) fpc loadStyle = do++ let fps = biosFilePaths fpc loadStyle++ (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+ -> TargetWithContext+ -> LoadMode -> 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 fpc loadStyle = do+ let fp = targetFilePath fpc+ ghc_version <- liftIO $ runCachedIO $ ghcVersion $ cradleProgramVersions rc+ let warnUnsupportedLoadMode msg =+ liftIO $ l <& WithSeverity+ (LogLoadModeUnsupported "bios" loadStyle (Just msg))+ Warning+ determinedLoadMode <- case ghc_version of+ Just ghc+ | ghc >= makeVersion [9,4] -> do+ -- Multi-component supported from ghc 9.4+ -- We trust the assertion for a bios program, as we have no way of+ -- checking its version+ pure $ case loadStyle of+ LoadFile -> LoadFile+ LoadFileWithContext -> LoadFileWithContext+ LoadUnitsFromCradle -> LoadFileWithContext+ LoadUnitsInferred -> LoadFileWithContext+ | loadStyle /= LoadFile -> do+ warnUnsupportedLoadMode "ghc version is too old. We require `ghc >= 9.4`"+ pure LoadFile+ _ -> do+ warnUnsupportedLoadMode "Unable to determine ghc version. We require `ghc >= 9.4`"+ pure LoadFile++ let fps = biosFilePaths fpc determinedLoadMode+ (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- Nothing -> biosDepsAction l wdir bios_deps fp loadStyle+ Nothing -> biosDepsAction l wdir bios_deps fpc determinedLoadMode -- Output from the program should be written to the output file and -- delimited by newlines. -- Execute the bios action and add dependencies of the cradle. -- 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`.@@ -557,443 +497,14 @@ cabalCradle l cs wdir mc projectFile = 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 ""+ , runCradle = \fpc -> runCradleResultT . cabalAction cs wdir mc l projectFile fpc+ , 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 ------------------------------------------------------------------------ @@ -1007,16 +518,16 @@ -- | Stack Cradle -- Works for by invoking `stack repl` with a wrapper script-stackCradle :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe String -> CradleProjectConfig -> CradleAction a-stackCradle l wdir mc syaml =+stackCradle :: LogAction IO (WithSeverity Log) -> ResolvedCradles b -> FilePath -> Maybe String -> CradleProjectConfig -> CradleAction a+stackCradle l cs wdir mc syaml = CradleAction { actionName = Types.Stack- , runCradle = stackAction wdir mc syaml l+ , runCradle = stackAction wdir mc syaml l cs , 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) "" }@@ -1043,22 +554,43 @@ -> Maybe String -> CradleProjectConfig -> LogAction IO (WithSeverity Log)- -> FilePath- -> LoadStyle+ -> ResolvedCradles a+ -> TargetWithContext+ -> LoadMode -> IO (CradleLoadResult ComponentOptions)-stackAction workDir mc syaml l fp loadStyle = do- logCradleHasNoSupportForLoadWithContext l loadStyle "stack"- let ghcProcArgs = ("stack", stackYamlProcessArgs syaml <> ["exec", "ghc", "--"])+stackAction workDir mc syaml l cs fpc loadStyle = do+ let fp = targetFilePath fpc+ logCradleHasNoSupportForLoadFileWithContext l loadStyle "stack"+ 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+ let+ fallback = [ comp | Just comp <- [mc] ]+ componentsToLoad = nubOrd <$> mconcat+ [ comps+ | ResolvedCradle{concreteCradle = ConcreteStack+ (StackType {stackComponentsToLoad = comps})} <- resolvedCradles cs ]+ allComponents = [ comp+ | ResolvedCradle{concreteCradle = ConcreteStack+ (StackType {stackComponent = Just comp})} <- resolvedCradles cs ]+ -- for stack we do not include --test --bench to avoid triggering stack repl limitations.+ inferred = []+ components = case loadStyle of+ LoadUnitsFromCradle+ | Just comps <- componentsToLoad -> comps+ | null allComponents -> inferred+ | otherwise -> allComponents+ LoadUnitsInferred -> inferred+ LoadFile -> fallback+ LoadFileWithContext -> fallback (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] ]+ <> components (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 +632,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 +642,7 @@ -- rulesHaskellWorkDir :: FilePath -> MaybeT IO FilePath rulesHaskellWorkDir fp =- findFileUpwards (== "WORKSPACE") fp+ findFileUpwards "WORKSPACE" fp rulesHaskellCradle :: FilePath -> Cradle rulesHaskellCradle wdir =@@ -1178,106 +708,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,46 +719,15 @@ -- | 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.-logCradleHasNoSupportForLoadWithContext :: Applicative m => LogAction m (WithSeverity Log) -> LoadStyle -> T.Text -> m ()-logCradleHasNoSupportForLoadWithContext l (LoadWithContext _) crdlName =+-- 'LoadFileWithContext' was requested.+logCradleHasNoSupportForLoadFileWithContext :: Applicative m => LogAction m (WithSeverity Log) -> LoadMode -> T.Text -> m ()+logCradleHasNoSupportForLoadFileWithContext l LoadFileWithContext crdlName = l <& WithSeverity- (LogLoadWithContextUnsupported crdlName+ (LogLoadModeUnsupported crdlName LoadFileWithContext $ Just $ crdlName <> " doesn't support loading multiple components at once" ) Info-logCradleHasNoSupportForLoadWithContext _ _ _ = pure ()+logCradleHasNoSupportForLoadFileWithContext _ _ _ = pure ()
+ src/HIE/Bios/Cradle/Cabal.hs view
@@ -0,0 +1,783 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module HIE.Bios.Cradle.Cabal+ (+ -- * Cabal Cradle interface+ cabalAction,+ runCabalGhcCmd,+ -- * Locations+ findCabalFiles,+ -- * Wrappers+ withGhcWrapperTool,+ -- * Argument processing+ processCabalWrapperArgs,+ -- * Internals (exposed for tests)+ isCabalMultipleCompSupported,+ cabalBuildDir,+ )+ where++import Data.Char (isSpace)+import System.Exit+import System.Directory+import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))+import Control.Monad+import Control.Monad.Extra (concatMapM)+import Control.Monad.IO.Class+import Data.Aeson ((.:))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import qualified Data.ByteString as BS+import Data.Conduit.Process+import Data.Maybe (fromMaybe)+import Data.List+import Data.List.Extra (trimEnd, nubOrd)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import System.FilePath+import System.Info.Extra (isWindows)+import System.IO.Temp+import Data.Version++import HIE.Bios.Config+import HIE.Bios.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 ->+ TargetWithContext ->+ LoadMode ->+ CradleLoadResultT IO ComponentOptions+cabalAction cradles workDir mc l projectFile fp loadStyle = do+ let progVersions = cradleProgramVersions cradles+ multiCompSupport <- isCabalMultipleCompSupported progVersions+ -- determine which load style is supported by this cabal cradle.+ determinedLoadMode <- case loadStyle of+ LoadFile -> pure LoadFile+ -- all other modes need multi component support.+ _ | not multiCompSupport -> do+ liftIO $+ l+ <& WithSeverity+ ( LogLoadModeUnsupported "cabal" loadStyle $+ Just "cabal or ghc version is too old. We require `cabal >= 3.11` and `ghc >= 9.4`"+ )+ Warning+ pure LoadFile+ _ -> pure loadStyle++ (cabalArgs, loadingFiles, extraDeps) <- processCabalLoadMode l cradles projectFile workDir mc fp determinedLoadMode++ 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 = nubOrd (deps <> extraDeps)+ , cradleErrorExitCode = ExitFailure code+ , cradleErrorStderr = [errorMsg] <> prettyProcessErrorDetails errorDetails+ , cradleErrorLoadingFiles = loadingFiles+ }+ Right (args, errorDetails) -> do+ case processCabalWrapperArgs args of+ Nothing -> do+ -- Provide some dependencies an IDE can look for to trigger a reload.+ -- Best effort. Assume the working directory is the+ -- root of the component, so we are right in trivial cases at least.+ deps <- liftIO $ cabalCradleDependencies projectFile workDir workDir+ throwCE CradleError+ { cradleErrorDependencies = nubOrd (deps <> extraDeps)+ , cradleErrorExitCode = ExitSuccess+ , cradleErrorStderr = ["Failed to parse result of calling cabal"] <> prettyProcessErrorDetails errorDetails+ , cradleErrorLoadingFiles = loadingFiles+ }+ Just (componentDir, ghc_args) -> do+ deps <- liftIO $ cabalCradleDependencies projectFile workDir componentDir+ usesResponseFiles <- usesResponseFilesForAllGhcOptions progVersions+ final_args <- case usesResponseFiles of+ True -> liftIO $ expandGhcOptionResponseFile ghc_args+ False -> pure ghc_args+ CradleLoadResultT $ pure $ CradleSuccess+ ComponentOptions+ { componentOptions = final_args+ , componentRoot = componentDir+ , componentDependencies = nubOrd (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 ""++data LoadUnits = Inferred | FromCradle+ deriving Eq++processCabalLoadMode :: MonadIO m => LogAction IO (WithSeverity Log) -> ResolvedCradles a -> CradleProjectConfig -> [Char] -> Maybe FilePath -> TargetWithContext -> LoadMode -> m ([FilePath], [FilePath], [FilePath])+processCabalLoadMode l cradles projectFile workDir mc fpc loadStyle = do+ (cabalArgs, loadingFiles, extraDeps) <- case loadStyle of+ LoadFile -> pure ([fpModule], [fp], [])+ LoadFileWithContext -> do+ let fps = targetContext fpc+ (modPairs, mergedDeps) <- moduleFilesFromSameProject fps+ let allModPairs = nubOrd $ (fpModule, fp) : modPairs+ allModules = nubOrd $ fmap fst allModPairs+ allFiles = nubOrd $ fmap snd allModPairs+ pure (["--enable-multi-repl"] ++ allModules, allFiles, mergedDeps)+ LoadUnitsInferred -> loadUnits Inferred+ LoadUnitsFromCradle -> loadUnits FromCradle++ liftIO $ l <& LogComputedCradleLoadMode "cabal" fpc loadStyle `WithSeverity` Info+ liftIO $ l <& LogCabalLoad fp mc (prefix <$> resolvedCradles cradles) loadingFiles `WithSeverity` Debug+ pure (cabalArgs, loadingFiles, extraDeps)+ where+ fpModule = fromMaybe (fixTargetPath fp) mc+ fp = targetFilePath fpc+ -- Need to make relative on Windows, due to a Cabal bug with how it+ -- parses file targets with a C: drive in it. So we decide to make+ -- the paths relative to the working directory.+ fixTargetPath x+ | isWindows && hasDrive x = makeRelative workDir x+ | otherwise = x+ -- Return (moduleTarget,file) pairs for each context file, plus a merged dependency list across all of them.+ moduleFilesFromSameProject :: MonadIO m => [FilePath] -> m ([(FilePath, FilePath)], [FilePath])+ moduleFilesFromSameProject fps = do+ -- First, select eligible files and collect their componentDir and YAML deps+ let selected =+ [ (file, depsYaml, prefix rc, cabalComponent ct)+ | file <- fps+ , Just rc@(ResolvedCradle {concreteCradle = ConcreteCabal ct, cradleDeps = depsYaml}) <- [selectCradle prefix file (resolvedCradles cradles)]+ , (projectConfigFromMaybe (cradleRoot cradles) (cabalProjectFile ct)) == projectFile+ ]+ -- Compute dynamic deps+ let compDirs = nubOrd $ takeDirectory fp : [ takeDirectory f | (f, _, _, _) <- selected ]+ dynDeps <- concatMapM (liftIO . cabalCradleDependenciesEnclosing projectFile (cradleRoot cradles)) compDirs+ -- Combine YAML deps with dynamic deps+ let mergedDeps = nubOrd $ dynDeps ++ concat [ depsYaml | (_, depsYaml, _ , _) <- selected ]+ let modPairs = [ (fromMaybe (fixTargetPath file) old_mc, file)+ | (file, _, _, old_mc) <- selected ]+ pure (modPairs, mergedDeps)++ cabalComponentsFromSameProject :: MonadIO m => Maybe [String] -> m ([String],[FilePath])+ cabalComponentsFromSameProject mToLoad = do++ let selected =+ [ (comp, prefix rc, depsYaml)+ | rc@(ResolvedCradle {concreteCradle = ConcreteCabal ct, cradleDeps = depsYaml}) <- (resolvedCradles cradles)+ , Just comp <- [cabalComponent ct]+ , maybe True (comp `elem`) mToLoad+ , (projectConfigFromMaybe (cradleRoot cradles) (cabalProjectFile ct)) == projectFile+ ]+ let compDirs = nubOrd $ [dir | (_,dir,_) <- selected]+ dynDeps <- concatMapM (liftIO . cabalCradleDependenciesEnclosing projectFile (cradleRoot cradles)) compDirs+ let mergedDeps = nubOrd $ dynDeps ++ concat [ depsYaml | (_, _, depsYaml) <- selected ]+ pure ([comp | (comp,_,_) <- selected], mergedDeps)++ loadUnits whichUnits0 = do+ let+ componentsToLoad = do+ guard (whichUnits0 == FromCradle)+ nubOrd <$> mconcat+ [ cs+ | ResolvedCradle{concreteCradle = ConcreteCabal+ (CabalType {cabalComponentsToLoad = cs})} <- resolvedCradles cradles ]++ -- compDeps includes the .cabal files of the specified components (if the prefixes are there and accurate)+ -- These are used as dependencies for both Inferred and FromCradle modes.+ -- They might not be accurate for `Inferred`, but we have no easy way to query the cabal project for the complete set.+ (cradleComponents,compDeps) <- cabalComponentsFromSameProject componentsToLoad+ let+ whichUnits+ | Just units <- componentsToLoad+ = (whichUnits0, units)+ -- Note we default to Inferred only if componentsToLoad is not declared.+ | null cradleComponents = (Inferred , [])+ | otherwise = (whichUnits0, cradleComponents)++ let fps = targetContext fpc+ (modPairs, mergedDeps0) <- moduleFilesFromSameProject fps+ let allModPairs = nubOrd $ (fpModule, fp) : modPairs+ allModules = nubOrd $ fmap fst allModPairs+ allFiles = nubOrd $ fmap snd allModPairs+ let mergedDeps = mergedDeps0 ++ compDeps+ let compArgs = case whichUnits of+ (Inferred,_) -> enableFlags ++ ["all"]+ where+ enableFlags = case projectFile of+ NoExplicitConfig+ -> ["--enable-tests","--enable-benchmarks"]+ _ -> []+ (FromCradle,units) -> units+ pure (["--enable-multi-repl"] ++ compArgs ++ allModules, allFiles, mergedDeps)++cabalLoadFilesWithRepl :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> [String] -> CradleLoadResultT IO CreateProcess+cabalLoadFilesWithRepl l projectFile workDir args = do+ buildDir <- liftIO $ cabalBuildDir workDir+ newEnvironment <- liftIO Process.getCleanEnvironment+ wrapper_fp <- liftIO $ withReplWrapperTool l (proc "ghc") workDir+ let+ cabalCommand = "v2-repl"+ cabalArgs =+ -- Don't clobber the user's 'dist-newstyle': pass --builddir (#501)+ [ "--builddir=" <> buildDir+ , cabalCommand, "--keep-temp-files", "--with-repl", wrapper_fp+ ] <> projectFileProcessArgs projectFile <> args+ pure $+ (proc "cabal" cabalArgs)+ { env = Just newEnvironment+ , cwd = Just workDir+ }++-- | @'cabalCradleDependencies' projectFile rootDir componentDir@.+-- Compute the dependencies of the cabal cradle based+-- on cabal project configuration, the cradle root and the component directory.+--+-- The @projectFile@ and @projectFile <> ".local"@ are always added to the list+-- of dependencies.+--+-- Directory 'componentDir' is a sub-directory where we look for+-- package specific cradle dependencies, such as a '.cabal' file.+--+-- Found dependencies are relative to 'rootDir'.+cabalCradleDependencies :: CradleProjectConfig -> FilePath -> FilePath -> IO [FilePath]+cabalCradleDependencies projectFile rootDir componentDir = do+ let relFp = makeRelative rootDir componentDir+ cabalFiles' <- findCabalFiles componentDir+ let cabalFiles = map (relFp </>) cabalFiles'+ return $ map normalise $ cabalFiles ++ projectLocationOrDefault projectFile++-- | @'cabalCradleDependenciesEnclosing' projectFile rootDir startDir@.+-- Find cradle dependency files by walking upwards from a starting directory.+--+-- This is similar to 'cabalCradleDependencies', but instead of looking only in a+-- specific component directory, it searches for @.cabal@ files in @startDir@ and+-- its ancestor directories, stopping at (and not traversing above) @rootDir@ or+-- the filesystem root. All discovered @.cabal@ files are returned relative to+-- @rootDir@, along with the cabal project configuration files determined by+-- 'projectLocationOrDefault'.+--+-- Inputs+-- - projectFile: the cradle's cabal project configuration (explicit file or default).+-- - rootDir: absolute cradle root; used as the boundary for the upward search and+-- to relativize returned paths.+-- - startDir: directory from which to begin searching for enclosing @.cabal@ files.+--+-- Output+-- - A list of normalised, relative file paths that should be watched to trigger+-- a reload when changed.+cabalCradleDependenciesEnclosing :: CradleProjectConfig -> FilePath -> FilePath -> IO [FilePath]+cabalCradleDependenciesEnclosing projectFile rootDir fp = do+ cabalFiles' <- findCabalFilesEnclosing fp+ let relCabalFiles = map (makeRelative rootDir) cabalFiles'+ return $ map normalise $ relCabalFiles ++ projectLocationOrDefault projectFile+ where+ -- find the cabal file upwards from fp to rootDir+ findCabalFilesEnclosing :: FilePath -> IO [FilePath]+ findCabalFilesEnclosing dir = do+ cfs <- map (dir </>) <$> findCabalFiles dir+ if not (null cfs)+ then return cfs+ else+ let parentDir = takeDirectory dir+ in if parentDir == dir || length parentDir < length rootDir+ then return []+ else findCabalFilesEnclosing parentDir++processCabalWrapperArgs :: [String] -> Maybe (FilePath, [String])+processCabalWrapperArgs args =+ case args of+ (dir: ghc_args) ->+ let final_args =+ removeVerbosityOpts+ $ removeRTS+ $ removeInteractive ghc_args+ in Just (dir, final_args)+ _ -> Nothing++-- ----------------------------------------------------------------------------+-- Legacy cabal commands to obtain ghc-options.+-- These commands are obsolete in the latest cabal version, but we still support+-- them.+-- ----------------------------------------------------------------------------++cabalLoadFilesBefore315 :: LogAction IO (WithSeverity Log) -> ProgramVersions -> CradleProjectConfig -> [Char] -> [String] -> CradleLoadResultT IO CreateProcess+cabalLoadFilesBefore315 l progVersions projectFile workDir args' = do+ let cabalCommand = "v2-repl"+ cabal_version <- liftIO $ runCachedIO $ cabalVersion progVersions++ let args = case cabal_version of+ Just v | v < makeVersion [3,15] -> "--keep-temp-files" : args'+ _ -> args'+ 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+ buildDir <- liftIO $ cabalBuildDir workDir+ let+ args = [ "--builddir=" <> buildDir, "path", "--output-format=json" ]+ <> projectFileProcessArgs projectFile+ bs = BS.fromStrict . T.encodeUtf8 . T.pack+ parse_compiler_path = Aeson.parseEither ((.: "compiler") >=> (.: "path")) <=< Aeson.eitherDecode++ compiler_info <- Process.readProcessWithCwd_ l workDir "cabal" args ""+ case parse_compiler_path (bs compiler_info) of+ Left err -> do+ liftIO $ l <& WithSeverity (LogCabalPath $ T.pack err) Warning+ pure Nothing+ Right a -> pure a++-- ----------------------------------------------------------------------------+-- Version and cabal capability checks+-- ----------------------------------------------------------------------------++data 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++-- | As `cabal repl` started to hit maximum cli invocation length, we changed how repl arguments are+-- passed to GHC. In `cabal 3.15`, `cabal 3.16.0.0`, `cabal 3.17` and onwards, ghc options are+-- passed to GHC via response files.+--+-- This breaks HLS release binary distributions before 2.12, as neither HLS nor hie-bios are capable of handling+-- response files at the top-level.+--+-- In particular, `cabal 3.16.0.0` was released with this change and no HLS bindist before 2.12 works+-- with `cabal 3.16.0.0`.+-- To make `cabal 3.16.*` series compatible with released HLS binaries, we reverted the response file+-- change for the ghc options. This change will apply once `cabal 3.16.1.*` is released.+-- Note, in `cabal 3.17`, i.e. cabal HEAD, we still pass the arguments via response files and will do that for the+-- `cabal 3.18` release.+--+-- So, we have a weird matrix now, between some commit in `cabal 3.15` and `cabal 3.16`, ghc arguments+-- are supplied encoded in a response file, while in `>= cabal 3.16.1`, the arguments are passed verbatim.+-- Then, later on in `cabal-3.17`, we use response files again.+--+-- 'usesResponseFilesForAllGhcOptions' encodes all of this history.+usesResponseFilesForAllGhcOptions :: MonadIO m => ProgramVersions -> m Bool+usesResponseFilesForAllGhcOptions vs = do+ cabal_version <- liftIO $ runCachedIO $ cabalVersion vs+ -- determine which load style is supported by this cabal cradle.+ case cabal_version of+ Just ver+ | ver >= makeVersion [3, 15] && ver <= makeVersion [3, 16, 0, 0] -> pure True+ | ver >= makeVersion [3, 17] -> pure True+ | otherwise -> pure False+ _ -> pure False+++-- | 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 @@+{-# LANGUAGE DeriveFunctor #-}+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, Functor)++-- | 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, Functor)
+ src/HIE/Bios/Cradle/Utils.hs view
@@ -0,0 +1,79 @@+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)+import HIE.Bios.Ghc.Gap (removeRTS)++-- ----------------------------------------------------------------------------+-- 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.+-- TODO: this finds the first cradle that matches, while hie-bios README says most-specific cradle would match, unless the inputs are assumed sorted by specificity?+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")++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/Environment.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards, CPP #-}-module HIE.Bios.Environment (initSession, getRuntimeGhcLibDir, getRuntimeGhcVersion, makeDynFlagsAbsolute, makeTargetsAbsolute, getCacheDir, addCmdOpts) where+{-# LANGUAGE TupleSections #-}+module HIE.Bios.Environment (initSession, initSession', getRuntimeGhcLibDir, getRuntimeGhcVersion, makeDynFlagsAbsolute, makeTargetsAbsolute, getCacheDir, addCmdOpts, extractUnits) where import GHC (GhcMonad) import qualified GHC as G@@ -21,6 +22,14 @@ import HIE.Bios.Types import qualified HIE.Bios.Ghc.Gap as Gap+import qualified System.OsPath as OsPath+import qualified GHC.Plugins as G+import qualified Data.List.NonEmpty as NE+import qualified GHC.Driver.Monad as G+import Data.IORef (newIORef, readIORef)+import qualified GHC.Unit.Env as G+import GHC.Driver.Env (HscEnv(hsc_unit_env))+import Data.Maybe (fromMaybe) -- | Start a GHC session and set some sensible options for tooling to use. -- Creates a folder in the cache directory to cache interface files to make@@ -28,27 +37,83 @@ initSession :: (GhcMonad m) => ComponentOptions -> m [G.Target]-initSession ComponentOptions {..} = do- df <- G.getSessionDynFlags+initSession = initSession' False++initSession' :: (GhcMonad m)+ => Bool+ -> ComponentOptions+ -> m [G.Target]+initSession' workAroundThreadUnsafety ComponentOptions {..} = do -- Create a unique folder per set of different GHC options, assuming that each different set of -- GHC options will create incompatible interface files.- let opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack componentOptions)- cache_dir <- liftIO $ getCacheDir opts_hash- -- Add the user specified options to a fresh GHC session.- (df', targets) <- addCmdOpts componentOptions df- let df'' = makeDynFlagsAbsolute componentRoot df'- void $ G.setSessionDynFlags- (disableOptimisation -- Compile with -O0 as we are not going to produce object files.- $ setIgnoreInterfacePragmas -- Ignore any non-essential information in interface files such as unfoldings changing.- $ writeInterfaceFiles (Just cache_dir) -- Write interface files to the cache- $ setVerbosity 0 -- Set verbosity to zero just in case the user specified `-vx` in the options.- $ Gap.setWayDynamicIfHostIsDynamic -- Add dynamic way if GHC is built with dynamic linking- $ setLinkerOptions df'' -- Set `-fno-code` to avoid generating object files, unless we have to.- )+ let+ -- There seems to be a race condition when writing interface files+ hash_args = (if workAroundThreadUnsafety then (componentRoot :) else id) componentOptions+ opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init $ map B.pack hash_args - let targets' = makeTargetsAbsolute componentRoot targets+ cache_dir <- liftIO $ makeAbsolute =<< getCacheDir opts_hash++ -- Plan:+ -- - Extract `-unit @resp_file` options if present+ -- - Add the user specified options to a fresh GHC session+ -- - Make all dflags absolute+ -- - Set flags for interactive session+ -- - Reconstruct targets and make them absolute++ let (units,rest) = extractUnits componentOptions++ let liftGhc m = do+ env <- G.getSession+ s <- liftIO (newIORef env)+ x <- liftIO $ G.reflectGhc m (G.Session s)+ G.setSession =<< liftIO (readIORef s)+ pure x+ let+ setFlags df'' =+ void $ G.setSessionDynFlags+ (disableOptimisation -- Compile with -O0 as we are not going to produce object files.+ $ setIgnoreInterfacePragmas -- Ignore any non-essential information in interface files such as unfoldings changing.+ $ writeInterfaceFiles (Just cache_dir) -- Write interface files to the cache+ $ setVerbosity 0 -- Set verbosity to zero just in case the user specified `-vx` in the options.+ $ Gap.setWayDynamicIfHostIsDynamic -- Add dynamic way if GHC is built with dynamic linking+ $ setLinkerOptions df'' -- Set `-fno-code` to avoid generating object files, unless we have to.+ )++ targets <- case NE.nonEmpty units of+ Nothing -> do+ (df',targets) <- addCmdOpts componentOptions =<< G.getSessionDynFlags+ setFlags $ makeDynFlagsAbsolute componentRoot df'+ pure targets+ Just ne_units -> do+ logger <- Gap.getLogger <$> G.getSession+ df <- G.getSessionDynFlags+ -- leftovers won't have targets when units are present.+ (df', _leftovers, _warns) <- Gap.parseDynamicFlags logger df (map G.noLoc rest)+ setFlags $ makeDynFlagsAbsolute componentRoot df'++ hs_srcs <- liftGhc $ Gap.initMulti ne_units (\ _ _ _ _ -> return ())++ G.modifySession $ G.hscUpdateHUG $ fmap (\ ue -> ue {G.homeUnitEnv_dflags = makeDynFlagsAbsolute componentRoot (G.homeUnitEnv_dflags ue)})++ -- This should be an enforced invariant.+ G.modifySession $ \ hsc_env -> G.hscSetActiveUnitId (G.ue_current_unit $ G.hsc_unit_env hsc_env) hsc_env++ mapM (\(src, uid, phase) -> G.guessTarget src uid phase) hs_srcs++ let mkTgtAbs env tgt = tgt {G.targetId = makeTargetIdAbsolute wdir (G.targetId tgt)}+ where+ wdir = fromMaybe componentRoot $+ G.workingDirectory+ . G.homeUnitEnv_dflags . G.ue_findHomeUnitEnv uid+ $ hsc_unit_env env+ uid = G.targetUnitId tgt++ env <- G.getSession+ let targets' = map (mkTgtAbs env) targets+ -- Unset the default log action to avoid output going to stdout. Gap.unsetLogAction+ return targets' ----------------------------------------------------------------@@ -133,7 +198,15 @@ setHiDir :: FilePath -> G.DynFlags -> G.DynFlags setHiDir f d = d { G.hiDir = Just f} +extractUnits :: [String] -> ([String], [String])+extractUnits = go [] []+ where+ -- TODO: we should likely use the 'processCmdLineP' instead+ go units rest ("-unit" : x : xs) = go (x : units) rest xs+ go units rest (x : xs) = go units (x : rest) xs+ go units rest [] = (reverse units, reverse rest) + -- | Interpret and set the specific command line options. -- A lot of this code is just copied from ghc/Main.hs -- It would be good to move this code into a library module so we can just use it@@ -161,16 +234,21 @@ $ df { G.importPaths = map makeAbs (G.importPaths df) , G.packageDBFlags =- map (Gap.overPkgDbRef makeAbs) (G.packageDBFlags df)+ map (Gap.overPkgDbRef makeAbsOs) (G.packageDBFlags df)+ , G.workingDirectory = (root </>) <$> G.workingDirectory df } where makeAbs =-#if __GLASGOW_HASKELL__ >= 903 case G.workingDirectory df of Just fp -> ((root </> fp) </>) Nothing ->-#endif (root </>)++ makeAbsOs p =+ case G.workingDirectory df of+ Just fp -> Gap.unsafeEncodeUtf (root </> fp) OsPath.</> p+ Nothing ->+ Gap.unsafeEncodeUtf root OsPath.</> p -- --------------------------------------------------------
src/HIE/Bios/Flags.hs view
@@ -6,11 +6,9 @@ -- | Initialize the 'DynFlags' relating to the compilation of a single -- file or GHC session according to the provided 'Cradle'.-getCompilerOptions- :: FilePath -- ^ The file we are loading it because of- -> LoadStyle -- ^ previous files we might want to include in the build- -> Cradle a- -> IO (CradleLoadResult ComponentOptions)-getCompilerOptions fp loadStyle cradle = do++-- | Note: @getCompilerOptions (TargetWithContext path cxt) LoadFile@ will warn if `cxt` is non-empty.+getCompilerOptions :: TargetWithContext -> LoadMode -> Cradle a -> IO (CradleLoadResult ComponentOptions)+getCompilerOptions target loadMode cradle = do (cradleLogger cradle) <& LogProcessOutput "invoking build tool to determine build flags (this may take some time depending on the cache)" `WithSeverity` Info- runCradle (cradleOptsProg cradle) fp loadStyle+ runCradle (cradleOptsProg cradle) target loadMode
src/HIE/Bios/Ghc/Api.hs view
@@ -7,6 +7,7 @@ , withDynFlags -- For test purposes , initSessionWithMessage+ , initSessionWithMessage' ) where import GHC (LoadHowMuch(..), DynFlags, GhcMonad)@@ -39,7 +40,7 @@ -> Cradle a -- ^ The cradle we want to load -> m (CradleLoadResult (m G.SuccessFlag, ComponentOptions)) -- ^ Whether we actually loaded the cradle or not. initializeFlagsWithCradleWithMessage msg fp cradle =- fmap (initSessionWithMessage msg) <$> liftIO (getCompilerOptions fp LoadFile cradle)+ fmap (initSessionWithMessage msg) <$> liftIO (getCompilerOptions (TargetWithContext fp []) LoadFile cradle) -- | Actually perform the initialisation of the session. Initialising the session corresponds to -- parsing the command line flags, setting the targets for the session and then attempting to load@@ -48,8 +49,15 @@ => Maybe G.Messager -> ComponentOptions -> (m G.SuccessFlag, ComponentOptions)-initSessionWithMessage msg compOpts = (do- targets <- initSession compOpts+initSessionWithMessage = initSessionWithMessage' False++initSessionWithMessage' :: (GhcMonad m)+ => Bool+ -> Maybe G.Messager+ -> ComponentOptions+ -> (m G.SuccessFlag, ComponentOptions)+initSessionWithMessage' workAroundThreadUnsafety msg compOpts = (do+ targets <- initSession' workAroundThreadUnsafety compOpts G.setTargets targets -- Get the module graph using the function `getModuleGraph` mod_graph <- G.depanal [] True
src/HIE/Bios/Ghc/Gap.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleInstances, CPP, PatternSynonyms #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-} -- | All the CPP for GHC version compability should live in this module. module HIE.Bios.Ghc.Gap ( ghcVersion@@ -11,6 +13,8 @@ , G.modifySession , G.reflectGhc , G.Session(..)+ -- * Compat shims+ , typecheckModule -- * Hsc Monad , getHscEnv -- * Driver compat@@ -41,6 +45,9 @@ , HIE.Bios.Ghc.Gap.parseDynamicFlags -- * Platform constants , hostIsDynamic+ -- * OsPath Compat+ , unsafeEncodeUtf+ , unsafeDecodeUtf -- * misc , getTyThing , fixInfo@@ -52,12 +59,15 @@ , load' , homeUnitId_ , getDynFlags+ , initMulti+ , InRTS(..)+ , removeRTS ) where import Control.Monad.IO.Class import qualified Control.Monad.Catch as E -import GHC+import GHC hiding (typecheckModule,parseTargetFiles) import qualified GHC as G ----------------------------------------------------------------@@ -73,14 +83,16 @@ import qualified GHC.Platform.Ways as Platform import qualified GHC.Runtime.Loader as DynamicLoading (initializePlugins) import qualified GHC.Tc.Types as Tc+import GHC.Unit.Types (UnitId) import GHC.Utils.Logger import GHC.Utils.Outputable import qualified GHC.Utils.Ppr as Ppr import qualified GHC.Driver.Make as G+import System.OsPath (OsPath)+import qualified System.OsPath as OsPath+import Data.Maybe (fromMaybe)+import GHC.Stack.Types (HasCallStack) -#if __GLASGOW_HASKELL__ > 903-import GHC.Unit.Types (UnitId)-#endif #if __GLASGOW_HASKELL__ < 904 import qualified GHC.Driver.Main as G #endif@@ -91,6 +103,21 @@ #if __GLASGOW_HASKELL__ < 907 import GHC.Driver.CmdLine as CmdLine #endif+#if __GLASGOW_HASKELL__ >= 914+import qualified GHC.Driver.Session.Units as G+#else+import GHC.Unit.Home.ModInfo (emptyHomePackageTable)+import GHC.Unit.Env+import Control.Monad+import GHC.ResponseFile (expandResponse)+import Data.List (partition)+import GHC.Driver.Phases (isHaskellishTarget)+import qualified GHC.Unit.State as State+import System.FilePath (isRelative, (</>))+import qualified Data.Map as Map+#endif+import qualified Data.List.NonEmpty as NE+import Data.List (isPrefixOf, isSuffixOf) ghcVersion :: String ghcVersion = VERSION_ghc@@ -106,6 +133,13 @@ load' _ a b c = G.load' a b c #endif +typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule+#if MIN_VERSION_ghc(10, 1, 0)+typecheckModule = G.typecheckModule G.StartAndStopTcMPlugins+#else+typecheckModule = G.typecheckModule+#endif+ bracket :: E.MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b bracket = E.bracket@@ -136,21 +170,22 @@ set_hsc_dflags :: DynFlags -> HscEnv -> HscEnv set_hsc_dflags dflags hsc_env = hsc_env { G.hsc_dflags = dflags } -overPkgDbRef :: (FilePath -> FilePath) -> G.PackageDBFlag -> G.PackageDBFlag+overPkgDbRef :: (OsPath -> OsPath) -> G.PackageDBFlag -> G.PackageDBFlag overPkgDbRef f (G.PackageDB pkgConfRef) = G.PackageDB $ case pkgConfRef of- G.PkgDbPath fp -> G.PkgDbPath (f fp)+ G.PkgDbPath fp ->+#if __GLASGOW_HASKELL__ >= 915+ G.PkgDbPath (f fp)+#else+ G.PkgDbPath (unsafeDecodeUtf $ f $ unsafeEncodeUtf fp)+#endif+ conf -> conf overPkgDbRef _f db = db ---------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 903 guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe G.Phase -> m G.Target guessTarget a b c = G.guessTarget a b c-#else-guessTarget :: GhcMonad m => String -> a -> Maybe G.Phase -> m G.Target-guessTarget a _ b = G.guessTarget a b-#endif ---------------------------------------------------------------- @@ -180,9 +215,7 @@ G.IncludeSpecs (map f $ G.includePathsQuote (includePaths df)) (map f $ G.includePathsGlobal (includePaths df))-#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) (map f $ G.includePathsQuoteImplicit (includePaths df))-#endif } ----------------------------------------------------------------@@ -195,11 +228,7 @@ setSession env noopLogger :: LogAction-#if __GLASGOW_HASKELL__ >= 903 noopLogger = (\_wr _s _ss _m -> return ())-#else-noopLogger = (\_df _wr _s _ss _m -> return ())-#endif -- -------------------------------------------------------- -- Doc Compat functions@@ -217,11 +246,7 @@ -- -------------------------------------------------------- numLoadedPlugins :: HscEnv -> Int-#if __GLASGOW_HASKELL__ >= 903 numLoadedPlugins = length . Plugins.pluginsWithArgs . hsc_plugins-#else-numLoadedPlugins = length . Plugins.plugins-#endif initializePluginsForModSummary :: HscEnv -> ModSummary -> IO (Int, [G.ModuleName], ModSummary) initializePluginsForModSummary hsc_env' mod_summary = do@@ -292,3 +317,129 @@ hostIsDynamic :: Bool hostIsDynamic = Platform.hostIsDynamic++-- --------------------------------------------------------+-- OsPath Compat+-- --------------------------------------------------------++unsafeEncodeUtf :: HasCallStack => FilePath -> OsPath+unsafeEncodeUtf fp =+#if MIN_VERSION_filepath(1,5,0)+ OsPath.unsafeEncodeUtf fp+#else+ fromMaybe (error "unsafeEncodeUtf") $ OsPath.encodeUtf fp+#endif++unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath+unsafeDecodeUtf = fromMaybe (error "unsafeDecodeUtf") . OsPath.decodeUtf++initMulti :: NE.NonEmpty String -> (DynFlags -> [(String, Maybe Phase)] -> [String] -> [String] -> IO ()) -> Ghc [(String, Maybe UnitId, Maybe Phase)]+#if __GLASGOW_HASKELL__ >= 914+initMulti = G.initMulti+#else++-- taken from ghc-9.6.7, dropping some checks and logging.+initMulti unitArgsFiles _check = do+ hsc_env <- GHC.getSession+ let logger = hsc_logger hsc_env+ initial_dflags <- GHC.getSessionDynFlags++ dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do+ when (verbosity initial_dflags > 2) (liftIO $ print f)+ args <- liftIO $ expandResponse [f]+ (dflags2, fileish_args, _warns) <- parseDynamicFlagsCmdLine initial_dflags (map (mkGeneralLocated f) (removeRTS args))++ let (dflags3, srcs, _objs) = parseTargetFiles dflags2 (map unLoc fileish_args)+ dflags4 = offsetDynFlags dflags3++ let (hs_srcs, _non_hs_srcs) = partition isHaskellishTarget srcs+ pure (dflags4, hs_srcs)++ let+ unitDflags = NE.map fst dynFlagsAndSrcs+ srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs+ (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs))++ let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags+ home_units = unitEnv_keys initial_home_graph++ home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do+ let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+ hue_flags = homeUnitEnv_dflags homeUnitEnv+ dflags = homeUnitEnv_dflags homeUnitEnv+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units++ updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants+ pure $ HomeUnitEnv+ { homeUnitEnv_units = unit_state+ , homeUnitEnv_unit_dbs = Just dbs+ , homeUnitEnv_dflags = updated_dflags+ , homeUnitEnv_hpt = emptyHomePackageTable+ , homeUnitEnv_home_unit = Just home_unit+ }++ let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph+ unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }++ GHC.setSession final_hsc_env++ return $ concat hs_srcs++offsetDynFlags :: DynFlags -> DynFlags+offsetDynFlags dflags =+ dflags { hiDir = c hiDir+ , objectDir = c objectDir+ , stubDir = c stubDir+ , hieDir = c hieDir+ , dumpDir = c dumpDir }++ where+ c f = augment_maybe (f dflags)++ augment_maybe Nothing = Nothing+ augment_maybe (Just f) = Just (augment f)+ augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f+ | otherwise = f+++createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> (HomeUnitGraph, UnitId)+createUnitEnvFromFlags unitDflags =+ let+ newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing+ unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags+ activeUnit = fst $ NE.head unitEnvList+ in+ (unitEnv_new (Map.fromList (NE.toList (unitEnvList))), activeUnit)+++#endif++-- | 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
src/HIE/Bios/Ghc/Load.hs view
@@ -20,12 +20,7 @@ import qualified GHC.Driver.Main as G import qualified HIE.Bios.Ghc.Gap as Gap-#if __GLASGOW_HASKELL__ > 903 import GHC.Fingerprint-#endif-#if __GLASGOW_HASKELL__ < 903-import Data.Time.Clock-#endif data Log = LogLoaded FilePath FilePath@@ -118,16 +113,9 @@ -- fool the recompilation checker so that we can get the typechecked modules updateTime :: MonadIO m => [Target] -> ModuleGraph -> m ModuleGraph updateTime ts graph = liftIO $ do-#if __GLASGOW_HASKELL__ < 903- cur_time <- getCurrentTime-#endif let go ms | any (msTargetIs ms) ts =-#if __GLASGOW_HASKELL__ >= 903 ms {ms_hs_hash = fingerprint0}-#else- ms {ms_hs_date = cur_time}-#endif | otherwise = ms pure $ Gap.mapMG go graph @@ -175,7 +163,7 @@ -> Gap.Hsc Gap.FrontendResult astHook logger tc_ref ms = ghcInHsc $ do p <- G.parseModule =<< initializePluginsGhc logger ms- tcm <- G.typecheckModule p+ tcm <- Gap.typecheckModule p let tcg_env = fst (tm_internals_ tcm) liftIO $ modifyIORef tc_ref (tcm :) return $ Gap.FrontendTypecheck tcg_env
src/HIE/Bios/Ghc/Logger.hs view
@@ -24,10 +24,8 @@ import HIE.Bios.Ghc.Api (withDynFlags) import qualified HIE.Bios.Ghc.Gap as Gap -#if __GLASGOW_HASKELL__ >= 903 import GHC.Types.Error import GHC.Driver.Errors.Types-#endif ---------------------------------------------------------------- @@ -46,9 +44,7 @@ appendLogRef :: DynFlags -> Gap.PprStyle -> LogRef -> LogAction appendLogRef df style (LogRef ref) _-#if __GLASGOW_HASKELL__ < 903- _ sev-#elif __GLASGOW_HASKELL__ < 905+#if __GLASGOW_HASKELL__ < 905 (MCDiagnostic sev _) #else (MCDiagnostic sev _ _)@@ -56,6 +52,7 @@ src msg = do let !l = ppMsg src sev df style msg modifyIORef ref (\b -> b . (l:))+appendLogRef _ _ _ _ _ _ _ = pure () ---------------------------------------------------------------- @@ -88,14 +85,9 @@ sourceError err = do dflag <- getSessionDynFlags style <- getStyle dflag-#if __GLASGOW_HASKELL__ >= 903 let ret = unlines . errBagToStrList dflag style . getMessages . srcErrorMessages $ err-#else- let ret = unlines . errBagToStrList dflag style . srcErrorMessages $ err-#endif return (Left ret) -#if __GLASGOW_HASKELL__ >= 903 errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope GhcMessage) -> [String] errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList @@ -108,19 +100,6 @@ msg = pprLocMsgEnvelope (defaultDiagnosticOpts @GhcMessage) err #else msg = pprLocMsgEnvelope err-#endif- -- fixme-#else-errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope DecoratedSDoc) -> [String]-errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList---ppErrMsg :: DynFlags -> Gap.PprStyle -> MsgEnvelope DecoratedSDoc -> String-ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext- where- spn = errMsgSpan err- msg = pprLocMsgEnvelope err- -- fixme #endif ppMsg :: SrcSpan -> G.Severity-> DynFlags -> Gap.PprStyle -> SDoc -> String
src/HIE/Bios/Internal/Debug.hs view
@@ -25,12 +25,14 @@ -- -- Otherwise, shows the error message and exit-code. debugInfo :: Show a- => FilePath+ => TargetWithContext+ -> LoadMode -> Cradle a -> IO String-debugInfo fp cradle = unlines <$> do+debugInfo fpc loadStyle cradle = unlines <$> do+ let fp = targetFilePath fpc let logger = cradleLogger cradle- res <- getCompilerOptions fp LoadFile cradle+ res <- getCompilerOptions fpc loadStyle cradle canonFp <- canonicalizePath fp conf <- findConfig canonFp crdl <- findCradle' logger canonFp
+ 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@@ -96,13 +102,20 @@ | LogProcessOutput String | LogCreateProcessRun CreateProcess | LogProcessRun FilePath [FilePath]- | LogRequestedCradleLoadStyle !T.Text !LoadStyle- | LogComputedCradleLoadStyle !T.Text !LoadStyle- | LogLoadWithContextUnsupported !T.Text !(Maybe T.Text)+ | LogRequestedCradleLoadMode !T.Text !TargetWithContext !LoadMode+ | LogComputedCradleLoadMode !T.Text !TargetWithContext !LoadMode+ | LogLoadModeUnsupported !T.Text LoadMode !(Maybe T.Text) | LogCabalLoad !FilePath !(Maybe String) ![FilePath] ![FilePath]+ | LogCabalLibraryTooOld [String] | LogCabalPath !T.Text deriving (Show) +instance Pretty LoadMode where+ pretty = viaShow++instance Pretty TargetWithContext where+ pretty (TargetWithContext fp fps) = pretty fp <> list (map pretty fps)+ instance Pretty Log where pretty (LogAny s) = pretty s pretty (LogProcessOutput s) = pretty s@@ -122,32 +135,56 @@ ] where envText = map (indent 2 . pretty) $ prettyProcessEnv cp- pretty (LogRequestedCradleLoadStyle crdlName ls) =+ pretty (LogRequestedCradleLoadMode crdlName fpc ls) = "Requested to load" <+> pretty crdlName <+> "cradle" <+> case ls of- LoadFile -> "using single file mode"- LoadWithContext fps -> "using all files (multi-components):" <> line <> indent 4 (pretty fps)- pretty (LogComputedCradleLoadStyle crdlName ls) =+ LoadFile -> "using single file mode" <+> parens ("target =" <+> pretty fpc)+ LoadFileWithContext -> "using all files (multi-components):" <> line <> indent 4 (pretty fpc)+ LoadUnitsFromCradle -> "using all units specified in cradle" <+> fallback+ LoadUnitsInferred -> "using all units from project" <+> fallback+ where+ fallback = parens $ "fallback info: " <+> pretty fpc+ pretty (LogComputedCradleLoadMode crdlName _fpc ls) = "Load" <+> pretty crdlName <+> "cradle" <+> case ls of LoadFile -> "using single file"- LoadWithContext _ -> "using all files (multi-components)"-- pretty (LogLoadWithContextUnsupported crdlName mReason) =+ LoadFileWithContext -> "using all files (multi-components)"+ LoadUnitsFromCradle -> "using all units specified in cradle"+ LoadUnitsInferred -> "using all units from project"+ pretty (LogLoadModeUnsupported crdlName mode mReason) = pretty crdlName <+> "cradle doesn't support loading using all files (multi-components)" <> case mReason of Nothing -> "." Just reason -> ", because:" <+> pretty reason <> "."- <+> "Falling back loading to single file mode."+ <+> "Falling back" <+> parens ("from" <+> pretty mode ) <+> "loading to single file mode." pretty (LogCabalLoad file prefixes projectFile crs) = "Cabal Loading file" <+> pretty file <> 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) --- | The 'LoadStyle' instructs a cradle on how to load a given file target.-data LoadStyle+type Component = String++-- | @TargetWithContext@ is only directly relevant for @LoadFile@ and @LoadFileWithContext@ modes.+-- Other modes though can fallback on those two, so relevant regardless.+data TargetWithContext = TargetWithContext+ { targetFilePath :: !FilePath+ , targetContext :: ![FilePath]+ }+ deriving (Show)++singleTarget :: FilePath -> TargetWithContext+singleTarget fp = TargetWithContext fp []++targetAndContext :: TargetWithContext -> [FilePath]+targetAndContext (TargetWithContext fp fps) = fp:fps++-- | The 'LoadMode' instructs a cradle on how to load a given file target.+data LoadMode = LoadFile -- ^ Instruct the cradle to load the given file target. --@@ -155,7 +192,7 @@ -- will configure the whole component the file target belongs to, and produce -- component options to load the component, which is the minimal unit of code in cabal repl. -- A 'default' cradle, on the other hand, will only load the given filepath.- | LoadWithContext [FilePath]+ | LoadFileWithContext -- ^ Give a cradle additional context for loading a file target. -- -- The context instructs the cradle to load the file target, while also loading@@ -163,12 +200,14 @@ -- This is useful for cradles that support loading multiple code units at once, -- e.g. cabal cradles can use the 'multi-repl' feature to set up a multiple home unit -- session in GHC.- deriving (Show, Eq, Ord)+ | LoadUnitsInferred+ | LoadUnitsFromCradle+ deriving (Eq,Ord,Enum,Bounded,Show) data CradleAction a = CradleAction { actionName :: ActionName a -- ^ Name of the action.- , runCradle :: FilePath -> LoadStyle -> IO (CradleLoadResult ComponentOptions)+ , runCradle :: TargetWithContext -> LoadMode -> IO (CradleLoadResult ComponentOptions) -- ^ Options to compile the given file with. , runGhcCmd :: [String] -> IO (CradleLoadResult String) -- ^ Executes the @ghc@ binary that is usually used to@@ -310,12 +349,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
@@ -4,27 +4,36 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-}-module Main where+module Main (main) where import Utils import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.ExpectedFailure-import qualified Test.Tasty.Options as Tasty import qualified Test.Tasty.Ingredients as Tasty+import qualified Test.Tasty.Options as Tasty+import qualified Test.Tasty.Runners as Tasty import HIE.Bios import HIE.Bios.Cradle-import Control.Monad ( forM_ )-import Data.List ( sort, isPrefixOf )+import HIE.Bios.Cradle.Cabal (cabalBuildDir)+import HIE.Bios.Types (LoadMode(..))+import Control.Monad (forM_, forM, unless)+import Control.Monad.Extra (unlessM)+import Control.Monad.IO.Class+import Data.Foldable (for_)+import Data.List ( sort, isPrefixOf, isInfixOf, tails ) import Data.Typeable+import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import System.Directory import System.FilePath ((</>), makeRelative)-import System.Exit (ExitCode(ExitSuccess, ExitFailure))-import Control.Monad.Extra (unlessM)+import System.Info.Extra (isWindows)+import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout) import qualified HIE.Bios.Ghc.Gap as Gap-import Control.Monad.IO.Class+import HIE.Bios.Cradle.Utils (expandGhcOptionResponseFile)+import HIE.Bios.Environment (extractUnits) + argDynamic :: [String] argDynamic = ["-dynamic" | Gap.hostIsDynamic] @@ -34,7 +43,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@@ -54,12 +63,17 @@ -- to avoid recompilation. main :: IO () main = do+ for_ [stderr, stdout] (`hSetBuffering` LineBuffering) writeStackYamlFiles stackDep <- checkToolIsAvailable "stack" cabalDep <- checkToolIsAvailable "cabal" extraGhcDep <- checkToolIsAvailable extraGhc defaultMainWithIngredients (ignoreToolTests:verboseLogging:defaultIngredients) $+ -- Run tests sequentially on Windows, to avoid issues with locking of the+ -- package database, e.g. errors of the form:+ -- package.db/package.cache.lock: openBinaryFile: resource busy (file is locked)+ (if isWindows then localOption (Tasty.NumThreads 1) else id) $ testGroup "Bios-tests" [ testGroup "Find cradle" findCradleTests , testGroup "Symlink" symbolicLinkTests@@ -77,8 +91,8 @@ initCradle "doesNotExist.hs" assertCradle isMultiCradle step "Attempt to load symlinked module A"- inCradleRootDir $ do- loadComponentOptions "./a/A.hs"+ do+ loadComponentOptions "./a/A.hs" [] assertComponentOptions $ \opts -> componentOptions opts `shouldMatchList` ["a"] <> argDynamic @@ -86,22 +100,27 @@ initCradle "doesNotExist.hs" assertCradle isMultiCradle step "Attempt to load symlinked module A"- inCradleRootDir $ do- liftIO $ createDirectoryLink "./a" "./b"- liftIO $ unlessM (doesFileExist "./b/A.hs") $+ do+ cradle <- askCradle+ let rooted = (cradleRootDir cradle </>)+ liftIO $ createDirectoryLink (rooted "a") (rooted "./b")+ liftIO $ unlessM (doesFileExist $ rooted "b/A.hs") $ assertFailure "Test invariant broken, this file must exist."- loadComponentOptions "./b/A.hs"+ loadComponentOptions "./b/A.hs" [] assertComponentOptions $ \opts -> componentOptions opts `shouldMatchList` ["b"] <> argDynamic+ , biosTestCase "Can not load symlinked module that is ignored" $ runTestEnv "./symlink-test" $ do initCradle "doesNotExist.hs" assertCradle isMultiCradle step "Attempt to load symlinked module A"- inCradleRootDir $ do- liftIO $ createDirectoryLink "./a" "./c"- liftIO $ unlessM (doesFileExist "./c/A.hs") $+ do+ cradle <- askCradle+ let rooted = (cradleRootDir cradle </>)+ liftIO $ createDirectoryLink (rooted "./a") (rooted "./c")+ liftIO $ unlessM (doesFileExist $ rooted "c/A.hs") $ assertFailure "Test invariant broken, this file must exist."- loadComponentOptions "./c/A.hs"+ loadComponentOptions "./c/A.hs" [] assertLoadNone ] @@ -110,7 +129,7 @@ [ biosTestCase "failing-bios" $ runTestEnv "./failing-bios" $ do initCradle "B.hs" assertCradle isBiosCradle- loadComponentOptions "B.hs"+ loadComponentOptions "B.hs" [] assertCradleError $ \CradleError {..} -> do cradleErrorExitCode @?= ExitFailure 1 cradleErrorDependencies `shouldMatchList` ["hie.yaml"]@@ -123,7 +142,11 @@ cradleErrorExitCode @?= ExitSuccess cradleErrorDependencies `shouldMatchList` [] length cradleErrorStderr @?= 1- "Couldn't execute myGhc" `isPrefixOf` head cradleErrorStderr @? "Error message should contain basic information"+ forM_ cradleErrorStderr $ \errorCtx ->+ -- 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@@ -134,7 +157,7 @@ biosCradleDeps fp deps = do initCradle fp assertCradle isBiosCradle- loadComponentOptions fp+ loadComponentOptions fp [] assertComponentOptions $ \opts -> do deps @?= componentDependencies opts @@ -152,13 +175,13 @@ cabalTestCases :: ToolDependency -> [TestTree] cabalTestCases extraGhcDep = [- biosTestCase "failing-cabal" $ runTestEnv "./failing-cabal" $ do- cabalAttemptLoad "MyLib.hs"+ biosTestCaseAll "failing-cabal" $ runTestEnv "./failing-cabal" $ do+ attemptCabalSingleTargetLoad "MyLib.hs" assertCradleError (\CradleError {..} -> do cradleErrorExitCode @?= ExitFailure 1 cradleErrorDependencies `shouldMatchList` ["failing-cabal.cabal", "cabal.project", "cabal.project.local"])- , biosTestCase "failing-cabal-multi-repl-with-shrink-error-files" $ runTestEnv "./failing-multi-repl-cabal-project" $ do- cabalAttemptLoadFiles "multi-repl-cabal-fail/app/Main.hs" ["multi-repl-cabal-fail/src/Lib.hs", "multi-repl-cabal-fail/src/Fail.hs", "NotInPath.hs"]+ , biosTestCaseMulti "failing-cabal-multi-repl-with-shrink-error-files" $ runTestEnv "./failing-multi-repl-cabal-project" $ do+ attemptCabalLoad "multi-repl-cabal-fail/app/Main.hs" ["multi-repl-cabal-fail/src/Lib.hs", "multi-repl-cabal-fail/src/Fail.hs", "NotInPath.hs"] root <- askRoot multiSupported <- isCabalMultipleCompSupported' if multiSupported@@ -170,100 +193,256 @@ (makeRelative root <$> cradleErrorLoadingFiles) `shouldMatchList` ["multi-repl-cabal-fail/app/Main.hs","multi-repl-cabal-fail/src/Fail.hs","multi-repl-cabal-fail/src/Lib.hs"]) else assertLoadSuccess >>= \ComponentOptions {} -> do return ()- , biosTestCase "simple-cabal" $ runTestEnv "./simple-cabal" $ do+ , biosTestCaseAll "simple-cabal" $ runTestEnv "./simple-cabal" $ do testDirectoryM isCabalCradle "B.hs"- , biosTestCase "nested-cabal" $ runTestEnv "./nested-cabal" $ do- cabalAttemptLoad "sub-comp/Lib.hs"+ , biosTestCaseMulti "build-dir" $ runTestEnv "./simple-cabal" $ do+ initCradle "B.hs"+ assertCradle isCabalCradle+ root <- askRoot+ buildDir <- liftIO $ cabalBuildDir root+ -- use --multi-repl, as that was the codepath with the bug+ loadFileGhc "B.hs" []+ liftIO $ do+ -- Check we aren't trampling over dist-newstyle+ distNewstyleExists <- doesDirectoryExist (root </> "dist-newstyle")+ assertBool "dist-newstyle was created" (not distNewstyleExists)+ -- Check we are using the correct build directory+ buildDirExists <- doesDirectoryExist buildDir+ assertBool "build dir does not exist" buildDirExists+ , biosTestCaseAll "nested-cabal" $ runTestEnv "./nested-cabal" $ do+ attemptCabalSingleTargetLoad "sub-comp/Lib.hs"+ mode <- askLoadMode assertComponentOptions $ \opts -> do- componentDependencies opts `shouldMatchList`- [ "sub-comp" </> "sub-comp.cabal"- , "cabal.project"- , "cabal.project.local"- ]- , biosTestCase "nested-cabal2" $ runTestEnv "./nested-cabal" $ do- cabalAttemptLoad "MyLib.hs"+ let+ expectedDeps+ | mode `elem` [LoadUnitsFromCradle,LoadUnitsInferred]+ = [ "nested-cabal.cabal"+ , "sub-comp" </> "sub-comp.cabal"+ , "cabal.project"+ , "cabal.project.local"+ ]+ | otherwise =+ [ "sub-comp" </> "sub-comp.cabal"+ , "cabal.project"+ , "cabal.project.local"+ ]+ componentDependencies opts `shouldMatchList` expectedDeps+ , biosTestCaseAll "nested-cabal2" $ runTestEnv "./nested-cabal" $ do+ attemptCabalSingleTargetLoad "MyLib.hs"+ mode <- askLoadMode assertComponentOptions $ \opts -> do- componentDependencies opts `shouldMatchList`- [ "nested-cabal.cabal"- , "cabal.project"- , "cabal.project.local"- ]- , biosTestCase "multi-cabal" $ runTestEnv "./multi-cabal" $ do+ let+ expectedDeps+ | mode `elem` [LoadUnitsFromCradle,LoadUnitsInferred]+ = [ "nested-cabal.cabal"+ , "sub-comp" </> "sub-comp.cabal"+ , "cabal.project"+ , "cabal.project.local"+ ]+ | otherwise+ = [ "nested-cabal.cabal"+ , "cabal.project"+ , "cabal.project.local"+ ]+ componentDependencies opts `shouldMatchList` expectedDeps+ , biosTestCaseMulti "nested-cabal multi-mode includes enclosing deps for extra files" $ runTestEnv "./nested-cabal" $ do+ -- Initialize cradle first, since capability checks use the current cradle.+ initCradle "sub-comp/Lib.hs"+ assertCradle isCabalCradle+ multiSupported <- isCabalMultipleCompSupported'+ if multiSupported+ then do+ loadComponentOptions "sub-comp/Lib.hs" ["MyLib.hs"]+ assertComponentOptions $ \opts -> do+ -- Expect both the main component's cabal file and the enclosing cabal for the extra file,+ -- plus project files.+ componentDependencies opts `shouldMatchList`+ [ "sub-comp" </> "sub-comp.cabal"+ , "nested-cabal.cabal"+ , "cabal.project"+ , "cabal.project.local"+ ]+ else do+ -- On older cabal/ghc combos, multi-repl isn't supported; just ensure load succeeds.+ loadComponentOptions "sub-comp/Lib.hs" []+ _ <- assertLoadSuccess+ pure ()+ , biosTestCaseMulti "nested-cabal multi-mode includes enclosing deps when extra file is subcomp" $ runTestEnv "./nested-cabal" $ do+ -- Initialize cradle at the top level, then treat the sub-component file as an extra file.+ initCradle "MyLib.hs"+ assertCradle isCabalCradle+ multiSupported <- isCabalMultipleCompSupported'+ if multiSupported+ then do+ loadComponentOptions "MyLib.hs" ["sub-comp/Lib.hs"]+ assertComponentOptions $ \opts -> do+ componentDependencies opts `shouldMatchList`+ [ "nested-cabal.cabal"+ , "sub-comp" </> "sub-comp.cabal"+ , "cabal.project"+ , "cabal.project.local"+ ]+ else do+ loadComponentOptions "MyLib.hs" []+ _ <- assertLoadSuccess+ pure ()+ , biosTestCaseAll "multi-cabal" $ runTestEnv "./multi-cabal" $ do {- tests if both components can be loaded -} testDirectoryM isCabalCradle "app/Main.hs" testDirectoryM isCabalCradle "src/Lib.hs" , {- issue https://github.com/mpickering/hie-bios/issues/200 -}- biosTestCase "monorepo-cabal" $ runTestEnv "./monorepo-cabal" $ do+ biosTestCaseAll "monorepo-cabal" $ runTestEnv "./monorepo-cabal" $ do testDirectoryM isCabalCradle "A/Main.hs" testDirectoryM isCabalCradle "B/MyLib.hs" , testGroup "Implicit cradle tests" $- [ biosTestCase "implicit-cabal" $ runTestEnv "./implicit-cabal" $ do+ [ biosTestCaseAll "implicit-cabal" $ runTestEnv "./implicit-cabal" $ do testImplicitDirectoryM isCabalCradle "Main.hs"- , biosTestCase "implicit-cabal-no-project" $ runTestEnv "./implicit-cabal-no-project" $ do+ , biosTestCaseAll "implicit-cabal-no-project" $ runTestEnv "./implicit-cabal-no-project" $ do testImplicitDirectoryM isCabalCradle "Main.hs"- , biosTestCase "implicit-cabal-deep-project" $ runTestEnv "./implicit-cabal-deep-project" $ do+ , biosTestCaseAll "implicit-cabal-deep-project" $ runTestEnv "./implicit-cabal-deep-project" $ do testImplicitDirectoryM isCabalCradle "foo/Main.hs"+ , biosTestCase "implicit-cabal-deep-project-with-context" $ runTestModeEnv "./implicit-cabal-deep-project" LoadFileWithContext $ do+ testImplicitDirectoryWithContextM isCabalCradle "foo/Main.hs" ["Main.hs"] ] , testGroupWithDependency extraGhcDep- [ biosTestCase "Appropriate ghc and libdir" $ runTestEnvLocal "./cabal-with-ghc" $ do+ [ biosTestCaseAll "Appropriate ghc and libdir" $ runTestEnv "./cabal-with-ghc" $ do initCradle "src/MyLib.hs" assertCradle isCabalCradle loadRuntimeGhcLibDir 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- opts <- cabalLoadOptions "src/MyLib.hs"- liftIO $ do- "-O2" `elem` componentOptions opts- @? "Options must contain '-O2'"- , biosTestCase "cabal-with-project, load" $ runTestEnv "cabal-with-project" $ do+ [ biosTestCaseAll "cabal-with-project, options propagated" $ runTestEnv "cabal-with-project" $ do+ _opts <- cabalLoadOptions "src/MyLib.hs"+ assertOptionsContain "-O2" Nothing+ , biosTestCaseAll "cabal-with-project, load" $ runTestEnv "cabal-with-project" $ do testDirectoryM isCabalCradle "src/MyLib.hs"- , biosTestCase "multi-cabal-with-project, options propagated" $ runTestEnv "multi-cabal-with-project" $ do- optsAppA <- cabalLoadOptions "appA/src/Lib.hs"- liftIO $ do- "-O2" `elem` componentOptions optsAppA- @? "Options must contain '-O2'"- optsAppB <- cabalLoadOptions "appB/src/Lib.hs"- liftIO $ do- "-O2" `notElem` componentOptions optsAppB- @? "Options must not contain '-O2'"- , biosTestCase "multi-cabal-with-project, load" $ runTestEnv "multi-cabal-with-project" $ do+ , biosTestCaseAll "multi-cabal-with-project, options propagated" $ runTestEnv "multi-cabal-with-project" $ do+ _optsAppA <- cabalLoadOptions "appA/src/Lib.hs"+ assertOptionsContain "-O2" (Just "appA")+ , biosTestCaseAll "multi-cabal-with-project, options not propagated" $ runTestEnv "multi-cabal-with-project" $ do+ _optsAppB <- cabalLoadOptions "appB/src/Lib.hs"+ assertOptionsDoNotContain "-O2" (Just "appB")+ , biosTestCaseAll "multi-cabal-with-project, load" $ runTestEnv "multi-cabal-with-project" $ do testDirectoryM isCabalCradle "appB/src/Lib.hs" testDirectoryM isCabalCradle "appB/src/Lib.hs" , testGroupWithDependency extraGhcDep- [ biosTestCase "Honours extra ghc setting" $ runTestEnv "cabal-with-ghc-and-project" $ do+ [ biosTestCaseAll "Honours extra ghc setting" $ runTestEnv "cabal-with-ghc-and-project" $ do initCradle "src/MyLib.hs" assertCradle isCabalCradle loadRuntimeGhcLibDir assertLibDirVersionIs extraGhcVersion loadRuntimeGhcVersion assertGhcVersionIs extraGhcVersion+ step "Find Component Options"+ loadComponentOptions "src/MyLib.hs" []+ _ <- assertLoadSuccess+ pure () ]+ , biosTestCaseAll "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"+ , biosTestCaseMulti "force older Cabal version in custom setup with multi mode" $ 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.+ let target = "src/MyLib.hs"+ initCradle target+ assertCradle isCabalCradle+ loadRuntimeGhcLibDir+ assertLibDirVersion+ loadRuntimeGhcVersion+ assertGhcVersion+ -- suffices to force loading cabal's `--enable-multi-repl` codepath+ loadFileGhc target []+ , biosTestCase "multi-cabal-with-load" $ runTestModeEnv "multi-cabal-with-load" LoadUnitsFromCradle $ do+ opts <- componentOptions <$> cabalLoadOptions "appA/src/Lib.hs"+ liftIO $ do+ unless (any ("appA" `isInfixOf`) opts) $+ assertFailure $ "Missing appA: " ++ unwords opts+ unless (all (not . ("appB" `isInfixOf`)) opts) $+ assertFailure $ "Included appB: " ++ unwords opts+ , biosTestCase "multi-cabal-with-load-inferred" $ runTestModeEnv "multi-cabal-with-load" LoadUnitsInferred $ do+ -- LoadUnitsInferred should be unaffected by componentsToLoad+ opts <- componentOptions <$> cabalLoadOptions "appA/src/Lib.hs"+ liftIO $ do+ unless (any ("appA" `isInfixOf`) opts) $+ assertFailure $ "Missing appA: " ++ unwords opts+ unless (any ("appB" `isInfixOf`) opts) $+ assertFailure $ "Missing appB: " ++ unwords opts+ , biosTestCase "cabal-with-load" $ runTestModeEnv "cabal-with-load" LoadUnitsFromCradle $ do+ opts <- componentOptions <$> cabalLoadOptions "appA/src/Lib.hs"+ liftIO $ do+ unless (any ("appA" `isInfixOf`) opts) $+ assertFailure $ "Missing appA: " ++ unwords opts+ unless (all (not . ("appB" `isInfixOf`)) opts) $+ assertFailure $ "Included appB: " ++ unwords opts+ , biosTestCase "multi-cabal-with-load-superset" $ runTestModeEnv "multi-cabal-with-load-superset" LoadUnitsFromCradle $ do+ opts <- componentOptions <$> cabalLoadOptions "appA/src/Lib.hs"+ liftIO $ do+ unless (any ("appA" `isInfixOf`) opts) $+ assertFailure $ "Missing appA: " ++ unwords opts+ unless (any ("appB" `isInfixOf`) opts) $+ assertFailure $ "Missing appB: " ++ unwords opts ] ] where- cabalAttemptLoad :: FilePath -> TestM ()- cabalAttemptLoad fp = do- initCradle fp- assertCradle isCabalCradle- loadComponentOptions fp+ attemptCabalSingleTargetLoad fp = attemptCabalLoad fp [] - cabalAttemptLoadFiles :: FilePath -> [FilePath] -> TestM ()- cabalAttemptLoadFiles fp fps = do+ attemptCabalLoad :: FilePath -> [FilePath] -> TestM ()+ attemptCabalLoad fp fps = do initCradle fp assertCradle isCabalCradle- loadComponentOptionsMultiStyle fp fps+ loadComponentOptions fp fps cabalLoadOptions :: FilePath -> TestM ComponentOptions cabalLoadOptions fp = do initCradle fp assertCradle isCabalCradle- loadComponentOptions fp+ loadComponentOptions fp [] assertLoadSuccess +assertOptionsContain :: [Char] -> Maybe String -> TestM ()+assertOptionsContain flag munit = do+ doesContain <- hasOption flag munit+ liftIO $ doesContain @? ("Options must contain '" ++ flag ++ "'")++assertOptionsDoNotContain :: [Char] -> Maybe String -> TestM ()+assertOptionsDoNotContain flag munit = do+ doesContain <- hasOption flag munit+ liftIO $ not doesContain @? ("Options must not contain '" ++ flag ++ "'")++hasOption :: [Char] -> Maybe String -> TestM Bool+hasOption flag munit = elem flag <$> do+ options <- componentOptions <$> assertLoadSuccess+ mode <- askLoadMode+ let+ common | Nothing <- munit = do+ expandGhcOptionResponseFile options+ | Just unit <- munit = do+ let (units, rest) = extractUnits options+ fmap (concat . (rest:)) . forM units $ \ resp_file -> do+ unit_flags <- expandGhcOptionResponseFile [resp_file]+ if and [ unit `isInfixOf` uid | ("-this-unit-id":uid:_) <- tails unit_flags+ ]+ then pure unit_flags+ else pure []+ liftIO $ case mode of+ LoadFile -> return options+ LoadFileWithContext -> expandGhcOptionResponseFile options+ LoadUnitsFromCradle -> common+ LoadUnitsInferred -> common+ stackTestCases :: [TestTree] stackTestCases = [ expectFailBecause "stack repl does not fail on an invalid cabal file" $@@ -277,6 +456,8 @@ , biosTestCase "multi-stack" $ runTestEnv "./multi-stack" $ do {- tests if both components can be loaded -} testDirectoryM isStackCradle "app/Main.hs" testDirectoryM isStackCradle "src/Lib.hs"+ , biosTestCaseMulti "multi-stack-multi-modes" $ runTestEnv "./multi-stack" $ do+ testDirectoryM isStackCradle "app/Main.hs" , biosTestCase "nested-stack" $ runTestEnv "./nested-stack" $ do stackAttemptLoad "sub-comp/Lib.hs" assertComponentOptions $ \opts ->@@ -293,6 +474,22 @@ {- tests if both components can be loaded -} testDirectoryM isStackCradle "appA/src/Lib.hs" testDirectoryM isStackCradle "appB/src/Lib.hs"+ , biosTestCase "multi-stack-with-load" $ runTestModeEnv "multi-stack-with-load" LoadUnitsFromCradle $ do+ testDirectoryM isStackCradle "appA/src/LibA.hs"+ assertComponentOptions $ \ opts0 -> do+ let opts = componentOptions opts0+ unless (any ("appA" `isInfixOf`) opts) $+ assertFailure $ "Missing appA: " ++ unwords opts+ unless (all (not . ("appB" `isInfixOf`)) opts) $+ assertFailure $ "Included appB: " ++ unwords opts+ , biosTestCase "multi-stack-with-load-inferred" $ runTestModeEnv "multi-stack-with-load" LoadUnitsInferred $ do+ testDirectoryM isStackCradle "appA/src/LibA.hs"+ assertComponentOptions $ \ opts0 -> do+ let opts = componentOptions opts0+ unless (any ("appA" `isInfixOf`) opts) $+ assertFailure $ "Missing appA: " ++ unwords opts+ unless (any ("appB" `isInfixOf`) opts) $+ assertFailure $ "Missing appB: " ++ unwords opts , -- Test for special characters in the path for parsing of the ghci-scripts. -- Issue https://github.com/mpickering/hie-bios/issues/162@@ -300,11 +497,11 @@ testDirectoryM isStackCradle "A.hs" testDirectoryM isStackCradle "B.hs" , testGroup "Implicit cradle tests"- [ biosTestCase "implicit-stack" $ runTestEnv "./implicit-stack" $+ [ biosTestCase "implicit-stack" $ runTestModeEnv "./implicit-stack" LoadFile $ do testImplicitDirectoryM isStackCradle "Main.hs"- , biosTestCase "implicit-stack-multi" $ runTestEnv "./implicit-stack-multi" $ do+ , biosTestCase "implicit-stack-multi" $ runTestModeEnv "./implicit-stack-multi" LoadFile $ do testImplicitDirectoryM isStackCradle "Main.hs"- testImplicitDirectoryM isStackCradle "other-package/Main.hs"+ testImplicitDirectoryM isStackCradle "other-package/Main.hs" ] ] where@@ -312,7 +509,7 @@ stackAttemptLoad fp = do initCradle fp assertCradle isStackCradle- loadComponentOptions fp+ loadComponentOptions fp [] directTestCases :: [TestTree] directTestCases =@@ -353,12 +550,27 @@ infix 1 `shouldMatchList` -biosTestCase :: TestName -> (Bool -> Assertion) -> TestTree+biosTestCase :: TestName -> (TestConfig -> Assertion) -> TestTree biosTestCase name assertion = askOption @VerboseLogging (\case- VerboseLogging verbose -> testCase name (assertion verbose)+ VerboseLogging verbose ->+ testCaseSteps name (\ stepF -> testWrapper verbose stepF) )+ where+ testWrapper verbose stepF =+ assertion defConfig{testVerbose=verbose,testStepFunction=stepF} +biosTestCaseMulti :: TestName -> (TestConfig -> Assertion) -> TestTree+biosTestCaseMulti name act = testGroup name $ biosTestsForAllModes [LoadFileWithContext .. ] act +biosTestCaseAll :: TestName -> (TestConfig -> Assertion) -> TestTree+biosTestCaseAll name act = testGroup name $ biosTestsForAllModes [minBound .. ] act++biosTestsForAllModes :: [LoadMode] -> (TestConfig -> Assertion) -> [TestTree]+biosTestsForAllModes modes assertion =+ [ biosTestCase (show mode) (\ conf -> assertion (conf{testLoadModeConfig=mode}))+ | mode <- modes+ ]+ -- ------------------------------------------------------------------ -- Stack related helper functions -- ------------------------------------------------------------------@@ -380,6 +592,7 @@ , ("tests" </> "projects" </> "implicit-stack-multi", "stack.yaml", ["."]) , ("tests" </> "projects" </> "multi-stack-with-yaml", "stack-alt.yaml", ["appA", "appB"]) , ("tests" </> "projects" </> "stack-with-yaml", "stack-alt.yaml", ["."])+ , ("tests" </> "projects" </> "multi-stack-with-load", "stack.yaml", ["appA", "appB"]) ] stackYaml :: String -> [FilePath] -> String@@ -389,12 +602,14 @@ stackYamlResolver :: String stackYamlResolver =-#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,10,0,0)))- "nightly-2025-04-24" -- GHC 9.10.1+#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,12,0,0)))+ "nightly-2025-08-07" -- GHC 9.12.2+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,10,0,0)))+ "lts-24.3" -- GHC 9.10.2 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,8,0,0))) "lts-23.19" -- GHC 9.8.4 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)))- "lts-22.43" -- GHC 9.6.6+ "lts-22.44" -- GHC 9.6.7 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,4,0,0))) "lts-21.25" -- GHC 9.4.8 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)))@@ -444,7 +659,7 @@ -- | This option, when set to 'True', specifies that we should run in the -- «list tests» mode newtype IgnoreToolDeps = IgnoreToolDeps Bool- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance Tasty.IsOption IgnoreToolDeps where defaultValue = IgnoreToolDeps False@@ -473,13 +688,12 @@ \_opts _tree -> Nothing -- --------------------------------------------------------------------- Ignore test group if built with GHC 9.6.7 and GHC 9.12.2+-- Ignore test group if not supported by any stackage snapshot -- ------------------------------------------------------------------ ignoreOnUnsupportedGhc :: TestTree -> TestTree ignoreOnUnsupportedGhc tt =-#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,6,7,0) && !MIN_VERSION_GLASGOW_HASKELL(9,6,8,0)) || (MIN_VERSION_GLASGOW_HASKELL(9,12,2,0) && !MIN_VERSION_GLASGOW_HASKELL(9,12,3,0)))- ignoreTestBecause "Not supported on 9.6.7 and 9.12.2"+#if (defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,14,0,0))+ ignoreTestBecause "Not supported on GHC 9.14" #endif- tt-+ tt
tests/ParserTests.hs view
@@ -25,76 +25,90 @@ 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))- ,("./test", CradleConfig [] (Cabal $ CabalType (Just "test") Nothing))]))+ testGroup "Parser Tests"+ [ assertParser "cabal-1.yaml" (noDeps (Cabal $ CabalType (Just "lib:hie-bios") Nothing Nothing))+ , assertParser "stack-config.yaml" (noDeps (Stack $ StackType Nothing 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 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 Nothing))+ ,("./test", CradleConfig [] (Cabal $ CabalType (Just "test") 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 "cabal-multi.yaml" (noDeps (CabalMulti (CabalType Nothing Nothing Nothing)+ [("./src", CabalType (Just "lib:hie-bios") Nothing Nothing)+ ,("./", CabalType (Just "lib:hie-bios") 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 "stack-multi.yaml" (noDeps (StackMulti (StackType Nothing Nothing Nothing)+ [("./src", StackType (Just "lib:hie-bios") Nothing Nothing)+ ,("./", StackType (Just"lib:hie-bios") Nothing 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)]))]))+ CabalMulti (CabalType Nothing Nothing Nothing)+ [("./src", CabalType (Just "lib:hie-bios") Nothing Nothing)+ ,("./tests", CabalType (Just "parser-tests") Nothing 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)]))]))+ StackMulti (StackType Nothing Nothing Nothing)+ [("./src", StackType (Just "lib:hie-bios") Nothing Nothing)+ ,("./tests", StackType (Just "parser-tests") Nothing 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"))- [("./src", CabalType (Just "lib:hie-bios") Nothing)- ,("./vendor", CabalType (Just "parser-tests") Nothing)]))+ , assertParser "cabal-with-project.yaml"+ (noDeps (Cabal $ CabalType Nothing (Just "cabal.project.extra") Nothing))+ , assertParser "cabal-with-both.yaml"+ (noDeps (Cabal $ CabalType (Just "hie-bios:hie") (Just "cabal.project.extra") Nothing))+ , assertParser "multi-cabal-with-project.yaml"+ (noDeps (CabalMulti (CabalType Nothing (Just "cabal.project.extra") Nothing)+ [("./src", CabalType (Just "lib:hie-bios") Nothing Nothing)+ ,("./vendor", CabalType (Just "parser-tests") Nothing Nothing)]))+ , assertParser "multi-cabal-with-load.yaml"+ (noDeps (CabalMulti (CabalType Nothing (Just "cabal.project.extra") (Just ["lib:hie-bios","parser-tests","some-other"]))+ [("./src", CabalType (Just "lib:hie-bios") Nothing Nothing)+ ,("./vendor", CabalType (Just "parser-tests") Nothing Nothing)]))+ , assertParser "cabal-with-load.yaml"+ (noDeps (Cabal (CabalType Nothing Nothing (Just ["lib:hie-bios","parser-tests","some-other"])))) -- Assertions for stack.yaml files- assertParser "stack-with-yaml.yaml"- (noDeps (Stack $ StackType Nothing (Just "stack-8.8.3.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"- (noDeps (StackMulti (StackType Nothing (Just "stack-8.8.3.yaml"))- [("./src", StackType (Just "lib:hie-bios") Nothing)- ,("./vendor", StackType (Just "parser-tests") Nothing)]))+ , assertParser "stack-with-yaml.yaml"+ (noDeps (Stack $ StackType Nothing (Just "stack-8.8.3.yaml") Nothing))+ , assertParser "stack-with-both.yaml"+ (noDeps (Stack $ StackType (Just "hie-bios:hie") (Just "stack-8.8.3.yaml") Nothing))+ , assertParser "multi-stack-with-yaml.yaml"+ (noDeps (StackMulti (StackType Nothing (Just "stack-8.8.3.yaml") Nothing)+ [("./src", StackType (Just "lib:hie-bios") Nothing Nothing)+ ,("./vendor", StackType (Just "parser-tests") Nothing 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))+ , ("./test", CradleConfig [] (Cabal $ CabalType (Just "test") Nothing 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 Nothing))+ , assertParserFails "single-components.yaml" aesonException+ , assertParser "multi-stack-with-load.yaml"+ (noDeps (StackMulti (StackType Nothing (Just "stack.extra.yaml") (Just ["lib:hie-bios","parser-tests","some-other"]))+ [("./src", StackType (Just "lib:hie-bios") Nothing Nothing)+ ,("./vendor", StackType (Just "parser-tests") Nothing Nothing)]))+ , assertParser "stack-with-load.yaml"+ (noDeps (Stack (StackType Nothing Nothing (Just ["lib:hie-bios","parser-tests","some-other"]))))+ ] -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 +118,15 @@ invalidYamlException (InvalidYaml (Just _)) = True invalidYamlException _ = False -assertParserFails :: Exception e => FilePath -> Selector e -> Assertion-assertParserFails fp es = (readConfig (configDir </> fp) :: IO (Config Void)) `shouldThrow` es+aesonException :: Selector ParseException+aesonException (AesonException _) = True+aesonException _ = False -assertCustomParser :: FilePath -> Config CabalHelper -> Assertion-assertCustomParser fp cc = do+assertParserFails :: Exception e => FilePath -> Selector e -> TestTree+assertParserFails fp es = testCase fp $ (readConfig (configDir </> fp) :: IO (Config Void)) `shouldThrow` es++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
@@ -12,6 +12,7 @@ -- * Run Tests runTestEnv,+ runTestModeEnv, runTestEnv', runTestEnvLocal, @@ -28,6 +29,7 @@ askStep, askLogger, askCradle,+ askLoadMode, askLoadResult, askOrLoadLibDir, askLibDir,@@ -43,10 +45,8 @@ initCradle, initImplicitCradle, loadComponentOptions,- loadComponentOptionsMultiStyle, loadRuntimeGhcLibDir, loadRuntimeGhcVersion,- inCradleRootDir, loadFileGhc, isCabalMultipleCompSupported', @@ -67,6 +67,7 @@ -- * High-level test helpers testDirectoryM, testImplicitDirectoryM,+ testImplicitDirectoryWithContextM, findCradleForModuleM, ) where @@ -78,6 +79,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@@ -92,6 +95,8 @@ import Colog.Core import qualified Data.Text as Text import Data.Function ((&))+import qualified Control.Exception as C+import System.Environment (lookupEnv) -- --------------------------------------------------------------------------- -- Test configuration and information@@ -103,8 +108,9 @@ { useTemporaryDirectory :: Bool , testProjectRoots :: FilePath , testVerbose :: Bool+ , testStepFunction :: String -> IO ()+ , testLoadModeConfig :: LoadMode }- deriving (Eq, Show, Ord) data TestEnv ext = TestEnv { testCradleType :: Maybe (Cradle ext)@@ -113,26 +119,39 @@ , testGhcVersionResult :: Maybe (CradleLoadResult String) , testRootDir :: FilePath , testLogger :: L.LogAction IO (L.WithSeverity HIE.Log)+ , testLoadMode :: LoadMode } defConfig :: TestConfig-defConfig = TestConfig True "./tests/projects" False+defConfig =+ TestConfig+ { useTemporaryDirectory = True+ , testProjectRoots = "./tests/projects"+ , testVerbose = False+ , testStepFunction = unLogAction logStringStderr+ , testLoadModeConfig = LoadFile+ } -runTestEnv :: FilePath -> TestM a -> Bool -> IO a-runTestEnv fp act verbose = runTestEnv' defConfig{testVerbose=verbose} fp act+runTestEnv :: FilePath -> TestM a -> TestConfig -> IO a+runTestEnv fp act testConf = runTestEnv' testConf fp act -runTestEnvLocal :: FilePath -> TestM a -> Bool -> IO a-runTestEnvLocal fp act verbose = runTestEnv' defConfig{useTemporaryDirectory = False,testVerbose=verbose} fp act+runTestModeEnv :: FilePath -> LoadMode -> TestM a -> TestConfig -> IO a+runTestModeEnv fp loadMode act testConf = runTestEnv' testConf{testLoadModeConfig=loadMode} fp act +runTestEnvLocal :: FilePath -> TestM a -> TestConfig -> IO a+runTestEnvLocal fp act testConf = runTestEnv' testConf{useTemporaryDirectory = False} fp act+ runTestEnv' :: TestConfig -> FilePath -> TestM a -> IO a runTestEnv' config root act = do -- We need to copy over the directory to somewhere outside the source tree -- when we test, since the cabal.project/stack.yaml/hie.yaml file in the root -- of this repository interferes with the test cradles!- let wrapper =+ let wrapper r cont = if useTemporaryDirectory config- then withTempCopy- else \r cont -> cont r+ then do+ mkeep <- lookupEnv "KEEP_TEMP_DIRS"+ withTempCopy (mkeep == Just "true") r cont+ else cont r mkEnv root' = TestEnv { testCradleType = Nothing@@ -141,13 +160,14 @@ , testGhcVersionResult = Nothing , testRootDir = root' , testLogger = init_logger+ , testLoadMode = testLoadModeConfig config }- realRoot = testProjectRoots config </> root+ realRoot <- makeAbsolute $ testProjectRoots config </> root wrapper realRoot $ \root' -> flip evalStateT (mkEnv root') $ do step $ "Run test in: " <> root' act where- init_logger = L.logStringStderr+ init_logger = LogAction (testStepFunction config) & L.cmap printLog & L.filterBySeverity (if testVerbose config then Debug else Error) getSeverity printLog (L.WithSeverity l sev) = "[" ++ show sev ++ "] " ++ show (pretty l)@@ -243,6 +263,9 @@ askLogger :: TestM (L.LogAction IO (L.WithSeverity HIE.Log)) askLogger = gets testLogger +askLoadMode :: TestM LoadMode+askLoadMode = gets testLoadMode+ -- --------------------------------------------------------------------------- -- Test setup helpers -- ---------------------------------------------------------------------------@@ -274,6 +297,7 @@ crd <- case mcfg of Just cfg -> liftIO $ loadCradle logger cfg Nothing -> liftIO $ loadImplicitCradle logger a_fp+ step $ "Cradle: " ++ show crd setCradle crd initImplicitCradle :: FilePath -> TestM ()@@ -284,21 +308,16 @@ crd <- liftIO $ loadImplicitCradle logger a_fp setCradle crd -loadComponentOptions :: FilePath -> TestM ()-loadComponentOptions fp = do- a_fp <- normFile fp- crd <- askCradle- step $ "Initialise flags for: " <> fp- clr <- liftIO $ getCompilerOptions a_fp LoadFile crd- setLoadResult clr--loadComponentOptionsMultiStyle :: FilePath -> [FilePath] -> TestM ()-loadComponentOptionsMultiStyle fp fps = do+loadComponentOptions :: FilePath -> [FilePath] -> TestM ()+loadComponentOptions fp extraFps = do a_fp <- normFile fp- a_fps <- mapM normFile fps+ a_fps <- traverse normFile extraFps crd <- askCradle- step $ "Initialise flags for: " <> fp <> " and " <> show fps- clr <- liftIO $ getCompilerOptions a_fp (LoadWithContext a_fps) crd+ mode <- askLoadMode+ step $ "Initialise flags for " <> fp <> " using " <> show mode+ when (not $ null extraFps) $ do+ step $ "Provided context: " <> show extraFps+ clr <- liftIO $ getCompilerOptions (TargetWithContext a_fp a_fps) mode crd setLoadResult clr loadRuntimeGhcLibDir :: TestM ()@@ -322,26 +341,17 @@ versions <- liftIO $ makeVersions (cradleLogger cr) root ((runGhcCmd . cradleOptsProg) cr) liftIO $ isCabalMultipleCompSupported versions -inCradleRootDir :: TestM a -> TestM a-inCradleRootDir act = do- crd <- askCradle- prev <- liftIO getCurrentDirectory- liftIO $ setCurrentDirectory (cradleRootDir crd)- a <- act- liftIO $ setCurrentDirectory prev- pure a--loadFileGhc :: FilePath -> TestM ()-loadFileGhc fp = do+loadFileGhc :: FilePath -> [FilePath] -> TestM ()+loadFileGhc fp extraFps = do libdir <- askOrLoadLibDir a_fp <- normFile fp stepF <- askStep step "Cradle load"- loadComponentOptions fp+ loadComponentOptions fp extraFps opts <- assertLoadSuccess liftIO $ G.runGhc (Just libdir) $ do- let (ini, _) = initSessionWithMessage (Just G.batchMsg) opts+ let (ini, _) = initSessionWithMessage' True (Just G.batchMsg) opts sf <- ini case sf of -- Test resetting the targets@@ -433,17 +443,20 @@ assertLibDirVersion loadRuntimeGhcVersion assertGhcVersion- loadFileGhc file+ loadFileGhc file [] testImplicitDirectoryM :: (Cradle Void -> Bool) -> FilePath -> TestM ()-testImplicitDirectoryM cradlePred file = do+testImplicitDirectoryM cradlePred file = testImplicitDirectoryWithContextM cradlePred file []++testImplicitDirectoryWithContextM :: (Cradle Void -> Bool) -> FilePath -> [FilePath] -> TestM ()+testImplicitDirectoryWithContextM cradlePred file ctxt = do initImplicitCradle file assertCradle cradlePred loadRuntimeGhcLibDir assertLibDirVersion loadRuntimeGhcVersion assertGhcVersion- loadFileGhc file+ loadFileGhc file ctxt findCradleForModuleM :: FilePath -> Maybe FilePath -> TestM () findCradleForModuleM fp expected' = do@@ -456,13 +469,21 @@ -- Copy Directory system utilities -- --------------------------------------------------------------------------- -withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a-withTempCopy srcDir f =- withSystemTempDirectory "hie-bios-test" $ \newDir -> do- exists <- doesDirectoryExist srcDir- when exists $ do- copyDir srcDir newDir- f newDir+withTempCopy :: Bool -> FilePath -> (FilePath -> IO a) -> IO a+withTempCopy keep srcDir f = getCanonicalTemporaryDirectory >>= \targetDir -> do+ C.bracket+ (liftIO (createTempDirectory targetDir template))+ cleanup $ \newDir -> do+ exists <- doesDirectoryExist srcDir+ when exists $ do+ copyDir srcDir newDir+ f newDir+ where+ template = "hie-bios-test"+ cleanup dir | keep = return ()+ | otherwise = (liftIO . ignoringIOErrors . removeDirectoryRecursive) dir+ ignoringIOErrors ioe = ioe `C.catch` (\e -> const (return ()) (e :: IOError))+ copyDir :: FilePath -> FilePath -> IO () copyDir src dst = do
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-load.yaml view
@@ -0,0 +1,3 @@+cradle:+ cabal:+ componentsToLoad: ["lib:hie-bios","parser-tests","some-other"]
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-load.yaml view
@@ -0,0 +1,9 @@+cradle:+ cabal:+ componentsToLoad: ["lib:hie-bios","parser-tests","some-other"]+ cabalProject: "cabal.project.extra"+ components:+ - path: "./src"+ component: "lib:hie-bios"+ - path: "./vendor"+ component: "parser-tests"
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/configs/multi-stack-with-load.yaml view
@@ -0,0 +1,9 @@+cradle:+ stack:+ componentsToLoad: ["lib:hie-bios","parser-tests","some-other"]+ stackYaml: "stack.extra.yaml"+ components:+ - path: "./src"+ component: "lib:hie-bios"+ - path: "./vendor"+ component: "parser-tests"
+ tests/configs/single-components.yaml view
@@ -0,0 +1,2 @@+cabal:+ components: "exe:t3"
+ tests/configs/stack-with-load.yaml view
@@ -0,0 +1,3 @@+cradle:+ stack:+ componentsToLoad: ["lib:hie-bios","parser-tests","some-other"]
− 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
tests/projects/multi-cabal/multi-cabal.cabal view
@@ -1,4 +1,4 @@-cabal-version: >=2.0+cabal-version: 2.0 name: multi-cabal version: 0.1.0.0 build-type: Simple
+ 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