hie-bios 0.19.0 → 0.21.0
raw patch · 41 files changed
Files
- ChangeLog.md +20/−0
- README.md +39/−0
- exe/Main.hs +21/−15
- hie-bios.cabal +267/−241
- src/HIE/Bios.hs +4/−0
- src/HIE/Bios/Config.hs +36/−21
- src/HIE/Bios/Config/YAML.hs +20/−13
- src/HIE/Bios/Cradle.hs +127/−68
- src/HIE/Bios/Cradle/Cabal.hs +269/−98
- src/HIE/Bios/Cradle/Resolved.hs +5/−3
- src/HIE/Bios/Cradle/Utils.hs +2/−31
- src/HIE/Bios/Environment.hs +96/−26
- src/HIE/Bios/Flags.hs +5/−7
- src/HIE/Bios/Ghc/Api.hs +7/−5
- src/HIE/Bios/Ghc/Gap.hs +141/−1
- src/HIE/Bios/Ghc/Load.hs +1/−1
- src/HIE/Bios/Internal/Debug.hs +5/−4
- src/HIE/Bios/Process.hs +17/−6
- src/HIE/Bios/Types.hs +70/−19
- tests/BiosTests.hs +338/−152
- tests/ParserTests.hs +46/−29
- tests/Utils.hs +94/−70
- tests/configs/cabal-with-load.yaml +3/−0
- tests/configs/multi-cabal-with-load.yaml +9/−0
- 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-custom-setup-old/a-with-custom/Setup.hs +2/−0
- tests/projects/cabal-with-custom-setup-old/a-with-custom/a-with-custom.cabal +15/−0
- tests/projects/cabal-with-custom-setup-old/a-with-custom/src/MyLib.hs +4/−0
- tests/projects/cabal-with-custom-setup-old/b/b.cabal +30/−0
- tests/projects/cabal-with-custom-setup-old/b/src/B.hs +6/−0
- tests/projects/cabal-with-custom-setup-old/b/tests/Main.hs +3/−0
- tests/projects/cabal-with-custom-setup-old/cabal.project +5/−0
- tests/projects/cabal-with-custom-setup/a-with-custom/Setup.hs +2/−0
- tests/projects/cabal-with-custom-setup/a-with-custom/a-with-custom.cabal +15/−0
- tests/projects/cabal-with-custom-setup/a-with-custom/src/MyLib.hs +4/−0
- tests/projects/cabal-with-custom-setup/b/b.cabal +24/−0
- tests/projects/cabal-with-custom-setup/b/src/B.hs +6/−0
- tests/projects/cabal-with-custom-setup/cabal.project +5/−0
- tests/projects/multi-cabal/multi-cabal.cabal +1/−1
ChangeLog.md view
@@ -1,5 +1,25 @@ # ChangeLog hie-bios +## 2026-07-30 - 0.21.0++* Add a CI timeout on tests ([#521](https://github.com/haskell/hie-bios/pull/521)).+* Consistently pass '--keep-temp-files' ([#519](https://github.com/haskell/hie-bios/pull/519)).+* Make cacheFile thread-safe using file locks ([#520](https://github.com/haskell/hie-bios/pull/520)).+* Make functions take the used cache directory explicitly ([#520](https://github.com/haskell/hie-bios/pull/520)).+ * Add *WithConfig functions.+ * Adjust existing functions to take a cache directory.+ * Replace thread-unsafety workaround of initSession' and+ initSessionWithMessage' with the cache directory argument.++## 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))
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
@@ -16,7 +16,7 @@ import HIE.Bios.Ghc.Check import HIE.Bios.Ghc.Gap as Gap import HIE.Bios.Internal.Debug-import HIE.Bios.Types (LoadStyle(..))+import HIE.Bios.Types (LoadMode(..), TargetWithContext (..), singleTarget) import Paths_hie_bios import Data.Void (Void) import Data.Function@@ -26,9 +26,11 @@ progVersion :: String progVersion = "hie-bios version " ++ showVersion version ++ " compiled by GHC " ++ Gap.ghcVersion ++ "\n" -data UseLoadStyle+data UseLoadMode = UseSingleFile | UseMultiFile+ | UseUnitsInferred+ | UseUnitsFromCradle data Cli = Cli { logLevel :: Maybe L.Severity@@ -38,7 +40,7 @@ data Command = Check { checkTargetFiles :: [FilePath] } | Flags { flagTargetFiles :: [FilePath] }- | Debug { debugUseMultiLoadStyle :: UseLoadStyle, debugComponents :: [FilePath] }+ | Debug { debugUseMultiLoadMode :: UseLoadMode, debugComponents :: [FilePath] } | ConfigInfo { configFiles :: [FilePath] } | CradleInfo { cradleFiles :: [FilePath] } | Root@@ -69,16 +71,18 @@ 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 <$> loadStyleParser <*> many 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.")) ) -loadStyleParser :: Parser UseLoadStyle-loadStyleParser =+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") ---------------------------------------------------------------- @@ -112,7 +116,7 @@ [] -> 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 \""@@ -130,15 +134,17 @@ Version -> return progVersion putStr res -debugFiles :: [FilePath] -> UseLoadStyle -> Cradle Void -> IO String-debugFiles fps useLoadStyle cradle = case useLoadStyle of+debugFiles :: [FilePath] -> UseLoadMode -> Cradle Void -> IO String+debugFiles fps useLoadMode cradle = case useLoadMode of UseSingleFile -> debugSingle- UseMultiFile -> debugBulk+ UseMultiFile -> debugBulk LoadFileWithContext+ UseUnitsInferred -> debugBulk LoadUnitsInferred+ UseUnitsFromCradle -> debugBulk LoadUnitsFromCradle where debugSingle = case fps of- [] -> debugInfo (cradleRootDir cradle) LoadFile cradle- _ -> concat <$> traverse (\fp -> debugInfo fp LoadFile cradle) fps+ [] -> debugInfo (singleTarget $ cradleRootDir cradle) LoadFile cradle+ _ -> concat <$> traverse (\fp -> debugInfo (singleTarget fp) LoadFile cradle) fps - debugBulk = case fps of- [] -> debugInfo (cradleRootDir cradle) (LoadWithContext []) cradle- fp:otherFps -> debugInfo fp (LoadWithContext otherFps) cradle+ debugBulk mode = case fps of+ [] -> debugInfo (TargetWithContext (cradleRootDir cradle) []) mode cradle+ fp:otherFps -> debugInfo (TargetWithContext fp otherFps) mode cradle
hie-bios.cabal view
@@ -1,266 +1,292 @@-Cabal-Version: 2.2-Name: hie-bios-Version: 0.19.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--- No glob syntax until GHC 8.6 because of stack-extra-doc-files: ChangeLog.md-Extra-Source-Files: README.md- wrappers/cabal- wrappers/cabal-with-repl- wrappers/cabal.hs- wrappers/cabal-with-repl.hs- tests/configs/*.yaml- tests/projects/cabal-with-ghc/cabal-with-ghc.cabal- tests/projects/cabal-with-ghc/cabal.project- tests/projects/cabal-with-ghc/hie.yaml- tests/projects/cabal-with-ghc/src/MyLib.hs- tests/projects/cabal-with-ghc-and-project/cabal-with-ghc.cabal- tests/projects/cabal-with-ghc-and-project/cabal.project.extra- tests/projects/cabal-with-ghc-and-project/hie.yaml- tests/projects/cabal-with-ghc-and-project/src/MyLib.hs- tests/projects/cabal-with-project/cabal-with-project.cabal- tests/projects/cabal-with-project/cabal.project.extra- 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.extra- 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.21.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+ README.md+extra-source-files:+ tests/configs/*.yaml+ tests/projects/cabal-with-custom-setup-old/a-with-custom/a-with-custom.cabal+ tests/projects/cabal-with-custom-setup-old/a-with-custom/Setup.hs+ tests/projects/cabal-with-custom-setup-old/a-with-custom/src/MyLib.hs+ tests/projects/cabal-with-custom-setup-old/b/b.cabal+ tests/projects/cabal-with-custom-setup-old/b/src/B.hs+ tests/projects/cabal-with-custom-setup-old/b/tests/Main.hs+ tests/projects/cabal-with-custom-setup-old/cabal.project+ tests/projects/cabal-with-custom-setup/a-with-custom/a-with-custom.cabal+ tests/projects/cabal-with-custom-setup/a-with-custom/Setup.hs+ tests/projects/cabal-with-custom-setup/a-with-custom/src/MyLib.hs+ tests/projects/cabal-with-custom-setup/b/b.cabal+ tests/projects/cabal-with-custom-setup/b/src/B.hs+ tests/projects/cabal-with-custom-setup/cabal.project+ 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.6.7 || ==9.8.4 || ==9.10.1 || ==9.12.2 || ==9.14.1+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.Cradle.Cabal- HIE.Bios.Cradle.ProgramVersions- HIE.Bios.Cradle.ProjectConfig- HIE.Bios.Cradle.Resolved- HIE.Bios.Cradle.Utils- HIE.Bios.Environment- HIE.Bios.Internal.Debug- HIE.Bios.Flags- HIE.Bios.Process- HIE.Bios.Types- HIE.Bios.Ghc.Api- HIE.Bios.Ghc.Check- 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.16,- extra >= 1.6.14 && < 1.9,- prettyprinter ^>= 1.6 || ^>= 1.7.0,- ghc >= 9.2.1 && < 9.15,- transformers >= 0.5.2 && < 0.7,- temporary >= 1.2 && < 1.4,- template-haskell >= 2.18 && <2.25,- 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,+ filelock >=0.1.1 && <0.2,+ 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.17.1 && < 0.20- , 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+ async,+ base,+ co-log-core,+ directory,+ extra,+ filepath,+ ghc,+ hie-bios,+ prettyprinter,+ process,+ tasty,+ tasty-expected-failure,+ tasty-hunit,+ temporary,+ text,+ transformers, hs-source-dirs: tests/ main-is: BiosTests.hs other-modules: Utils+ ghc-options:+ -threaded+ -Wall - ghc-options: -threaded -Wall -- There seems to be a race condition on windows if !os(windows)- ghc-options: -rtsopts "-with-rtsopts=-N"+ ghc-options:+ -rtsopts+ -with-rtsopts=-N -Source-Repository head- Type: git- Location: https://github.com/haskell/hie-bios.git+source-repository head+ type: git+ location: https://github.com/haskell/hie-bios.git
src/HIE/Bios.hs view
@@ -14,7 +14,11 @@ , CradleError(..) , findCradle , loadCradle+ , loadCradleWithConfig , loadImplicitCradle+ , loadImplicitCradleWithConfig+ , CradleRunConfig(..)+ , defaultCradleRunConfig , defaultCradle -- * Compiler Options , ComponentOptions(..)
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
@@ -7,7 +7,11 @@ module HIE.Bios.Cradle ( findCradle , loadCradle+ , loadCradleWithConfig , loadImplicitCradle+ , loadImplicitCradleWithConfig+ , CradleRunConfig(..)+ , defaultCradleRunConfig , yamlConfig , defaultCradle , isCabalCradle@@ -19,6 +23,7 @@ , isDefaultCradle , isOtherCradle , getCradle+ , getCradleWithConfig , Process.readProcessWithOutputs , Process.readProcessWithCwd , makeCradleResult@@ -49,6 +54,7 @@ import System.IO.Temp import HIE.Bios.Config+import HIE.Bios.Environment (resolveCacheDir) import HIE.Bios.Types hiding (ActionName(..)) import qualified HIE.Bios.Process as Process import qualified HIE.Bios.Types as Types@@ -58,6 +64,7 @@ import HIE.Bios.Cradle.Cabal as Cabal import HIE.Bios.Cradle.Resolved import HIE.Bios.Cradle.ProgramVersions+import Data.List.Extra (nubOrd) ---------------------------------------------------------------- @@ -76,30 +83,45 @@ -- | Given root\/hie.yaml load the Cradle. loadCradle :: LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle Void)-loadCradle l = loadCradleWithOpts l absurd+loadCradle l = loadCradleWithConfig l defaultCradleRunConfig +-- | 'loadCradle' with an explicit 'CradleRunConfig'.+loadCradleWithConfig :: LogAction IO (WithSeverity Log) -> CradleRunConfig -> FilePath -> IO (Cradle Void)+loadCradleWithConfig l config = loadCradleWithOpts l config absurd+ -- | Given root\/foo\/bar.hs, load an implicit cradle loadImplicitCradle :: Show a => LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle a)-loadImplicitCradle l wfile = do+loadImplicitCradle l = loadImplicitCradleWithConfig l defaultCradleRunConfig++-- | 'loadImplicitCradle' with an explicit 'CradleRunConfig'.+loadImplicitCradleWithConfig :: Show a => LogAction IO (WithSeverity Log) -> CradleRunConfig -> FilePath -> IO (Cradle a)+loadImplicitCradleWithConfig l config wfile = do let wdir = takeDirectory wfile cfg <- runMaybeT (implicitConfig wdir) case cfg of- Just bc -> getCradle l absurd bc+ Just bc -> getCradleWithConfig l config absurd bc Nothing -> return $ defaultCradle l wdir -- | Finding 'Cradle'. -- Find a cabal file by tracing ancestor directories. -- Find a sandbox according to a cabal sandbox config -- in a cabal directory.-loadCradleWithOpts :: (Yaml.FromJSON b, Show a) => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> IO (Cradle a)-loadCradleWithOpts l buildCustomCradle wfile = do+loadCradleWithOpts :: (Yaml.FromJSON b, Show a) => LogAction IO (WithSeverity Log) -> CradleRunConfig -> (b -> CradleAction a) -> FilePath -> IO (Cradle a)+loadCradleWithOpts l config buildCustomCradle wfile = do cradleConfig <- readCradleConfig wfile- getCradle l buildCustomCradle (cradleConfig, takeDirectory wfile)+ l <& WithSeverity (LogAny $ T.pack $ "Cradle Config: " ++ show cradleConfig) Debug+ getCradleWithConfig l config 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+getCradle l = getCradleWithConfig l defaultCradleRunConfig++-- | 'getCradle' with an explicit 'CradleRunConfig'.+getCradleWithConfig :: Show a => LogAction IO (WithSeverity Log) -> CradleRunConfig -> (b -> CradleAction a) -> (CradleConfig b, FilePath) -> IO (Cradle a)+getCradleWithConfig l config buildCustomCradle (cc, wdir) = do rcs <- canonicalizeResolvedCradles wdir cs- resolvedCradlesToCradle l buildCustomCradle wdir rcs+ liftIO $ l <& WithSeverity (LogAny . T.pack $ "Resolved Cradles " ++ show ((fmap . fmap) (const ()) rcs)) Debug+ cacheDir <- resolveCacheDir "" (cradleCacheDir config)+ resolvedCradlesToCradle l buildCustomCradle wdir cacheDir rcs where cs = resolveCradleTree wdir cc @@ -111,8 +133,8 @@ (\(ComponentOptions os' dir ds) -> CradleSuccess (ComponentOptions os' dir (ds `union` deps))) -resolvedCradlesToCradle :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> [ResolvedCradle b] -> IO (Cradle a)-resolvedCradlesToCradle logger buildCustomCradle root cs = mdo+resolvedCradlesToCradle :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> CacheDir -> [ResolvedCradle b] -> IO (Cradle a)+resolvedCradlesToCradle logger buildCustomCradle root cacheDir cs = mdo let run_ghc_cmd args = -- We're being lazy here and just returning the ghc path for the -- first non-none cradle. This shouldn't matter in practice: all@@ -124,12 +146,13 @@ act args versions <- makeVersions logger root run_ghc_cmd- let rcs = ResolvedCradles root cs versions+ let rcs = ResolvedCradles root cs versions cacheDir 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@@ -137,12 +160,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 } }@@ -184,20 +207,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))+ 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]@@ -229,9 +252,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 @@ -357,7 +380,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 }@@ -379,11 +402,20 @@ biosWorkDir :: FilePath -> MaybeT IO FilePath biosWorkDir = Process.findFileUpwards ".hie-bios" -biosDepsAction :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe Callable -> FilePath -> LoadStyle -> IO [FilePath]-biosDepsAction l wdir (Just biosDepsCall) fp loadStyle = do- let fps = case loadStyle of- LoadFile -> [fp]- LoadWithContext old_fps -> fp : old_fps+-- | 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'@@ -398,37 +430,43 @@ -> Callable -> Maybe Callable -> LogAction IO (WithSeverity Log)- -> FilePath- -> LoadStyle+ -> TargetWithContext+ -> LoadMode -> IO (CradleLoadResult ComponentOptions)-biosAction rc wdir bios bios_deps l fp loadStyle = do+biosAction rc wdir bios bios_deps l fpc loadStyle = do+ let fp = targetFilePath fpc ghc_version <- liftIO $ runCachedIO $ ghcVersion $ cradleProgramVersions rc- determinedLoadStyle <- case ghc_version of- Just ghc- -- Multi-component supported from ghc 9.4- -- We trust the assertion for a bios program, as we have no way of- -- checking its version- | LoadWithContext _ <- loadStyle ->- if ghc >= makeVersion [9,4]- then pure loadStyle- else do- liftIO $ l <& WithSeverity- (LogLoadWithContextUnsupported "bios"- $ Just "ghc version is too old. We require `ghc >= 9.4`"- )- Warning- pure LoadFile- _ -> pure LoadFile- let fps = case determinedLoadStyle of- LoadFile -> [fp]- LoadWithContext old_fps -> fp : old_fps+ 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)]) <- 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.@@ -478,7 +516,7 @@ cabalCradle l cs wdir mc projectFile = CradleAction { actionName = Types.Cabal- , runCradle = \fp -> runCradleResultT . cabalAction cs wdir mc l projectFile fp+ , runCradle = \fpc -> runCradleResultT . cabalAction cs wdir mc l projectFile fpc , runGhcCmd = runCabalGhcCmd cs wdir l projectFile } @@ -499,11 +537,11 @@ -- | 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@@ -535,19 +573,40 @@ -> 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"+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 ghcProc workDir+ wrapper_fp <- withGhcWrapperTool l (cradleCacheDirResolved cs) 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)]) <- 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, _) <- Process.readProcessWithOutputs [hie_bios_output] l workDir@@ -682,12 +741,12 @@ 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
@@ -40,7 +40,6 @@ 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@@ -137,38 +136,32 @@ Maybe String -> LogAction IO (WithSeverity Log) -> CradleProjectConfig ->- FilePath ->- LoadStyle ->+ 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.- determinedLoadStyle <- case loadStyle of- LoadWithContext _ | not multiCompSupport -> do+ determinedLoadMode <- case loadStyle of+ LoadFile -> pure LoadFile+ -- all other modes need multi component support.+ _ | not multiCompSupport -> do liftIO $ l <& WithSeverity- ( LogLoadWithContextUnsupported "cabal" $+ ( 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) <- processCabalLoadStyle l cradles projectFile workDir mc fp determinedLoadStyle-- cabalFeatures <- determineCabalLoadFeature progVersions- let- -- Used for @cabal >= 3.15@ but @lib:Cabal <3.15@, in custom setups.- mkFallbackCabalProc = cabalLoadFilesBefore315 l progVersions projectFile workDir cabalArgs- cabalProc <- case cabalFeatures of- CabalWithRepl -> cabalLoadFilesWithRepl l projectFile workDir cabalArgs- CabalWithGhcShimWrapper -> cabalLoadFilesBefore315 l progVersions projectFile workDir cabalArgs+ (cabalArgs, loadingFiles, extraDeps) <- processCabalLoadMode l cradles progVersions projectFile workDir mc fp determinedLoadMode - mResult <- runCabalToGetGhcOptions cabalProc mkFallbackCabalProc+ mResult <- runCabalToGetGhcOptions progVersions cabalArgs case mResult of- Left (code, errorDetails) -> do+ Left (cabalProc, 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.@@ -196,10 +189,9 @@ } 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+ final_args <- case loadModeUsesResponseFiles cabalArgs of+ UsesResponseFiles -> liftIO $ expandGhcOptionResponseFile ghc_args+ NoResponseFiles -> pure ghc_args CradleLoadResultT $ pure $ CradleSuccess ComponentOptions { componentOptions = final_args@@ -207,19 +199,67 @@ , 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.+ -- | Try to obtain the ghc options using cabal.+ --+ -- First, we try what the user requested and what cabal supports.+ -- For example, if the user requested to load multiple components at once, and cabal+ -- is recent enough, we try to use @--with-repl --enable-multi-repl@.+ -- We detect when certain cabal features are not supported. For example, for old+ -- lib:Cabal versions, @--with-repl@ is not supported. In this case, we parse the error message+ -- and fall back to the old `CabalWithGhcShimWrapper` version.+ -- The ghc shim @--with-ghc@ might work with @--keep-temp-files@ if no custom cabal package is part+ -- of the repl session, so we try to load that, and as a last resort, fall back to single component loading. runCabalToGetGhcOptions ::- Process.CreateProcess ->- CradleLoadResultT IO Process.CreateProcess ->+ ProgramVersions ->+ LoadModeTargets -> CradleLoadResultT IO (Either- (Int, ProcessErrorDetails)+ (CreateProcess, Int, ProcessErrorDetails) ([String], ProcessErrorDetails) )- runCabalToGetGhcOptions cabalProc mkFallbackCabalProc = do+ runCabalToGetGhcOptions progVersions cabalArgs = do+ cabalFeatures <- determineCabalLoadFeature progVersions+ let+ cacheDir = cradleCacheDirResolved cradles+ -- The preferred way of loading ghc-options. Requires cabal 3.16+ cabalWithReplProc = cabalLoadFilesWithRepl l cacheDir projectFile workDir cabalArgs+ -- Legacy way of loading ghc-options.+ -- Supports multi-repl and the deprecated single file mode.+ cabalWithGhcShimWrapper = cabalLoadFilesBefore315 l cacheDir progVersions projectFile workDir cabalArgs+ -- Legacy way of loading ghc-options.+ -- This should only be used for project with Custom setups that are older than lib:Cabal 3.16.+ cabalWithGhcShimWrapperSingleTarget = cabalLoadFilesBefore315 l cacheDir progVersions projectFile workDir (demoteToSingleLoadModeTarget cabalArgs)++ cabalProc <- case cabalFeatures of+ CabalWithRepl -> cabalWithReplProc+ CabalWithGhcShimWrapper -> cabalWithGhcShimWrapper++ loadResult <- getCabalGhcOptions cabalProc+ case loadResult of+ -- Some fallback+ Left (_, _, details)+ -- Used for @cabal >= 3.15@ but @lib:Cabal <3.15@, in custom setups.+ | isCabalLibraryInProjectTooOld (processStderr details) -> do+ liftIO $ l <& WithSeverity (LogWithReplNotSupported (processStderr details)) Debug+ shimResult <- getCabalGhcOptions =<< cabalWithGhcShimWrapper+ case shimResult of+ Left (_, _, shimDetails)+ | checkKeepTempFilesIsNotSupported shimDetails -> do+ liftIO $ l <& WithSeverity (LogKeepTempFilesNotSupported (processStdout shimDetails <> processStderr shimDetails)) Debug+ getCabalGhcOptions =<< cabalWithGhcShimWrapperSingleTarget+ _ ->+ pure shimResult++ | checkKeepTempFilesIsNotSupported details -> do+ liftIO $ l <& WithSeverity (LogKeepTempFilesNotSupported (processStdout details <> processStderr details)) Debug+ getCabalGhcOptions =<< cabalWithGhcShimWrapperSingleTarget++ Left codeAndDetails -> do+ pure $ Left codeAndDetails+ Right argsAndDetails ->+ pure $ Right argsAndDetails++ getCabalGhcOptions cabalProc = do (ex, output, stde, [(_, maybeArgs)]) <- liftIO $ Process.readProcessWithOutputs [hie_bios_output] l workDir cabalProc let args = fromMaybe [] maybeArgs let errorDetails = ProcessErrorDetails@@ -230,47 +270,52 @@ , 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)+ pure $ Left (cabalProc, code, errorDetails) ExitSuccess -> pure $ Right (args, errorDetails) + checkKeepTempFilesIsNotSupported details =+ -- See https://github.com/haskell/cabal/issues/12178 why we check stdout and stderr.+ -- This is a forward compatible check to make sure this won't break accidentally in the future once+ -- this ticket is fixed.+ isKeepTempFilesNotSupported (processStdout details) || isKeepTempFilesNotSupported (processStderr details) 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+ callCabalPathForCompilerPath l (cradleCacheDirResolved cs) vs wdir projectFile >>= \case Just p -> Process.readProcessWithCwd_ l wdir p args "" Nothing -> do- buildDir <- liftIO $ cabalBuildDir wdir+ buildDir <- liftIO $ cabalBuildDir (cradleCacheDirResolved cs) 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+ cabalProc <- cabalExecGhc l (cradleCacheDirResolved cs) vs projectFile wdir args Process.readProcessWithCwd' l cabalProc "" -processCabalLoadStyle :: MonadIO m => LogAction IO (WithSeverity Log) -> ResolvedCradles a -> CradleProjectConfig -> [Char] -> Maybe FilePath -> [Char] -> LoadStyle -> m ([FilePath], [FilePath], [FilePath])-processCabalLoadStyle l cradles projectFile workDir mc fp loadStyle = do- let fpModule = fromMaybe (fixTargetPath fp) mc+processCabalLoadMode :: MonadIO m => LogAction IO (WithSeverity Log) -> ResolvedCradles a -> ProgramVersions -> CradleProjectConfig -> [Char] -> Maybe FilePath -> TargetWithContext -> LoadMode -> m (LoadModeTargets, [FilePath], [FilePath])+processCabalLoadMode l cradles progVersions projectFile workDir mc fpc loadStyle = do+ usesResponseFiles <- usesResponseFilesForAllGhcOptions progVersions (cabalArgs, loadingFiles, extraDeps) <- case loadStyle of- LoadFile -> pure ([fpModule], [fp], [])- LoadWithContext fps -> do+ LoadFile -> pure (SingleTarget fpModule usesResponseFiles, [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)+ let+ extraModules = fmap fst modPairs+ allFiles = fp : fmap snd modPairs+ pure (MultipleTargets fpModule extraModules NoExtraComponents usesResponseFiles, allFiles, mergedDeps)+ LoadUnitsInferred -> loadUnits usesResponseFiles Inferred+ LoadUnitsFromCradle -> loadUnits usesResponseFiles FromCradle - liftIO $ l <& LogComputedCradleLoadStyle "cabal" loadStyle `WithSeverity` Info+ liftIO $ l <& LogComputedCradleLoadMode "cabal" fpc loadStyle `WithSeverity` Info liftIO $ l <& LogCabalLoad fp mc (prefix <$> resolvedCradles cradles) loadingFiles `WithSeverity` Debug- pure (cabalArgs, loadingFiles, extraDeps)+ pure (cabalArgs, nubOrd 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.@@ -296,18 +341,73 @@ | (file, _, _, old_mc) <- selected ] pure (modPairs, mergedDeps) -cabalLoadFilesWithRepl :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> [String] -> CradleLoadResultT IO CreateProcess-cabalLoadFilesWithRepl l projectFile workDir args = do- buildDir <- liftIO $ cabalBuildDir workDir+ 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 usesResponseFiles 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+ extraModules = nubOrd $ fmap fst modPairs+ allFiles = nubOrd $ fp : fmap snd modPairs+ let mergedDeps = mergedDeps0 ++ compDeps+ let+ extraComponents = case fst whichUnits of+ Inferred -> case projectFile of+ NoExplicitConfig -> LoadTestsAndBenchmarks+ ExplicitConfig{} -> NoExtraComponents+ FromCradle -> NoExtraComponents++ withExtraTargets targetFiles = case whichUnits of+ (Inferred, _) -> "all" : targetFiles+ (FromCradle, units) -> units ++ targetFiles++ pure (MultipleTargets fpModule (withExtraTargets extraModules) extraComponents usesResponseFiles, fp:allFiles, mergedDeps)++cabalLoadFilesWithRepl :: LogAction IO (WithSeverity Log) -> CacheDir -> CradleProjectConfig -> FilePath -> LoadModeTargets -> CradleLoadResultT IO CreateProcess+cabalLoadFilesWithRepl l cacheDir projectFile workDir args = do+ buildDir <- liftIO $ cabalBuildDir cacheDir workDir newEnvironment <- liftIO Process.getCleanEnvironment- wrapper_fp <- liftIO $ withReplWrapperTool l (proc "ghc") workDir+ wrapper_fp <- liftIO $ withReplWrapperTool l cacheDir (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+ , cabalCommand, "--with-repl", wrapper_fp+ ] <> projectFileProcessArgs projectFile <> renderLoadModeTargets CabalWithRepl args pure $ (proc "cabal" cabalArgs) { env = Just newEnvironment@@ -386,15 +486,10 @@ -- them. -- ---------------------------------------------------------------------------- -cabalLoadFilesBefore315 :: LogAction IO (WithSeverity Log) -> ProgramVersions -> CradleProjectConfig -> [Char] -> [String] -> CradleLoadResultT IO CreateProcess-cabalLoadFilesBefore315 l progVersions projectFile workDir args' = do+cabalLoadFilesBefore315 :: LogAction IO (WithSeverity Log) -> CacheDir -> ProgramVersions -> CradleProjectConfig -> [Char] -> LoadModeTargets -> CradleLoadResultT IO CreateProcess+cabalLoadFilesBefore315 l cacheDir 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+ cabalProcess l cacheDir progVersions projectFile workDir cabalCommand (renderLoadModeTargets CabalWithGhcShimWrapper args) `modCradleError` \err -> do deps <- cabalCradleDependencies projectFile workDir workDir pure $ err {cradleErrorDependencies = cradleErrorDependencies err ++ deps} @@ -407,15 +502,15 @@ -- 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+cabalProcess :: LogAction IO (WithSeverity Log) -> CacheDir -> ProgramVersions -> CradleProjectConfig -> FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess+cabalProcess l cacheDir vs cabalProject workDir command args = do+ ghcDirs@(ghcBin, libdir) <- callCabalPathForCompilerPath l cacheDir 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+ ghcPkgPath <- liftIO $ withGhcPkgTool cacheDir ghcBin libdir newEnvironment <- liftIO $ setupEnvironment ghcDirs cabalProc <- liftIO $ setupCabalCommand ghcPkgPath pure $ (cabalProc@@ -434,8 +529,8 @@ setupCabalCommand :: FilePath -> IO CreateProcess setupCabalCommand ghcPkgPath = do- wrapper_fp <- withGhcWrapperTool l (proc "ghc") workDir- buildDir <- cabalBuildDir workDir+ wrapper_fp <- withGhcWrapperTool l cacheDir (proc "ghc") workDir+ buildDir <- cabalBuildDir cacheDir workDir let extraCabalArgs = [ "--builddir=" <> buildDir , command@@ -494,8 +589,8 @@ -- -- 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+withGhcPkgTool :: CacheDir -> FilePath -> FilePath -> IO FilePath+withGhcPkgTool cacheDir ghcPathAbs libdir = do let ghcName = takeFileName ghcPathAbs -- TODO: check for existence ghcPkgPath = guessGhcPkgFromGhc ghcName@@ -531,7 +626,7 @@ ] ] srcHash = show (fingerprintString contents)- cacheFile "ghc-pkg" srcHash $ \wrapperFp -> writeFile wrapperFp contents+ cacheFileIn cacheDir "ghc-pkg" srcHash $ \wrapperFp -> writeFile wrapperFp contents -- Escape the filepath and trim excess newlines added by 'escapeArgs' escapeFilePath fp = trimEnd $ escapeArgs [fp]@@ -546,9 +641,9 @@ -- | 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+withGhcWrapperTool :: LogAction IO (WithSeverity Log) -> CacheDir -> GhcProc -> FilePath -> IO FilePath+withGhcWrapperTool l cacheDir mkGhcCall wdir = do+ withWrapperTool l cacheDir 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@@ -556,16 +651,16 @@ -- -- '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+withReplWrapperTool :: LogAction IO (WithSeverity Log) -> CacheDir -> GhcProc -> FilePath -> IO FilePath+withReplWrapperTool l cacheDir mkGhcCall wdir =+ withWrapperTool l cacheDir 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+withWrapperTool :: LogAction IO (WithSeverity Log) -> CacheDir -> GhcProc -> String -> FilePath -> String -> String -> IO FilePath+withWrapperTool l cacheDir 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 ->+ cacheFileIn cacheDir (withExtension baseName) srcHash $ \wrapper_fp -> if isWindows then withSystemTempDirectory "hie-bios" $ \ tmpDir -> do@@ -596,13 +691,13 @@ -- 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+-- | Given the cache root and the work directory, get the build dir we are+-- using for cabal.+cabalBuildDir :: CacheDir -> FilePath -> IO FilePath+cabalBuildDir (CacheDir cacheDir) workDir = do abs_work_dir <- makeAbsolute workDir let dirHash = show (fingerprintString abs_work_dir)- getCacheDir ("dist-" <> filter (not . isSpace) (takeBaseName abs_work_dir)<>"-"<>dirHash)+ pure $ cacheDir </> ("dist-" <> filter (not . isSpace) (takeBaseName abs_work_dir)<>"-"<>dirHash) -- |Find .cabal files in the given directory. --@@ -617,16 +712,16 @@ -- 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+cabalExecGhc :: LogAction IO (WithSeverity Log) -> CacheDir -> ProgramVersions -> CradleProjectConfig -> FilePath -> [String] -> CradleLoadResultT IO CreateProcess+cabalExecGhc l cacheDir vs projectFile wdir args = do+ cabalProcess l cacheDir 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+callCabalPathForCompilerPath :: LogAction IO (WithSeverity Log) -> CacheDir -> ProgramVersions -> FilePath -> CradleProjectConfig -> CradleLoadResultT IO (Maybe FilePath)+callCabalPathForCompilerPath l cacheDir vs workDir projectFile = do isCabalPathSupported vs >>= \case False -> pure Nothing True -> do- buildDir <- liftIO $ cabalBuildDir workDir+ buildDir <- liftIO $ cabalBuildDir cacheDir workDir let args = [ "--builddir=" <> buildDir, "path", "--output-format=json" ] <> projectFileProcessArgs projectFile@@ -644,10 +739,46 @@ -- Version and cabal capability checks -- ---------------------------------------------------------------------------- +data LoadUnits = Inferred | FromCradle+ deriving Eq++data WithTestsAndBenchmarks+ = NoExtraComponents+ | LoadTestsAndBenchmarks++data LoadModeTargets+ = SingleTarget+ String+ -- ^ Main Target FilePath or component+ UsesResponseFiles+ -- ^ Is this going to use top-level response files?+ | MultipleTargets+ String+ -- ^ Main Target FilePath or component+ [String]+ -- ^ Extra targets to load alongside the main component+ WithTestsAndBenchmarks+ -- ^ Should we enable tests and benchmarks as well?+ UsesResponseFiles+ -- ^ Is this going to use top-level response files?++loadModeUsesResponseFiles :: LoadModeTargets -> UsesResponseFiles+loadModeUsesResponseFiles = \ case+ SingleTarget _ usesResponseFiles -> usesResponseFiles+ MultipleTargets _ _ _ usesResponseFiles -> usesResponseFiles++demoteToSingleLoadModeTarget :: LoadModeTargets -> LoadModeTargets+demoteToSingleLoadModeTarget (MultipleTargets mainTarget _ _ _) = SingleTarget mainTarget NoResponseFiles+demoteToSingleLoadModeTarget (SingleTarget mainTarget _) = SingleTarget mainTarget NoResponseFiles+ data CabalLoadFeature = CabalWithRepl | CabalWithGhcShimWrapper +data UsesResponseFiles+ = UsesResponseFiles+ | NoResponseFiles+ determineCabalLoadFeature :: MonadIO m => ProgramVersions -> m CabalLoadFeature determineCabalLoadFeature vs = do cabal_version <- liftIO $ runCachedIO $ cabalVersion vs@@ -677,17 +808,21 @@ -- 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 :: MonadIO m => ProgramVersions -> m UsesResponseFiles 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+ | ver >= makeVersion [3, 15] && ver <= makeVersion [3, 16, 0, 0] -> pure UsesResponseFiles+ | ver >= makeVersion [3, 17] -> pure UsesResponseFiles+ | otherwise -> pure NoResponseFiles+ _ -> pure NoResponseFiles +renderResponseFileArgs :: UsesResponseFiles -> [[Char]]+renderResponseFileArgs = \ case+ UsesResponseFiles -> ["--keep-temp-files"]+ NoResponseFiles -> [] -- | 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:@@ -705,8 +840,23 @@ -- 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+ any ("constraint from --with-repl requires >=3.15" `isInfixOf`) stderr +-- | Some @cabal@ versions don't support @--keep-temp-files@+--+-- @+-- Configuring a-with-custom-0.1.0.0...+-- unrecognized 'repl' option `--keep-temp-files'+-- @+--+-- Can also occur with 'configure'.+--+-- We do a quick and dirty string comparison to check whether the error message looks like it has been caused+-- by using a @--keep-temp-files@ version that doesn't support the @--keep-temp-files@ flag.+isKeepTempFilesNotSupported :: [String] -> Bool+isKeepTempFilesNotSupported stderr =+ any (\ line -> all (`isInfixOf` line) ["unrecognized", "option `--keep-temp-files'"]) stderr+ isCabalPathSupported :: MonadIO m => ProgramVersions -> m Bool isCabalPathSupported vs = do v <- liftIO $ runCachedIO $ cabalVersion vs@@ -720,3 +870,24 @@ case (cabal_version, ghc_version) of (Just cabal, Just ghc) -> pure $ ghc >= makeVersion [9, 4] && cabal >= makeVersion [3, 11] _ -> pure False++renderWithTestsAndBenchmarks :: WithTestsAndBenchmarks -> [String]+renderWithTestsAndBenchmarks = \ case+ NoExtraComponents -> []+ LoadTestsAndBenchmarks -> ["--enable-tests", "--enable-benchmarks"]++renderLoadModeTargets :: CabalLoadFeature -> LoadModeTargets -> [String]+renderLoadModeTargets CabalWithGhcShimWrapper = \ case+ SingleTarget fp usesResponseFiles ->+ -- If cabal version is recent enough, we even need to pass '--keep-temp-files'+ -- when loading a single target+ fp : renderResponseFileArgs usesResponseFiles+ MultipleTargets mainTarget targets withTestsAndBenchmarks _usesResponseFiles ->+ "--enable-multi-repl" : "--keep-temp-files" : renderWithTestsAndBenchmarks withTestsAndBenchmarks ++ nubOrd (mainTarget:targets)+renderLoadModeTargets CabalWithRepl = \ case+ SingleTarget fp _usesResponseFiles ->+ -- We need to pass `--keep-temp-files` here as well as `with-repl` will invoke the script with a response file.+ ["--keep-temp-files", fp]+ MultipleTargets mainTarget targets withTestsAndBenchmarks _usesResponseFiles ->+ "--enable-multi-repl" : "--keep-temp-files" : renderWithTestsAndBenchmarks withTestsAndBenchmarks ++ nubOrd (mainTarget:targets)+
src/HIE/Bios/Cradle/Resolved.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} module HIE.Bios.Cradle.Resolved ( ResolvedCradles(..) , ResolvedCradle(..)@@ -6,6 +7,7 @@ import HIE.Bios.Cradle.ProgramVersions import HIE.Bios.Config+import HIE.Bios.Types -- | The final cradle config that specifies the cradle for -- each prefix we know how to handle@@ -13,6 +15,7 @@ { cradleRoot :: FilePath , resolvedCradles :: [ResolvedCradle a] -- ^ In order of decreasing specificity , cradleProgramVersions :: ProgramVersions+ , cradleCacheDirResolved :: CacheDir } -- | 'ConcreteCradle' augmented with information on which file the@@ -21,7 +24,7 @@ { prefix :: FilePath -- ^ the prefix to match files , cradleDeps :: [FilePath] -- ^ accumulated dependencies , concreteCradle :: ConcreteCradle a- } deriving Show+ } deriving (Show, Functor) -- | The actual type of action we will be using to process a file data ConcreteCradle a@@ -31,5 +34,4 @@ | ConcreteDirect [String] | ConcreteNone | ConcreteOther a- deriving Show-+ deriving (Show, Functor)
src/HIE/Bios/Cradle/Utils.hs view
@@ -18,6 +18,7 @@ import Data.List import System.Process.Extra import GHC.ResponseFile (expandResponse)+import HIE.Bios.Ghc.Gap (removeRTS) -- ---------------------------------------------------------------------------- -- Process error details@@ -53,6 +54,7 @@ -- | 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) =@@ -68,36 +70,6 @@ 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")) @@ -105,4 +77,3 @@ 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, initSession', getRuntimeGhcLibDir, getRuntimeGhcVersion, makeDynFlagsAbsolute, makeTargetsAbsolute, getCacheDir, addCmdOpts) where+{-# LANGUAGE TupleSections #-}+module HIE.Bios.Environment (initSession, initSession', getRuntimeGhcLibDir, getRuntimeGhcVersion, makeDynFlagsAbsolute, makeTargetsAbsolute, getCacheDir, resolveCacheDir, addCmdOpts, extractUnits) where import GHC (GhcMonad) import qualified GHC as G@@ -22,7 +23,13 @@ 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@@ -30,37 +37,82 @@ initSession :: (GhcMonad m) => ComponentOptions -> m [G.Target]-initSession = initSession' False+initSession = initSession' Nothing +-- | 'initSession' with caches placed under the given root instead of resolved+-- from the environment. initSession' :: (GhcMonad m)- => Bool+ => Maybe CacheDir -> ComponentOptions -> m [G.Target]-initSession' workAroundThreadUnsafety ComponentOptions {..} = do- df <- G.getSessionDynFlags+initSession' mCacheRoot 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 $ resolveCacheDir opts_hash mCacheRoot++ -- 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- -- 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+ 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.+ ) - 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.- )+ 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' - let targets' = makeTargetsAbsolute componentRoot targets+ 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' ----------------------------------------------------------------@@ -114,13 +166,22 @@ -- | Prepends the cache directory used by the library to the supplied file path. -- It tries to use the path under the environment variable `$HIE_BIOS_CACHE_DIR` -- and falls back to the standard `$XDG_CACHE_HOME/hie-bios` if the former is not set-getCacheDir :: FilePath -> IO FilePath+getCacheDir :: FilePath -> IO CacheDir getCacheDir fp = do mbEnvCacheDirectory <- lookupEnv "HIE_BIOS_CACHE_DIR" cacheBaseDir <- maybe (getXdgDirectory XdgCache cacheDir) return mbEnvCacheDirectory- return (cacheBaseDir </> fp)+ return (CacheDir (cacheBaseDir </> fp)) +-- | Resolve a cache directory root, appending @suffix@ and making it absolute.+-- An explicit path is used as given. 'Nothing' falls back to 'getCacheDir'.+resolveCacheDir :: FilePath -> Maybe CacheDir -> IO CacheDir+resolveCacheDir suffix mCacheRoot = do+ resolved <- case mCacheRoot of+ Nothing -> fmap unCacheDir (getCacheDir suffix)+ Just cacheRoot -> pure ((</> suffix) (unCacheDir cacheRoot))+ fmap CacheDir (makeAbsolute resolved)+ ---------------------------------------------------------------- -- we don't want to generate object code so we compile to bytecode@@ -138,14 +199,22 @@ setVerbosity :: Int -> G.DynFlags -> G.DynFlags setVerbosity n df = df { G.verbosity = n } -writeInterfaceFiles :: Maybe FilePath -> G.DynFlags -> G.DynFlags+writeInterfaceFiles :: Maybe CacheDir -> G.DynFlags -> G.DynFlags writeInterfaceFiles Nothing df = df-writeInterfaceFiles (Just hi_dir) df = setHiDir hi_dir (Gap.gopt_set df G.Opt_WriteInterface)+writeInterfaceFiles (Just (CacheDir hi_dir)) df = setHiDir hi_dir (Gap.gopt_set df G.Opt_WriteInterface) 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@@ -174,6 +243,7 @@ { G.importPaths = map makeAbs (G.importPaths df) , G.packageDBFlags = map (Gap.overPkgDbRef makeAbsOs) (G.packageDBFlags df)+ , G.workingDirectory = (root </>) <$> G.workingDirectory df } where makeAbs =
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
@@ -40,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@@ -49,15 +49,17 @@ => Maybe G.Messager -> ComponentOptions -> (m G.SuccessFlag, ComponentOptions)-initSessionWithMessage = initSessionWithMessage' False+initSessionWithMessage = initSessionWithMessage' Nothing +-- | 'initSessionWithMessage' with the interface-file cache placed under the+-- given root, see 'initSession''. initSessionWithMessage' :: (GhcMonad m)- => Bool+ => Maybe CacheDir -> Maybe G.Messager -> ComponentOptions -> (m G.SuccessFlag, ComponentOptions)-initSessionWithMessage' workAroundThreadUnsafety msg compOpts = (do- targets <- initSession' workAroundThreadUnsafety compOpts+initSessionWithMessage' mCacheRoot msg compOpts = (do+ targets <- initSession' mCacheRoot 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@@ -55,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 ----------------------------------------------------------------@@ -96,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@@ -111,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@@ -303,3 +332,114 @@ 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
@@ -163,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/Internal/Debug.hs view
@@ -25,13 +25,14 @@ -- -- Otherwise, shows the error message and exit-code. debugInfo :: Show a- => FilePath- -> LoadStyle+ => TargetWithContext+ -> LoadMode -> Cradle a -> IO String-debugInfo fp loadStyle cradle = unlines <$> do+debugInfo fpc loadStyle cradle = unlines <$> do+ let fp = targetFilePath fpc let logger = cradleLogger cradle- res <- getCompilerOptions fp loadStyle cradle+ res <- getCompilerOptions fpc loadStyle cradle canonFp <- canonicalizePath fp conf <- findConfig canonFp crdl <- findCradle' logger canonFp
src/HIE/Bios/Process.hs view
@@ -11,6 +11,7 @@ , getCleanEnvironment -- * File Caching , cacheFile+ , cacheFileIn -- * Find file utilities , findFileUpwards , findFileUpwardsPredicate@@ -36,6 +37,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Text as T import System.Environment+import System.FileLock import System.FilePath import System.IO (hClose, hGetContents, hSetBuffering, BufferMode(LineBuffering), withFile, IOMode(..)) import System.IO.Error (isPermissionError)@@ -156,14 +158,24 @@ cacheFile :: FilePath -> String -> (FilePath -> IO ()) -> IO FilePath cacheFile fpName srcHash populate = do cacheDir <- getCacheDir ""+ cacheFileIn cacheDir fpName srcHash populate++-- | 'cacheFile' with the cache directory given explicitly instead of resolved+-- from the environment.+cacheFileIn :: CacheDir -> FilePath -> String -> (FilePath -> IO ()) -> IO FilePath+cacheFileIn (CacheDir cacheDir) fpName srcHash populate = do createDirectoryIfMissing True cacheDir let newFpName = cacheDir </> (dropExtensions fpName <> "-" <> srcHash) <.> takeExtensions fpName- unlessM (doesFileExist newFpName) $ do- populate newFpName- setMode newFpName+ -- Concurrent loads race to create the same cache entry, so serialize them on+ -- a lock. Populate into a temp file and rename to keep it atomic as well.+ withFileLock (newFpName <.> "lock") Exclusive $ \_ ->+ unlessM (doesFileExist newFpName) $+ withTempFile cacheDir (takeFileName newFpName) $ \tmpFile tmpHandle -> do+ hClose tmpHandle+ populate tmpFile+ setFileMode tmpFile accessModes+ renamePath tmpFile newFpName pure newFpName- where- setMode wrapper_fp = setFileMode wrapper_fp accessModes ------------------------------------------------------------------------------ -- Utilities@@ -219,4 +231,3 @@ removeFileIfExists f = do yes <- doesFileExist f when yes (removeFile f)-
src/HIE/Bios/Types.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module HIE.Bios.Types where import System.Exit@@ -14,6 +16,7 @@ import qualified Control.Monad.Fail as Fail #endif import Data.Maybe (fromMaybe)+import Data.String import qualified Data.Text as T import Prettyprinter import System.Process.Extra (CreateProcess (env, cmdspec), CmdSpec (..), showCommandForUser)@@ -102,14 +105,21 @@ | 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]+ | LogWithReplNotSupported [String]+ | LogKeepTempFilesNotSupported [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@@ -129,35 +139,59 @@ ] 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+ pretty (LogWithReplNotSupported err) =+ "'lib:Cabal' is too old to use '--with-repl' flag. Requires 'lib:Cabal' >= 3.15. Likely caused by `build-type: Custom`. Original error:" <> line <> vcat (fmap pretty err)+ pretty (LogKeepTempFilesNotSupported err) =+ "'lib:Cabal' is too old to use '--keep-temp-files' flag. Likely caused by `build-type: Custom`. 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. --@@ -165,7 +199,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@@ -173,12 +207,29 @@ -- 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) +newtype CacheDir = CacheDir { unCacheDir :: FilePath }+ deriving (Show, Eq)+ deriving newtype (IsString)++-- | Configuration for constructing and running a 'Cradle'.+data CradleRunConfig = CradleRunConfig+ { cradleCacheDir :: Maybe CacheDir+ -- ^ Root directory for cache artefacts produced while running the cradle.+ -- 'Nothing' falls back to @$HIE_BIOS_CACHE_DIR@, or the XDG cache+ -- directory if that is unset. See 'resolveCacheDir'.+ } deriving (Show, Eq)++defaultCradleRunConfig :: CradleRunConfig+defaultCradleRunConfig = CradleRunConfig { cradleCacheDir = Nothing }+ 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
tests/BiosTests.hs view
@@ -4,32 +4,45 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-}-module Main where+{-# LANGUAGE NumericUnderscores #-}+module Main (main) where import Utils -import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.ExpectedFailure-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 HIE.Bios.Cradle.Cabal (cabalBuildDir)-import Control.Monad (forM_)+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (replicateConcurrently)+import Control.Exception (SomeException, evaluate, try)+import Control.Monad (forM, forM_, unless, when) import Control.Monad.Extra (unlessM) import Control.Monad.IO.Class import Data.Foldable (for_)-import Data.List ( sort, isPrefixOf )+import Data.List (isInfixOf, isPrefixOf, sort, tails, last)+import Data.Maybe (isJust) import Data.Typeable-import System.Exit (ExitCode(ExitSuccess, ExitFailure))+import Data.Version+import HIE.Bios+import HIE.Bios.Cradle+import HIE.Bios.Cradle.Cabal (cabalBuildDir)+import HIE.Bios.Cradle.Utils (expandGhcOptionResponseFile)+import HIE.Bios.Environment (extractUnits, resolveCacheDir)+import qualified HIE.Bios.Ghc.Gap as Gap+import HIE.Bios.Process (cacheFileIn)+import HIE.Bios.Types (CacheDir (..), LoadMode (..), TargetWithContext (..)) import System.Directory-import System.FilePath ((</>), makeRelative)-import System.Info.Extra (isWindows)+import System.Exit (ExitCode (ExitFailure, ExitSuccess))+import System.FilePath (makeRelative, (</>)) import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout)-import qualified HIE.Bios.Ghc.Gap as Gap-+import System.IO.Temp+import System.Info.Extra (isWindows)+import System.Process+import Test.Tasty+import Test.Tasty.ExpectedFailure+import Test.Tasty.HUnit+import qualified Test.Tasty.Ingredients as Tasty+import qualified Test.Tasty.Options as Tasty+import qualified Test.Tasty.Runners as Tasty+import Text.ParserCombinators.ReadP (readP_to_S)+import Debug.Trace (traceShowId) argDynamic :: [String] argDynamic = ["-dynamic" | Gap.hostIsDynamic]@@ -66,6 +79,10 @@ cabalDep <- checkToolIsAvailable "cabal" extraGhcDep <- checkToolIsAvailable extraGhc + -- Pre-create the shared extraGhc cabal store. The parallel tests otherwise+ -- race to initialise it and can fail with "package.db already exists".+ when (toolExists cabalDep && toolExists extraGhcDep) warmupExtraGhcStore+ defaultMainWithIngredients (ignoreToolTests:verboseLogging:defaultIngredients) $ -- Run tests sequentially on Windows, to avoid issues with locking of the -- package database, e.g. errors of the form:@@ -74,14 +91,23 @@ testGroup "Bios-tests" [ testGroup "Find cradle" findCradleTests , testGroup "Symlink" symbolicLinkTests+ , testGroup "Cache files" cacheFileTests , testGroup "Loading tests" [ testGroup "bios" biosTestCases , testGroup "direct" directTestCases- , testGroupWithDependency cabalDep (cabalTestCases extraGhcDep)+ , testGroupWithDependency cabalDep (cabalTestCases cabalDep extraGhcDep) , ignoreOnUnsupportedGhc $ testGroupWithDependency stackDep stackTestCases ] ] +-- | Load a cabal-with-ghc cradle once to create the extraGhc store. The result+-- is ignored; only the store-creation side effect matters. See 'main'.+warmupExtraGhcStore :: IO ()+warmupExtraGhcStore =+ runTestEnv "./cabal-with-ghc"+ (initCradle "src/MyLib.hs" *> loadComponentOptions (TargetWithContext "src/MyLib.hs" []))+ defConfig+ symbolicLinkTests :: [TestTree] symbolicLinkTests = [ biosTestCase "Can load base module" $ runTestEnv "./symlink-test" $ do@@ -89,7 +115,7 @@ assertCradle isMultiCradle step "Attempt to load symlinked module A" do- loadComponentOptions "./a/A.hs"+ loadComponentOptions $ TargetWithContext "./a/A.hs" [] assertComponentOptions $ \opts -> componentOptions opts `shouldMatchList` ["a"] <> argDynamic @@ -103,7 +129,7 @@ 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 $ TargetWithContext "./b/A.hs" [] assertComponentOptions $ \opts -> componentOptions opts `shouldMatchList` ["b"] <> argDynamic @@ -117,16 +143,39 @@ 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 $ TargetWithContext "./c/A.hs" [] assertLoadNone ] +-- | Concurrent 'cacheFileIn' calls can race on the same cache entry.+cacheFileTests :: [TestTree]+cacheFileTests =+ [ testCase "cacheFile is atomic under concurrent calls" $ do+ withSystemTempDirectory "hie-bios-cache-file-test" $ \testCacheDir -> do+ let payloadPrefix = "#!/bin/sh\n"+ payloadSuffix = concat (replicate 500 "echo 'cacheFile is atomic under concurrent calls'\n")+ payload = payloadPrefix <> payloadSuffix+ -- Pause mid-write so a non-atomic populate would expose a partial+ -- file, and so all threads pile up on the entry concurrently.+ populate fp = do+ writeFile fp payloadPrefix+ threadDelay 50_000 -- 50ms+ appendFile fp payloadSuffix+ results <- replicateConcurrently 16 $ try @SomeException $ do+ fp <- cacheFileIn (CacheDir testCacheDir) "ghc-pkg" "0123456789abcdef" populate+ contents <- readFile fp+ contents <$ evaluate (length contents)+ forM_ results $ \case+ Left err -> assertFailure $ "cacheFile threw: " <> show err+ Right contents -> assertEqual "cached file contents" payload contents+ ]+ biosTestCases :: [TestTree] biosTestCases = [ biosTestCase "failing-bios" $ runTestEnv "./failing-bios" $ do initCradle "B.hs" assertCradle isBiosCradle- loadComponentOptions "B.hs"+ loadComponentOptions $ TargetWithContext "B.hs" [] assertCradleError $ \CradleError {..} -> do cradleErrorExitCode @?= ExitFailure 1 cradleErrorDependencies `shouldMatchList` ["hie.yaml"]@@ -145,7 +194,7 @@ 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"+ testDirectoryM isBiosCradle $ single "B.hs" , biosTestCase "simple-bios-shell-deps" $ runTestEnv "./simple-bios-shell" $ do biosCradleDeps "B.hs" ["hie.yaml"] ] <> concat [linuxTestCases | False] -- TODO(fendor), enable again@@ -154,33 +203,33 @@ biosCradleDeps fp deps = do initCradle fp assertCradle isBiosCradle- loadComponentOptions fp+ loadComponentOptions $ TargetWithContext fp [] assertComponentOptions $ \opts -> do deps @?= componentDependencies opts linuxTestCases = [ biosTestCase "simple-bios" $ runTestEnv "./simple-bios" $- testDirectoryM isBiosCradle "B.hs"+ testDirectoryM isBiosCradle $ single "B.hs" , biosTestCase "simple-bios-ghc" $ runTestEnv "./simple-bios-ghc" $- testDirectoryM isBiosCradle "B.hs"+ testDirectoryM isBiosCradle $ single "B.hs" , biosTestCase "simple-bios-deps" $ runTestEnv "./simple-bios" $ do biosCradleDeps "B.hs" ["hie-bios.sh", "hie.yaml"] , biosTestCase "simple-bios-deps-new" $ runTestEnv "./deps-bios-new" $ do biosCradleDeps "B.hs" ["hie-bios.sh", "hie.yaml"] ] -cabalTestCases :: ToolDependency -> [TestTree]-cabalTestCases extraGhcDep =+cabalTestCases :: ToolDependency -> ToolDependency -> [TestTree]+cabalTestCases cabalDep 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'+ multiSupported <- isCabalMultipleCompSupportedM if multiSupported then assertCradleError (\CradleError {..} -> do@@ -190,15 +239,17 @@ (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- testDirectoryM isCabalCradle "B.hs"- , biosTestCase "build-dir" $ runTestEnv "./simple-cabal" $ do+ , biosTestCaseAll "simple-cabal" $ runTestEnv "./simple-cabal" $ do+ testDirectoryM isCabalCradle $ single "B.hs"+ , biosTestCaseMulti "build-dir" $ runTestEnv "./simple-cabal" $ do initCradle "B.hs" assertCradle isCabalCradle root <- askRoot- buildDir <- liftIO $ cabalBuildDir root+ buildDir <- liftIO $ do+ cacheDir <- resolveCacheDir "" Nothing+ cabalBuildDir cacheDir root -- use --multi-repl, as that was the codepath with the bug- loadFileGhcMultiStyle "B.hs" []+ loadFileGhc $ TargetWithContext "B.hs" [] liftIO $ do -- Check we aren't trampling over dist-newstyle distNewstyleExists <- doesDirectoryExist (root </> "dist-newstyle")@@ -206,30 +257,60 @@ -- Check we are using the correct build directory buildDirExists <- doesDirectoryExist buildDir assertBool "build dir does not exist" buildDirExists- , biosTestCase "nested-cabal" $ runTestEnv "./nested-cabal" $ do- cabalAttemptLoad "sub-comp/Lib.hs"+ , biosTestCase "custom cache dir" $ runTestEnv "./simple-cabal" $+ withSystemTempDirectory "hie-bios-custom-cache-dir" $ \cacheRoot -> do+ initCradleWithConfig defaultCradleRunConfig { cradleCacheDir = Just (CacheDir cacheRoot) } "B.hs"+ assertCradle isCabalCradle+ loadComponentOptions $ TargetWithContext "B.hs" []+ _ <- assertLoadSuccess+ liftIO $ do+ entries <- listDirectory cacheRoot+ assertBool ("cache entries under the configured dir: " <> show entries)+ (any (\e -> "wrapper" `isInfixOf` e || "dist-" `isPrefixOf` e) entries)+ , 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 "nested-cabal multi-mode includes enclosing deps for extra files" $ runTestEnv "./nested-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'+ multiSupported <- isCabalMultipleCompSupportedM if multiSupported then do- loadComponentOptionsMultiStyle "sub-comp/Lib.hs" ["MyLib.hs"]+ loadComponentOptions $ TargetWithContext "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.@@ -241,17 +322,17 @@ ] else do -- On older cabal/ghc combos, multi-repl isn't supported; just ensure load succeeds.- loadComponentOptions "sub-comp/Lib.hs"+ loadComponentOptions $ TargetWithContext "sub-comp/Lib.hs" [] _ <- assertLoadSuccess pure ()- , biosTestCase "nested-cabal multi-mode includes enclosing deps when extra file is subcomp" $ runTestEnv "./nested-cabal" $ do+ , 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'+ multiSupported <- isCabalMultipleCompSupportedM if multiSupported then do- loadComponentOptionsMultiStyle "MyLib.hs" ["sub-comp/Lib.hs"]+ loadComponentOptions $ TargetWithContext "MyLib.hs" ["sub-comp/Lib.hs"] assertComponentOptions $ \opts -> do componentDependencies opts `shouldMatchList` [ "nested-cabal.cabal"@@ -260,27 +341,29 @@ , "cabal.project.local" ] else do- loadComponentOptions "MyLib.hs"+ loadComponentOptions $ TargetWithContext "MyLib.hs" [] _ <- assertLoadSuccess pure ()- , biosTestCase "multi-cabal" $ runTestEnv "./multi-cabal" $ do+ , biosTestCaseAll "multi-cabal" $ runTestEnv "./multi-cabal" $ do {- tests if both components can be loaded -}- testDirectoryM isCabalCradle "app/Main.hs"- testDirectoryM isCabalCradle "src/Lib.hs"+ testDirectoryM isCabalCradle $ single "app/Main.hs"+ testDirectoryM isCabalCradle $ single "src/Lib.hs" , {- issue https://github.com/mpickering/hie-bios/issues/200 -}- biosTestCase "monorepo-cabal" $ runTestEnv "./monorepo-cabal" $ do- testDirectoryM isCabalCradle "A/Main.hs"- testDirectoryM isCabalCradle "B/MyLib.hs"+ biosTestCaseAll "monorepo-cabal" $ runTestEnv "./monorepo-cabal" $ do+ testDirectoryM isCabalCradle $ single "A/Main.hs"+ testDirectoryM isCabalCradle $ single "B/MyLib.hs" , testGroup "Implicit cradle tests" $- [ biosTestCase "implicit-cabal" $ runTestEnv "./implicit-cabal" $ do- testImplicitDirectoryM isCabalCradle "Main.hs"- , biosTestCase "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- testImplicitDirectoryM isCabalCradle "foo/Main.hs"+ [ biosTestCaseAll "implicit-cabal" $ runTestEnv "./implicit-cabal" $ do+ testImplicitDirectoryM isCabalCradle $ single "Main.hs"+ , biosTestCaseAll "implicit-cabal-no-project" $ runTestEnv "./implicit-cabal-no-project" $ do+ testImplicitDirectoryM isCabalCradle $ single "Main.hs"+ , biosTestCaseAll "implicit-cabal-deep-project" $ runTestEnv "./implicit-cabal-deep-project" $ do+ testImplicitDirectoryM isCabalCradle $ single "foo/Main.hs"+ , biosTestCase "implicit-cabal-deep-project-with-context" $ runTestModeEnv "./implicit-cabal-deep-project" LoadFileWithContext $ do+ testImplicitDirectoryM isCabalCradle $ ctx "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@@ -288,85 +371,131 @@ loadRuntimeGhcVersion assertGhcVersionIs extraGhcVersion step "Find Component Options"- loadComponentOptions "src/MyLib.hs"+ loadComponentOptions $ TargetWithContext "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- 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- 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- initCradle "src/MyLib.hs"- assertCradle isCabalCradle- loadRuntimeGhcLibDir- assertLibDirVersionIs extraGhcVersion- loadRuntimeGhcVersion- assertGhcVersionIs extraGhcVersion- step "Find Component Options"- loadComponentOptions "src/MyLib.hs"- _ <- assertLoadSuccess- pure ()- ]- , biosTestCase "force older Cabal version in custom setup" $ runTestEnv "cabal-with-custom-setup" $ do+ , 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 $ single "src/MyLib.hs"+ , 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 $ single "appB/src/Lib.hs"+ testDirectoryM isCabalCradle $ single "appB/src/Lib.hs"+ , testGroupWithDependency extraGhcDep+ [ 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 $ TargetWithContext "src/MyLib.hs" []+ _ <- assertLoadSuccess+ pure ()+ ]+ , 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+ , testGroup "custom Cabal"+ [ biosTestCaseAll "with-repl fallback" $ runTestEnv "cabal-with-custom-setup-old" $ 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"- , biosTestCase "force older Cabal version in custom setup with multi mode" $ runTestEnv "cabal-with-custom-setup" $ do+ testDirectoryM isCabalCradle $ single "a-with-custom/src/MyLib.hs"+ , expectBrokenOnCabal318 cabalDep $ biosTestCaseAll "loads other packages with multi-repl" $ runTestEnv "cabal-with-custom-setup-old" $ 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- loadFileGhcMultiStyle target []+ testDirectoryM isCabalCradle $ ctx "b/src/B.hs" ["b/tests/Main.hs"]+ , biosTestCaseAll "custom package and simple package" $ runTestEnv "cabal-with-custom-setup" $ do+ testDirectoryM isCabalCradle $ single "b/src/B.hs" ]+ ] 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 $ TargetWithContext fp fps cabalLoadOptions :: FilePath -> TestM ComponentOptions cabalLoadOptions fp = do initCradle fp assertCradle isCabalCradle- loadComponentOptions fp+ loadComponentOptions $ TargetWithContext 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" $@@ -376,10 +505,12 @@ cradleErrorExitCode @?= ExitFailure 1 cradleErrorDependencies `shouldMatchList` ["failing-stack.cabal", "stack.yaml", "package.yaml"] , biosTestCase "simple-stack" $ runTestEnv "./simple-stack" $ do- testDirectoryM isStackCradle "B.hs"+ testDirectoryM isStackCradle $ single "B.hs" , biosTestCase "multi-stack" $ runTestEnv "./multi-stack" $ do {- tests if both components can be loaded -}- testDirectoryM isStackCradle "app/Main.hs"- testDirectoryM isStackCradle "src/Lib.hs"+ testDirectoryM isStackCradle $ single "app/Main.hs"+ testDirectoryM isStackCradle $ single "src/Lib.hs"+ , biosTestCaseMulti "multi-stack-multi-modes" $ runTestEnv "./multi-stack" $ do+ testDirectoryM isStackCradle $ single "app/Main.hs" , biosTestCase "nested-stack" $ runTestEnv "./nested-stack" $ do stackAttemptLoad "sub-comp/Lib.hs" assertComponentOptions $ \opts ->@@ -390,24 +521,40 @@ componentDependencies opts `shouldMatchList` ["nested-stack.cabal", "package.yaml", "stack.yaml"] , biosTestCase "stack-with-yaml" $ runTestEnv "./stack-with-yaml" $ do {- tests if both components can be loaded -}- testDirectoryM isStackCradle "app/Main.hs"- testDirectoryM isStackCradle "src/Lib.hs"+ testDirectoryM isStackCradle $ single "app/Main.hs"+ testDirectoryM isStackCradle $ single "src/Lib.hs" , biosTestCase "multi-stack-with-yaml" $ runTestEnv "./multi-stack-with-yaml" $ do {- tests if both components can be loaded -}- testDirectoryM isStackCradle "appA/src/Lib.hs"- testDirectoryM isStackCradle "appB/src/Lib.hs"+ testDirectoryM isStackCradle $ single "appA/src/Lib.hs"+ testDirectoryM isStackCradle $ single "appB/src/Lib.hs"+ , biosTestCase "multi-stack-with-load" $ runTestModeEnv "multi-stack-with-load" LoadUnitsFromCradle $ do+ testDirectoryM isStackCradle $ single "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 $ single "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 biosTestCase "space stack" $ runTestEnv "./space stack" $ do- testDirectoryM isStackCradle "A.hs"- testDirectoryM isStackCradle "B.hs"+ testDirectoryM isStackCradle $ single "A.hs"+ testDirectoryM isStackCradle $ single "B.hs" , testGroup "Implicit cradle tests"- [ biosTestCase "implicit-stack" $ runTestEnv "./implicit-stack" $- testImplicitDirectoryM isStackCradle "Main.hs"- , biosTestCase "implicit-stack-multi" $ runTestEnv "./implicit-stack-multi" $ do- testImplicitDirectoryM isStackCradle "Main.hs"- testImplicitDirectoryM isStackCradle "other-package/Main.hs"+ [ biosTestCase "implicit-stack" $ runTestModeEnv "./implicit-stack" LoadFile $ do+ testImplicitDirectoryM isStackCradle $ single "Main.hs"+ , biosTestCase "implicit-stack-multi" $ runTestModeEnv "./implicit-stack-multi" LoadFile $ do+ testImplicitDirectoryM isStackCradle $ single "Main.hs"+ testImplicitDirectoryM isStackCradle $ single "other-package/Main.hs" ] ] where@@ -415,16 +562,16 @@ stackAttemptLoad fp = do initCradle fp assertCradle isStackCradle- loadComponentOptions fp+ loadComponentOptions $ TargetWithContext fp [] directTestCases :: [TestTree] directTestCases = [ biosTestCase "simple-direct" $ runTestEnv "./simple-direct" $ do- testDirectoryM isDirectCradle "B.hs"+ testDirectoryM isDirectCradle $ single "B.hs" , biosTestCase "multi-direct" $ runTestEnv "./multi-direct" $ do {- tests if both components can be loaded -}- testDirectoryM isMultiCradle "A.hs"- testDirectoryM isMultiCradle "B.hs"+ testDirectoryM isMultiCradle $ single "A.hs"+ testDirectoryM isMultiCradle $ single "B.hs" ] findCradleTests :: [TestTree]@@ -456,11 +603,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 -- ------------------------------------------------------------------@@ -482,6 +645,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@@ -512,15 +676,25 @@ data ToolDependency = ToolDependency { toolName :: String- , toolExists :: Bool+ , toolVersion :: Maybe Version } +toolExists :: ToolDependency -> Bool+toolExists td = isJust $ toolVersion td+ checkToolIsAvailable :: String -> IO ToolDependency checkToolIsAvailable f = do- exists <- maybe False (const True) <$> findExecutable f+ mexe <- findExecutable f+ version <- case mexe of+ Nothing -> pure Nothing+ Just exe -> do+ versionStr <- readProcess exe ["--numeric-version"] ""+ pure $ case readP_to_S parseVersion versionStr of+ xs@(_:_) -> Just $ fst $ last xs+ [] -> Nothing pure ToolDependency { toolName = f- , toolExists = exists+ , toolVersion = version } testGroupWithDependency :: ToolDependency -> [TestTree] -> TestTree@@ -585,4 +759,16 @@ #if (defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,14,0,0)) ignoreTestBecause "Not supported on GHC 9.14" #endif- tt+ tt++expectBrokenOnCabal318 :: ToolDependency -> TestTree -> TestTree+expectBrokenOnCabal318 td tt =+ if traceShowId (traceShowId (toolVersion td) >= Just (makeVersion [3,17,0,0]))+ then expectFailBecause+ ("cabal 3.18 passes all options using response files. \+ If old lib:Cabal versions are used, we can't pass '--keep-temp-files' because the configure step rejects it. \+ Thus, the response files are deleted before we can parse them. Falling back to the ghc shim wrapper doesn't work either \+ since all arguments are passed via response files and we can't see the first argument to be '--interactive' and the wrapper fails.\+ "+ ) tt+ else tt
tests/ParserTests.hs view
@@ -26,58 +26,64 @@ main :: IO () main = defaultMain $ testGroup "Parser Tests"- [ assertParser "cabal-1.yaml" (noDeps (Cabal $ CabalType (Just "lib:hie-bios") Nothing))- , assertParser "stack-config.yaml" (noDeps (Stack $ StackType Nothing Nothing))+ [ assertParser "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)))+ , 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))- ,("./test", CradleConfig [] (Cabal $ CabalType (Just "test") Nothing))]))+ , 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) ,("./", 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) ,("./", 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.extra")))+ (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")))+ (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"))- [("./src", CabalType (Just "lib:hie-bios") Nothing)- ,("./vendor", CabalType (Just "parser-tests") Nothing)]))+ (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")))+ (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")))+ (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"))- [("./src", StackType (Just "lib:hie-bios") Nothing)- ,("./vendor", StackType (Just "parser-tests") Nothing)]))+ (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" (noDeps (Other CabalHelperCabal $ simpleCabalHelperYaml "cabal"))@@ -87,11 +93,18 @@ (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))+ , 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 -> TestTree@@ -104,6 +117,10 @@ invalidYamlException :: Selector ParseException invalidYamlException (InvalidYaml (Just _)) = True invalidYamlException _ = False++aesonException :: Selector ParseException+aesonException (AesonException _) = True+aesonException _ = False assertParserFails :: Exception e => FilePath -> Selector e -> TestTree assertParserFails fp es = testCase fp $ (readConfig (configDir </> fp) :: IO (Config Void)) `shouldThrow` es
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,@@ -39,16 +41,18 @@ step, normFile, relFile,+ mainTarget, findCradleLoc, initCradle,+ initCradleWithConfig, initImplicitCradle, loadComponentOptions,- loadComponentOptionsMultiStyle, loadRuntimeGhcLibDir, loadRuntimeGhcVersion, loadFileGhc,- loadFileGhcMultiStyle,- isCabalMultipleCompSupported',+ isCabalMultipleCompSupportedM,+ single,+ ctx, -- * Assertion helpers assertCradle,@@ -94,6 +98,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@@ -105,8 +111,9 @@ { useTemporaryDirectory :: Bool , testProjectRoots :: FilePath , testVerbose :: Bool+ , testStepFunction :: String -> IO ()+ , testLoadModeConfig :: LoadMode }- deriving (Eq, Show, Ord) data TestEnv ext = TestEnv { testCradleType :: Maybe (Cradle ext)@@ -115,26 +122,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@@ -143,13 +163,14 @@ , testGhcVersionResult = Nothing , testRootDir = root' , testLogger = init_logger+ , testLoadMode = testLoadModeConfig config } 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)@@ -245,10 +266,19 @@ askLogger :: TestM (L.LogAction IO (L.WithSeverity HIE.Log)) askLogger = gets testLogger +askLoadMode :: TestM LoadMode+askLoadMode = gets testLoadMode+ -- --------------------------------------------------------------------------- -- Test setup helpers -- --------------------------------------------------------------------------- +single :: FilePath -> TargetWithContext+single fp = TargetWithContext fp []++ctx :: FilePath -> [FilePath] -> TargetWithContext+ctx fp fps = TargetWithContext fp fps+ step :: String -> TestM () step msg = do s <- askStep@@ -257,6 +287,9 @@ normFile :: FilePath -> TestM FilePath normFile fp = (</> fp) <$> gets testRootDir +mainTarget :: TargetWithContext -> TestM FilePath+mainTarget target = (</> targetFilePath target) <$> gets testRootDir+ relFile :: FilePath -> TestM FilePath relFile fp = (`makeRelative` fp) <$> gets testRootDir @@ -266,7 +299,10 @@ liftIO $ findCradle a_fp initCradle :: FilePath -> TestM ()-initCradle fp = do+initCradle = initCradleWithConfig defaultCradleRunConfig++initCradleWithConfig :: CradleRunConfig -> FilePath -> TestM ()+initCradleWithConfig config fp = do a_fp <- normFile fp step $ "Finding Cradle for: " <> fp mcfg <- findCradleLoc a_fp@@ -274,8 +310,9 @@ step $ "Loading Cradle: " <> show relMcfg logger <- askLogger crd <- case mcfg of- Just cfg -> liftIO $ loadCradle logger cfg- Nothing -> liftIO $ loadImplicitCradle logger a_fp+ Just cfg -> liftIO $ loadCradleWithConfig logger config cfg+ Nothing -> liftIO $ loadImplicitCradleWithConfig logger config a_fp+ step $ "Cradle: " ++ show crd setCradle crd initImplicitCradle :: FilePath -> TestM ()@@ -286,21 +323,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 :: TargetWithContext -> TestM ()+loadComponentOptions (TargetWithContext fp extraFps) = do a_fp <- normFile fp- a_fps <- traverse 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 ()@@ -317,43 +349,27 @@ ghcVersionRes <- liftIO $ getRuntimeGhcVersion crd setGhcVersionResult ghcVersionRes -isCabalMultipleCompSupported' :: TestM Bool-isCabalMultipleCompSupported' = do+isCabalMultipleCompSupportedM :: TestM Bool+isCabalMultipleCompSupportedM = do cr <- askCradle root <- askRoot versions <- liftIO $ makeVersions (cradleLogger cr) root ((runGhcCmd . cradleOptsProg) cr) liftIO $ isCabalMultipleCompSupported versions -loadFileGhc :: FilePath -> TestM ()-loadFileGhc fp = do- libdir <- askOrLoadLibDir- a_fp <- normFile fp- stepF <- askStep- step "Cradle load"- loadComponentOptions fp- opts <- assertLoadSuccess- liftIO $- G.runGhc (Just libdir) $ do- let (ini, _) = initSessionWithMessage' True (Just G.batchMsg) opts- sf <- ini- case sf of- -- Test resetting the targets- Succeeded -> do- liftIO $ stepF "Set target files"- setTargetFiles mempty [(a_fp, a_fp)]- Failed -> liftIO $ assertFailure "Module loading failed"--loadFileGhcMultiStyle :: FilePath -> [FilePath] -> TestM ()-loadFileGhcMultiStyle fp extraFps = do+loadFileGhc :: TargetWithContext -> TestM ()+loadFileGhc target = do libdir <- askOrLoadLibDir- a_fp <- normFile fp+ a_fp <- mainTarget target stepF <- askStep step "Cradle load"- loadComponentOptionsMultiStyle fp extraFps+ loadComponentOptions target opts <- assertLoadSuccess+ root <- askRoot+ -- Tests run in parallel, so isolate the interface-file cache per test root.+ let ifaceCacheRoot = CacheDir (root </> "ghc-iface-cache") liftIO $ G.runGhc (Just libdir) $ do- let (ini, _) = initSessionWithMessage' True (Just G.batchMsg) opts+ let (ini, _) = initSessionWithMessage' (Just ifaceCacheRoot) (Just G.batchMsg) opts sf <- ini case sf of -- Test resetting the targets@@ -437,25 +453,25 @@ -- High-level, re-usable assertions -- --------------------------------------------------------------------------- -testDirectoryM :: (Cradle Void -> Bool) -> FilePath -> TestM ()-testDirectoryM cradlePred file = do- initCradle file+testDirectoryM :: (Cradle Void -> Bool) -> TargetWithContext -> TestM ()+testDirectoryM cradlePred target = do+ initCradle $ targetFilePath target assertCradle cradlePred loadRuntimeGhcLibDir assertLibDirVersion loadRuntimeGhcVersion assertGhcVersion- loadFileGhc file+ loadFileGhc target -testImplicitDirectoryM :: (Cradle Void -> Bool) -> FilePath -> TestM ()-testImplicitDirectoryM cradlePred file = do- initImplicitCradle file+testImplicitDirectoryM :: (Cradle Void -> Bool) -> TargetWithContext -> TestM ()+testImplicitDirectoryM cradlePred target = do+ initImplicitCradle $ targetFilePath target assertCradle cradlePred loadRuntimeGhcLibDir assertLibDirVersion loadRuntimeGhcVersion assertGhcVersion- loadFileGhc file+ loadFileGhc target findCradleForModuleM :: FilePath -> Maybe FilePath -> TestM () findCradleForModuleM fp expected' = do@@ -468,13 +484,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-load.yaml view
@@ -0,0 +1,3 @@+cradle:+ cabal:+ componentsToLoad: ["lib:hie-bios","parser-tests","some-other"]
+ 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-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-custom-setup-old/a-with-custom/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/projects/cabal-with-custom-setup-old/a-with-custom/a-with-custom.cabal view
@@ -0,0 +1,15 @@+cabal-version: 3.0+name: a-with-custom+version: 0.1.0.0+build-type: Custom++custom-setup+ setup-depends:+ Cabal <3.16,+ base++library+ exposed-modules: MyLib+ build-depends: base+ hs-source-dirs: src+ default-language: Haskell2010
+ tests/projects/cabal-with-custom-setup-old/a-with-custom/src/MyLib.hs view
@@ -0,0 +1,4 @@+module MyLib (someFunc) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ tests/projects/cabal-with-custom-setup-old/b/b.cabal view
@@ -0,0 +1,30 @@+cabal-version: 3.0+name: b+version: 0.1.0.0+-- synopsis:+-- description:+license: NONE+author: fendor+maintainer: fendor@posteo.de+-- copyright:+build-type: Simple+extra-doc-files: CHANGELOG.md+-- extra-source-files:++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: B+ -- other-modules:+ -- other-extensions:+ build-depends: base, a-with-custom+ hs-source-dirs: src+ default-language: Haskell2010++test-suite b-tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: tests+ build-depends: base
+ tests/projects/cabal-with-custom-setup-old/b/src/B.hs view
@@ -0,0 +1,6 @@+module B (someFunc) where++import MyLib ()++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ tests/projects/cabal-with-custom-setup-old/b/tests/Main.hs view
@@ -0,0 +1,3 @@+module Main where++main = putStrLn "Not implemented"
+ tests/projects/cabal-with-custom-setup-old/cabal.project view
@@ -0,0 +1,5 @@+packages:+ a-with-custom/+ b/++allow-newer: base, containers
+ tests/projects/cabal-with-custom-setup/a-with-custom/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/projects/cabal-with-custom-setup/a-with-custom/a-with-custom.cabal view
@@ -0,0 +1,15 @@+cabal-version: 3.0+name: a-with-custom+version: 0.1.0.0+build-type: Custom++custom-setup+ setup-depends:+ Cabal,+ base++library+ exposed-modules: MyLib+ build-depends: base+ hs-source-dirs: src+ default-language: Haskell2010
+ tests/projects/cabal-with-custom-setup/a-with-custom/src/MyLib.hs view
@@ -0,0 +1,4 @@+module MyLib (someFunc) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ tests/projects/cabal-with-custom-setup/b/b.cabal view
@@ -0,0 +1,24 @@+cabal-version: 3.0+name: b+version: 0.1.0.0+-- synopsis:+-- description:+license: NONE+author: fendor+maintainer: fendor@posteo.de+-- copyright:+build-type: Simple+extra-doc-files: CHANGELOG.md+-- extra-source-files:++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: B+ -- other-modules:+ -- other-extensions:+ build-depends: base, a-with-custom+ hs-source-dirs: src+ default-language: Haskell2010
+ tests/projects/cabal-with-custom-setup/b/src/B.hs view
@@ -0,0 +1,6 @@+module B (someFunc) where++import MyLib ()++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ tests/projects/cabal-with-custom-setup/cabal.project view
@@ -0,0 +1,5 @@+packages:+ a-with-custom/+ b/++allow-newer: base, containers
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