diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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)) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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" diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -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 diff --git a/hie-bios.cabal b/hie-bios.cabal --- a/hie-bios.cabal +++ b/hie-bios.cabal @@ -1,266 +1,292 @@ -Cabal-Version: 2.2 -Name: hie-bios -Version: 0.19.0 -Author: Matthew Pickering , Hannes Siebenhandl -Maintainer: Hannes Siebenhandl -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 , Hannes Siebenhandl +maintainer: Hannes Siebenhandl +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 diff --git a/src/HIE/Bios.hs b/src/HIE/Bios.hs --- a/src/HIE/Bios.hs +++ b/src/HIE/Bios.hs @@ -14,7 +14,11 @@ , CradleError(..) , findCradle , loadCradle + , loadCradleWithConfig , loadImplicitCradle + , loadImplicitCradleWithConfig + , CradleRunConfig(..) + , defaultCradleRunConfig , defaultCradle -- * Compiler Options , ComponentOptions(..) diff --git a/src/HIE/Bios/Config.hs b/src/HIE/Bios/Config.hs --- a/src/HIE/Bios/Config.hs +++ b/src/HIE/Bios/Config.hs @@ -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) diff --git a/src/HIE/Bios/Config/YAML.hs b/src/HIE/Bios/Config/YAML.hs --- a/src/HIE/Bios/Config/YAML.hs +++ b/src/HIE/Bios/Config/YAML.hs @@ -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] } diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -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 () diff --git a/src/HIE/Bios/Cradle/Cabal.hs b/src/HIE/Bios/Cradle/Cabal.hs --- a/src/HIE/Bios/Cradle/Cabal.hs +++ b/src/HIE/Bios/Cradle/Cabal.hs @@ -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) + diff --git a/src/HIE/Bios/Cradle/Resolved.hs b/src/HIE/Bios/Cradle/Resolved.hs --- a/src/HIE/Bios/Cradle/Resolved.hs +++ b/src/HIE/Bios/Cradle/Resolved.hs @@ -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) diff --git a/src/HIE/Bios/Cradle/Utils.hs b/src/HIE/Bios/Cradle/Utils.hs --- a/src/HIE/Bios/Cradle/Utils.hs +++ b/src/HIE/Bios/Cradle/Utils.hs @@ -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 - diff --git a/src/HIE/Bios/Environment.hs b/src/HIE/Bios/Environment.hs --- a/src/HIE/Bios/Environment.hs +++ b/src/HIE/Bios/Environment.hs @@ -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 = diff --git a/src/HIE/Bios/Flags.hs b/src/HIE/Bios/Flags.hs --- a/src/HIE/Bios/Flags.hs +++ b/src/HIE/Bios/Flags.hs @@ -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 diff --git a/src/HIE/Bios/Ghc/Api.hs b/src/HIE/Bios/Ghc/Api.hs --- a/src/HIE/Bios/Ghc/Api.hs +++ b/src/HIE/Bios/Ghc/Api.hs @@ -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 diff --git a/src/HIE/Bios/Ghc/Gap.hs b/src/HIE/Bios/Ghc/Gap.hs --- a/src/HIE/Bios/Ghc/Gap.hs +++ b/src/HIE/Bios/Ghc/Gap.hs @@ -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 diff --git a/src/HIE/Bios/Ghc/Load.hs b/src/HIE/Bios/Ghc/Load.hs --- a/src/HIE/Bios/Ghc/Load.hs +++ b/src/HIE/Bios/Ghc/Load.hs @@ -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 diff --git a/src/HIE/Bios/Internal/Debug.hs b/src/HIE/Bios/Internal/Debug.hs --- a/src/HIE/Bios/Internal/Debug.hs +++ b/src/HIE/Bios/Internal/Debug.hs @@ -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 diff --git a/src/HIE/Bios/Process.hs b/src/HIE/Bios/Process.hs --- a/src/HIE/Bios/Process.hs +++ b/src/HIE/Bios/Process.hs @@ -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) - diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs --- a/src/HIE/Bios/Types.hs +++ b/src/HIE/Bios/Types.hs @@ -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 diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -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 diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -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 diff --git a/tests/Utils.hs b/tests/Utils.hs --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -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 diff --git a/tests/configs/cabal-with-load.yaml b/tests/configs/cabal-with-load.yaml new file mode 100644 --- /dev/null +++ b/tests/configs/cabal-with-load.yaml @@ -0,0 +1,3 @@ +cradle: + cabal: + componentsToLoad: ["lib:hie-bios","parser-tests","some-other"] diff --git a/tests/configs/multi-cabal-with-load.yaml b/tests/configs/multi-cabal-with-load.yaml new file mode 100644 --- /dev/null +++ b/tests/configs/multi-cabal-with-load.yaml @@ -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" diff --git a/tests/configs/multi-stack-with-load.yaml b/tests/configs/multi-stack-with-load.yaml new file mode 100644 --- /dev/null +++ b/tests/configs/multi-stack-with-load.yaml @@ -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" diff --git a/tests/configs/single-components.yaml b/tests/configs/single-components.yaml new file mode 100644 --- /dev/null +++ b/tests/configs/single-components.yaml @@ -0,0 +1,2 @@ +cabal: + components: "exe:t3" diff --git a/tests/configs/stack-with-load.yaml b/tests/configs/stack-with-load.yaml new file mode 100644 --- /dev/null +++ b/tests/configs/stack-with-load.yaml @@ -0,0 +1,3 @@ +cradle: + stack: + componentsToLoad: ["lib:hie-bios","parser-tests","some-other"] diff --git a/tests/projects/cabal-with-custom-setup-old/a-with-custom/Setup.hs b/tests/projects/cabal-with-custom-setup-old/a-with-custom/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup-old/a-with-custom/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/tests/projects/cabal-with-custom-setup-old/a-with-custom/a-with-custom.cabal b/tests/projects/cabal-with-custom-setup-old/a-with-custom/a-with-custom.cabal new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup-old/a-with-custom/a-with-custom.cabal @@ -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 diff --git a/tests/projects/cabal-with-custom-setup-old/a-with-custom/src/MyLib.hs b/tests/projects/cabal-with-custom-setup-old/a-with-custom/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup-old/a-with-custom/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/tests/projects/cabal-with-custom-setup-old/b/b.cabal b/tests/projects/cabal-with-custom-setup-old/b/b.cabal new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup-old/b/b.cabal @@ -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 diff --git a/tests/projects/cabal-with-custom-setup-old/b/src/B.hs b/tests/projects/cabal-with-custom-setup-old/b/src/B.hs new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup-old/b/src/B.hs @@ -0,0 +1,6 @@ +module B (someFunc) where + +import MyLib () + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/tests/projects/cabal-with-custom-setup-old/b/tests/Main.hs b/tests/projects/cabal-with-custom-setup-old/b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup-old/b/tests/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Not implemented" diff --git a/tests/projects/cabal-with-custom-setup-old/cabal.project b/tests/projects/cabal-with-custom-setup-old/cabal.project new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup-old/cabal.project @@ -0,0 +1,5 @@ +packages: + a-with-custom/ + b/ + +allow-newer: base, containers diff --git a/tests/projects/cabal-with-custom-setup/a-with-custom/Setup.hs b/tests/projects/cabal-with-custom-setup/a-with-custom/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup/a-with-custom/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/tests/projects/cabal-with-custom-setup/a-with-custom/a-with-custom.cabal b/tests/projects/cabal-with-custom-setup/a-with-custom/a-with-custom.cabal new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup/a-with-custom/a-with-custom.cabal @@ -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 diff --git a/tests/projects/cabal-with-custom-setup/a-with-custom/src/MyLib.hs b/tests/projects/cabal-with-custom-setup/a-with-custom/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup/a-with-custom/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/tests/projects/cabal-with-custom-setup/b/b.cabal b/tests/projects/cabal-with-custom-setup/b/b.cabal new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup/b/b.cabal @@ -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 diff --git a/tests/projects/cabal-with-custom-setup/b/src/B.hs b/tests/projects/cabal-with-custom-setup/b/src/B.hs new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup/b/src/B.hs @@ -0,0 +1,6 @@ +module B (someFunc) where + +import MyLib () + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/tests/projects/cabal-with-custom-setup/cabal.project b/tests/projects/cabal-with-custom-setup/cabal.project new file mode 100644 --- /dev/null +++ b/tests/projects/cabal-with-custom-setup/cabal.project @@ -0,0 +1,5 @@ +packages: + a-with-custom/ + b/ + +allow-newer: base, containers diff --git a/tests/projects/multi-cabal/multi-cabal.cabal b/tests/projects/multi-cabal/multi-cabal.cabal --- a/tests/projects/multi-cabal/multi-cabal.cabal +++ b/tests/projects/multi-cabal/multi-cabal.cabal @@ -1,4 +1,4 @@ -cabal-version: >=2.0 +cabal-version: 2.0 name: multi-cabal version: 0.1.0.0 build-type: Simple