diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # ChangeLog hie-bios +## 2026-06-30 - 0.20.0 + +* Hide LoadMode in TestM ([#516](https://github.com/haskell/hie-bios/pull/516)) +* "componentsToLoad" field ([#515](https://github.com/haskell/hie-bios/pull/515)) +* Fail hard if component(s) field have wrong type ([#513](https://github.com/haskell/hie-bios/pull/513)) +* Allow to build with GHC 10.1 ([#510](https://github.com/haskell/hie-bios/pull/510)) +* New Load Modes for upfront loading of cradle/project ([#508](https://github.com/haskell/hie-bios/pull/508)) + * Implement full project loading + ## 2026-04-15 - 0.19.0 * Pass --builddir to avoid clobbering dist-newstyle ([#503](https://github.com/haskell/hie-bios/pull/503)) 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,275 @@ -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.20.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 +extra-source-files: + README.md + tests/configs/*.yaml + tests/projects/cabal-with-ghc-and-project/cabal-with-ghc.cabal + tests/projects/cabal-with-ghc-and-project/cabal.project.extra + tests/projects/cabal-with-ghc-and-project/hie.yaml + tests/projects/cabal-with-ghc-and-project/src/MyLib.hs + tests/projects/cabal-with-ghc/cabal-with-ghc.cabal + tests/projects/cabal-with-ghc/cabal.project + tests/projects/cabal-with-ghc/hie.yaml + tests/projects/cabal-with-ghc/src/MyLib.hs + tests/projects/cabal-with-project/cabal-with-project.cabal + tests/projects/cabal-with-project/cabal.project.extra + tests/projects/cabal-with-project/hie.yaml + tests/projects/cabal-with-project/src/MyLib.hs + tests/projects/deps-bios-new/A.hs + tests/projects/deps-bios-new/B.hs + tests/projects/deps-bios-new/hie-bios.sh + tests/projects/deps-bios-new/hie.yaml + tests/projects/failing-bios-ghc/A.hs + tests/projects/failing-bios-ghc/B.hs + tests/projects/failing-bios-ghc/hie.yaml + tests/projects/failing-bios/A.hs + tests/projects/failing-bios/B.hs + tests/projects/failing-bios/hie.yaml + tests/projects/failing-cabal/failing-cabal.cabal + tests/projects/failing-cabal/hie.yaml + tests/projects/failing-cabal/MyLib.hs + tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/app/Main.hs + tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/multi-repl-cabal-fail.cabal + tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/src/Fail.hs + tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/src/Lib.hs + tests/projects/failing-multi-repl-cabal-project/NotInPath.hs + tests/projects/failing-stack/failing-stack.cabal + tests/projects/failing-stack/hie.yaml + tests/projects/failing-stack/src/Lib.hs + tests/projects/implicit-cabal-deep-project/cabal.project + tests/projects/implicit-cabal-deep-project/foo/foo.cabal + tests/projects/implicit-cabal-deep-project/foo/Main.hs + tests/projects/implicit-cabal-deep-project/implicit-cabal-deep-project.cabal + tests/projects/implicit-cabal-deep-project/Main.hs + tests/projects/implicit-cabal-deep-project/README + tests/projects/implicit-cabal-no-project/implicit-cabal-no-project.cabal + tests/projects/implicit-cabal-no-project/Main.hs + tests/projects/implicit-cabal/cabal.project + tests/projects/implicit-cabal/implicit-cabal.cabal + tests/projects/implicit-cabal/Main.hs + tests/projects/implicit-stack-multi/implicit-stack-multi.cabal + tests/projects/implicit-stack-multi/Main.hs + tests/projects/implicit-stack-multi/other-package/Main.hs + tests/projects/implicit-stack-multi/other-package/other-package.cabal + tests/projects/implicit-stack/implicit-stack.cabal + tests/projects/implicit-stack/Main.hs + tests/projects/monorepo-cabal/A/A.cabal + tests/projects/monorepo-cabal/A/Main.hs + tests/projects/monorepo-cabal/B/B.cabal + tests/projects/monorepo-cabal/B/MyLib.hs + tests/projects/monorepo-cabal/cabal.project + tests/projects/monorepo-cabal/hie.yaml + tests/projects/multi-cabal-with-project/appA/appA.cabal + tests/projects/multi-cabal-with-project/appA/src/Lib.hs + tests/projects/multi-cabal-with-project/appB/appB.cabal + tests/projects/multi-cabal-with-project/appB/src/Lib.hs + tests/projects/multi-cabal-with-project/cabal.project.extra + tests/projects/multi-cabal-with-project/hie.yaml + tests/projects/multi-cabal/app/Main.hs + tests/projects/multi-cabal/cabal.project + tests/projects/multi-cabal/hie.yaml + tests/projects/multi-cabal/multi-cabal.cabal + tests/projects/multi-cabal/src/Lib.hs + tests/projects/multi-direct/A.hs + tests/projects/multi-direct/B.hs + tests/projects/multi-direct/hie.yaml + tests/projects/multi-stack-with-yaml/appA/appA.cabal + tests/projects/multi-stack-with-yaml/appA/src/Lib.hs + tests/projects/multi-stack-with-yaml/appB/appB.cabal + tests/projects/multi-stack-with-yaml/appB/src/Lib.hs + tests/projects/multi-stack-with-yaml/hie.yaml + tests/projects/multi-stack/app/Main.hs + tests/projects/multi-stack/cabal.project + tests/projects/multi-stack/hie.yaml + tests/projects/multi-stack/multi-stack.cabal + tests/projects/multi-stack/src/Lib.hs + tests/projects/nested-cabal/cabal.project + tests/projects/nested-cabal/hie.yaml + tests/projects/nested-cabal/MyLib.hs + tests/projects/nested-cabal/nested-cabal.cabal + tests/projects/nested-cabal/sub-comp/Lib.hs + tests/projects/nested-cabal/sub-comp/sub-comp.cabal + tests/projects/nested-stack/hie.yaml + tests/projects/nested-stack/MyLib.hs + tests/projects/nested-stack/nested-stack.cabal + tests/projects/nested-stack/sub-comp/Lib.hs + tests/projects/nested-stack/sub-comp/sub-comp.cabal + tests/projects/simple-bios-ghc/A.hs + tests/projects/simple-bios-ghc/B.hs + tests/projects/simple-bios-ghc/hie-bios.sh + tests/projects/simple-bios-ghc/hie.yaml + tests/projects/simple-bios-shell/A.hs + tests/projects/simple-bios-shell/B.hs + tests/projects/simple-bios-shell/hie.yaml + tests/projects/simple-bios/A.hs + tests/projects/simple-bios/B.hs + tests/projects/simple-bios/hie-bios-deps.sh + tests/projects/simple-bios/hie-bios.sh + tests/projects/simple-bios/hie.yaml + tests/projects/simple-cabal/A.hs + tests/projects/simple-cabal/B.hs + tests/projects/simple-cabal/cabal.project + tests/projects/simple-cabal/hie.yaml + tests/projects/simple-cabal/simple-cabal.cabal + tests/projects/simple-direct/A.hs + tests/projects/simple-direct/B.hs + tests/projects/simple-direct/hie.yaml + tests/projects/simple-stack/A.hs + tests/projects/simple-stack/B.hs + tests/projects/simple-stack/cabal.project + tests/projects/simple-stack/hie.yaml + tests/projects/simple-stack/simple-stack.cabal + "tests/projects/space stack/A.hs" + "tests/projects/space stack/B.hs" + "tests/projects/space stack/hie.yaml" + "tests/projects/space stack/stackproj.cabal" + tests/projects/stack-with-yaml/app/Main.hs + tests/projects/stack-with-yaml/hie.yaml + tests/projects/stack-with-yaml/src/Lib.hs + tests/projects/stack-with-yaml/stack-with-yaml.cabal + tests/projects/symlink-test/a/A.hs + tests/projects/symlink-test/hie.yaml + wrappers/cabal + wrappers/cabal-with-repl + wrappers/cabal-with-repl.hs + wrappers/cabal.hs -tested-with: GHC ==9.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, + 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 + base, + co-log-core, + directory, + extra, + filepath, + ghc, + hie-bios, + prettyprinter, + 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/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 @@ -58,6 +58,7 @@ import HIE.Bios.Cradle.Cabal as Cabal import HIE.Bios.Cradle.Resolved import HIE.Bios.Cradle.ProgramVersions +import Data.List.Extra (nubOrd) ---------------------------------------------------------------- @@ -94,11 +95,13 @@ loadCradleWithOpts :: (Yaml.FromJSON b, Show a) => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> IO (Cradle a) loadCradleWithOpts l buildCustomCradle wfile = do cradleConfig <- readCradleConfig wfile + l <& WithSeverity (LogAny $ T.pack $ "Cradle Config: " ++ show cradleConfig) Debug getCradle l buildCustomCradle (cradleConfig, takeDirectory wfile) getCradle :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> (CradleConfig b, FilePath) -> IO (Cradle a) getCradle l buildCustomCradle (cc, wdir) = do rcs <- canonicalizeResolvedCradles wdir cs + liftIO $ l <& WithSeverity (LogAny . T.pack $ "Resolved Cradles " ++ show ((fmap . fmap) (const ()) rcs)) Debug resolvedCradlesToCradle l buildCustomCradle wdir rcs where cs = resolveCradleTree wdir cc @@ -126,10 +129,11 @@ versions <- makeVersions logger root run_ghc_cmd let rcs = ResolvedCradles root cs versions cradleActions = [ (c, resolveCradleAction logger buildCustomCradle rcs root c) | c <- cs ] - err_msg fp + err_msg (TargetWithContext fp fps) = ["Multi Cradle: No prefixes matched" , "pwd: " ++ root , "filepath: " ++ fp + , "context: " ++ intercalate ", " fps , "prefixes:" ] ++ [show (prefix pf, actionName cc) | (pf, cc) <- cradleActions] pure $ Cradle @@ -137,12 +141,12 @@ , cradleLogger = logger , cradleOptsProg = CradleAction { actionName = multiActionName - , runCradle = \fp prev -> do - absfp <- makeAbsolute fp + , runCradle = \fpc prev -> do + absfp <- makeAbsolute (targetFilePath fpc) case selectCradle (prefix . fst) absfp cradleActions of Just (rc, act) -> do - addActionDeps (cradleDeps rc) <$> runCradle act fp prev - Nothing -> return $ CradleFail $ CradleError [] ExitSuccess (err_msg fp) [fp] + addActionDeps (cradleDeps rc) <$> runCradle act fpc prev + Nothing -> return $ CradleFail $ CradleError [] ExitSuccess (err_msg fpc) (targetFilePath fpc: targetContext fpc) , runGhcCmd = run_ghc_cmd } } @@ -184,20 +188,20 @@ resolveCradleAction :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> CradleAction a -resolveCradleAction l buildCustomCradle cs root cradle = addLoadStyleLogToCradleAction $ +resolveCradleAction l buildCustomCradle cs root cradle = addLoadModeLogToCradleAction $ case concreteCradle cradle of ConcreteCabal t -> cabalCradle l cs root (cabalComponent t) (projectConfigFromMaybe root (cabalProjectFile t)) - ConcreteStack t -> stackCradle l root (stackComponent t) (projectConfigFromMaybe root (stackYaml t)) + 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 +233,9 @@ where maybeItsBios = (\wdir -> (Bios (Program $ wdir ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir fp - maybeItsStack = stackExecutable >> (Stack $ StackType Nothing Nothing,) <$> stackWorkDir fp + maybeItsStack = stackExecutable >> (Stack $ StackType Nothing Nothing Nothing,) <$> stackWorkDir fp - maybeItsCabal = (Cabal $ CabalType Nothing Nothing,) <$> cabalWorkDir fp + maybeItsCabal = (Cabal $ CabalType Nothing Nothing Nothing,) <$> cabalWorkDir fp -- maybeItsObelisk = (Obelisk,) <$> obeliskWorkDir fp @@ -357,7 +361,7 @@ = CradleAction { actionName = Types.Direct , runCradle = \_ loadStyle -> do - logCradleHasNoSupportForLoadWithContext l loadStyle "direct" + logCradleHasNoSupportForLoadFileWithContext l loadStyle "direct" return (CradleSuccess (ComponentOptions (args ++ argDynamic) wdir [])) , runGhcCmd = runGhcCmdOnPath l wdir } @@ -379,11 +383,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 +411,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 +497,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 +518,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 +554,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 + 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 +722,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 @@ -137,26 +137,28 @@ 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 + (cabalArgs, loadingFiles, extraDeps) <- processCabalLoadMode l cradles projectFile workDir mc fp determinedLoadMode cabalFeatures <- determineCabalLoadFeature progVersions let @@ -255,22 +257,29 @@ cabalProc <- cabalExecGhc l vs projectFile wdir args Process.readProcessWithCwd' l cabalProc "" -processCabalLoadStyle :: MonadIO m => LogAction IO (WithSeverity Log) -> ResolvedCradles a -> CradleProjectConfig -> [Char] -> Maybe FilePath -> [Char] -> LoadStyle -> m ([FilePath], [FilePath], [FilePath]) -processCabalLoadStyle l cradles projectFile workDir mc fp loadStyle = do - let fpModule = fromMaybe (fixTargetPath fp) mc +data LoadUnits = Inferred | FromCradle + deriving Eq + +processCabalLoadMode :: MonadIO m => LogAction IO (WithSeverity Log) -> ResolvedCradles a -> CradleProjectConfig -> [Char] -> Maybe FilePath -> TargetWithContext -> LoadMode -> m ([FilePath], [FilePath], [FilePath]) +processCabalLoadMode l cradles projectFile workDir mc fpc loadStyle = do (cabalArgs, loadingFiles, extraDeps) <- case loadStyle of LoadFile -> pure ([fpModule], [fp], []) - LoadWithContext fps -> do + LoadFileWithContext -> do + let fps = targetContext fpc (modPairs, mergedDeps) <- moduleFilesFromSameProject fps let allModPairs = nubOrd $ (fpModule, fp) : modPairs allModules = nubOrd $ fmap fst allModPairs allFiles = nubOrd $ fmap snd allModPairs pure (["--enable-multi-repl"] ++ allModules, allFiles, mergedDeps) + LoadUnitsInferred -> loadUnits Inferred + LoadUnitsFromCradle -> loadUnits FromCradle - liftIO $ l <& 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) 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. @@ -295,6 +304,58 @@ let modPairs = [ (fromMaybe (fixTargetPath file) old_mc, file) | (file, _, _, old_mc) <- selected ] pure (modPairs, mergedDeps) + + cabalComponentsFromSameProject :: MonadIO m => Maybe [String] -> m ([String],[FilePath]) + cabalComponentsFromSameProject mToLoad = do + + let selected = + [ (comp, prefix rc, depsYaml) + | rc@(ResolvedCradle {concreteCradle = ConcreteCabal ct, cradleDeps = depsYaml}) <- (resolvedCradles cradles) + , Just comp <- [cabalComponent ct] + , maybe True (comp `elem`) mToLoad + , (projectConfigFromMaybe (cradleRoot cradles) (cabalProjectFile ct)) == projectFile + ] + let compDirs = nubOrd $ [dir | (_,dir,_) <- selected] + dynDeps <- concatMapM (liftIO . cabalCradleDependenciesEnclosing projectFile (cradleRoot cradles)) compDirs + let mergedDeps = nubOrd $ dynDeps ++ concat [ depsYaml | (_, _, depsYaml) <- selected ] + pure ([comp | (comp,_,_) <- selected], mergedDeps) + + loadUnits whichUnits0 = do + let + componentsToLoad = do + guard (whichUnits0 == FromCradle) + nubOrd <$> mconcat + [ cs + | ResolvedCradle{concreteCradle = ConcreteCabal + (CabalType {cabalComponentsToLoad = cs})} <- resolvedCradles cradles ] + + -- compDeps includes the .cabal files of the specified components (if the prefixes are there and accurate) + -- These are used as dependencies for both Inferred and FromCradle modes. + -- They might not be accurate for `Inferred`, but we have no easy way to query the cabal project for the complete set. + (cradleComponents,compDeps) <- cabalComponentsFromSameProject componentsToLoad + let + whichUnits + | Just units <- componentsToLoad + = (whichUnits0, units) + -- Note we default to Inferred only if componentsToLoad is not declared. + | null cradleComponents = (Inferred , []) + | otherwise = (whichUnits0, cradleComponents) + + let fps = targetContext fpc + (modPairs, mergedDeps0) <- moduleFilesFromSameProject fps + let allModPairs = nubOrd $ (fpModule, fp) : modPairs + allModules = nubOrd $ fmap fst allModPairs + allFiles = nubOrd $ fmap snd allModPairs + let mergedDeps = mergedDeps0 ++ compDeps + let compArgs = case whichUnits of + (Inferred,_) -> enableFlags ++ ["all"] + where + enableFlags = case projectFile of + NoExplicitConfig + -> ["--enable-tests","--enable-benchmarks"] + _ -> [] + (FromCradle,units) -> units + pure (["--enable-multi-repl"] ++ compArgs ++ allModules, allFiles, mergedDeps) cabalLoadFilesWithRepl :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> [String] -> CradleLoadResultT IO CreateProcess cabalLoadFilesWithRepl l projectFile workDir args = do 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(..) @@ -21,7 +22,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 +32,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, 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 @@ -37,7 +44,6 @@ -> ComponentOptions -> m [G.Target] initSession' workAroundThreadUnsafety ComponentOptions {..} = do - df <- G.getSessionDynFlags -- Create a unique folder per set of different GHC options, assuming that each different set of -- GHC options will create incompatible interface files. let @@ -45,22 +51,69 @@ 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 - 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. - ) + cache_dir <- liftIO $ makeAbsolute =<< getCacheDir opts_hash - let targets' = makeTargetsAbsolute componentRoot targets + -- Plan: + -- - Extract `-unit @resp_file` options if present + -- - Add the user specified options to a fresh GHC session + -- - Make all dflags absolute + -- - Set flags for interactive session + -- - Reconstruct targets and make them absolute + + let (units,rest) = extractUnits componentOptions + + let liftGhc m = do + env <- G.getSession + s <- liftIO (newIORef env) + x <- liftIO $ G.reflectGhc m (G.Session s) + G.setSession =<< liftIO (readIORef s) + pure x + let + setFlags df'' = + void $ G.setSessionDynFlags + (disableOptimisation -- Compile with -O0 as we are not going to produce object files. + $ setIgnoreInterfacePragmas -- Ignore any non-essential information in interface files such as unfoldings changing. + $ writeInterfaceFiles (Just cache_dir) -- Write interface files to the cache + $ setVerbosity 0 -- Set verbosity to zero just in case the user specified `-vx` in the options. + $ Gap.setWayDynamicIfHostIsDynamic -- Add dynamic way if GHC is built with dynamic linking + $ setLinkerOptions df'' -- Set `-fno-code` to avoid generating object files, unless we have to. + ) + + targets <- case NE.nonEmpty units of + Nothing -> do + (df',targets) <- addCmdOpts componentOptions =<< G.getSessionDynFlags + setFlags $ makeDynFlagsAbsolute componentRoot df' + pure targets + Just ne_units -> do + logger <- Gap.getLogger <$> G.getSession + df <- G.getSessionDynFlags + -- leftovers won't have targets when units are present. + (df', _leftovers, _warns) <- Gap.parseDynamicFlags logger df (map G.noLoc rest) + setFlags $ makeDynFlagsAbsolute componentRoot df' + + hs_srcs <- liftGhc $ Gap.initMulti ne_units (\ _ _ _ _ -> return ()) + + G.modifySession $ G.hscUpdateHUG $ fmap (\ ue -> ue {G.homeUnitEnv_dflags = makeDynFlagsAbsolute componentRoot (G.homeUnitEnv_dflags ue)}) + + -- This should be an enforced invariant. + G.modifySession $ \ hsc_env -> G.hscSetActiveUnitId (G.ue_current_unit $ G.hsc_unit_env hsc_env) hsc_env + + mapM (\(src, uid, phase) -> G.guessTarget src uid phase) hs_srcs + + let mkTgtAbs env tgt = tgt {G.targetId = makeTargetIdAbsolute wdir (G.targetId tgt)} + where + wdir = fromMaybe componentRoot $ + G.workingDirectory + . G.homeUnitEnv_dflags . G.ue_findHomeUnitEnv uid + $ hsc_unit_env env + uid = G.targetUnitId tgt + + env <- G.getSession + let targets' = map (mkTgtAbs env) targets + -- Unset the default log action to avoid output going to stdout. Gap.unsetLogAction + return targets' ---------------------------------------------------------------- @@ -145,7 +198,15 @@ setHiDir :: FilePath -> G.DynFlags -> G.DynFlags setHiDir f d = d { G.hiDir = Just f} +extractUnits :: [String] -> ([String], [String]) +extractUnits = go [] [] + where + -- TODO: we should likely use the 'processCmdLineP' instead + go units rest ("-unit" : x : xs) = go (x : units) rest xs + go units rest (x : xs) = go units (x : rest) xs + go units rest [] = (reverse units, reverse rest) + -- | Interpret and set the specific command line options. -- A lot of this code is just copied from ghc/Main.hs -- It would be good to move this code into a library module so we can just use it @@ -174,6 +235,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 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/Types.hs b/src/HIE/Bios/Types.hs --- a/src/HIE/Bios/Types.hs +++ b/src/HIE/Bios/Types.hs @@ -102,14 +102,20 @@ | LogProcessOutput String | LogCreateProcessRun CreateProcess | LogProcessRun FilePath [FilePath] - | LogRequestedCradleLoadStyle !T.Text !LoadStyle - | LogComputedCradleLoadStyle !T.Text !LoadStyle - | LogLoadWithContextUnsupported !T.Text !(Maybe T.Text) + | LogRequestedCradleLoadMode !T.Text !TargetWithContext !LoadMode + | LogComputedCradleLoadMode !T.Text !TargetWithContext !LoadMode + | LogLoadModeUnsupported !T.Text LoadMode !(Maybe T.Text) | LogCabalLoad !FilePath !(Maybe String) ![FilePath] ![FilePath] | LogCabalLibraryTooOld [String] | LogCabalPath !T.Text deriving (Show) +instance Pretty LoadMode where + pretty = viaShow + +instance Pretty TargetWithContext where + pretty (TargetWithContext fp fps) = pretty fp <> list (map pretty fps) + instance Pretty Log where pretty (LogAny s) = pretty s pretty (LogProcessOutput s) = pretty s @@ -129,21 +135,26 @@ ] 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 @@ -156,8 +167,24 @@ "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 +192,7 @@ -- will configure the whole component the file target belongs to, and produce -- component options to load the component, which is the minimal unit of code in cabal repl. -- A 'default' cradle, on the other hand, will only load the given filepath. - | LoadWithContext [FilePath] + | LoadFileWithContext -- ^ Give a cradle additional context for loading a file target. -- -- The context instructs the cradle to load the file target, while also loading @@ -173,12 +200,14 @@ -- This is useful for cradles that support loading multiple code units at once, -- e.g. cabal cradles can use the 'multi-repl' feature to set up a multiple home unit -- session in GHC. - deriving (Show, Eq, Ord) + | LoadUnitsInferred + | LoadUnitsFromCradle + deriving (Eq,Ord,Enum,Bounded,Show) data CradleAction a = CradleAction { actionName :: ActionName a -- ^ Name of the action. - , runCradle :: FilePath -> LoadStyle -> IO (CradleLoadResult ComponentOptions) + , runCradle :: TargetWithContext -> LoadMode -> IO (CradleLoadResult ComponentOptions) -- ^ Options to compile the given file with. , runGhcCmd :: [String] -> IO (CradleLoadResult String) -- ^ Executes the @ghc@ binary that is usually used to diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -4,7 +4,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} -module Main where +module Main (main) where import Utils @@ -17,11 +17,12 @@ import HIE.Bios import HIE.Bios.Cradle import HIE.Bios.Cradle.Cabal (cabalBuildDir) -import Control.Monad (forM_) +import HIE.Bios.Types (LoadMode(..)) +import Control.Monad (forM_, forM, unless) import Control.Monad.Extra (unlessM) import Control.Monad.IO.Class import Data.Foldable (for_) -import Data.List ( sort, isPrefixOf ) +import Data.List ( sort, isPrefixOf, isInfixOf, tails ) import Data.Typeable import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import System.Directory @@ -29,6 +30,8 @@ import System.Info.Extra (isWindows) import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout) import qualified HIE.Bios.Ghc.Gap as Gap +import HIE.Bios.Cradle.Utils (expandGhcOptionResponseFile) +import HIE.Bios.Environment (extractUnits) argDynamic :: [String] @@ -89,7 +92,7 @@ assertCradle isMultiCradle step "Attempt to load symlinked module A" do - loadComponentOptions "./a/A.hs" + loadComponentOptions "./a/A.hs" [] assertComponentOptions $ \opts -> componentOptions opts `shouldMatchList` ["a"] <> argDynamic @@ -103,7 +106,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 "./b/A.hs" [] assertComponentOptions $ \opts -> componentOptions opts `shouldMatchList` ["b"] <> argDynamic @@ -117,7 +120,7 @@ liftIO $ createDirectoryLink (rooted "./a") (rooted "./c") liftIO $ unlessM (doesFileExist $ rooted "c/A.hs") $ assertFailure "Test invariant broken, this file must exist." - loadComponentOptions "./c/A.hs" + loadComponentOptions "./c/A.hs" [] assertLoadNone ] @@ -126,7 +129,7 @@ [ biosTestCase "failing-bios" $ runTestEnv "./failing-bios" $ do initCradle "B.hs" assertCradle isBiosCradle - loadComponentOptions "B.hs" + loadComponentOptions "B.hs" [] assertCradleError $ \CradleError {..} -> do cradleErrorExitCode @?= ExitFailure 1 cradleErrorDependencies `shouldMatchList` ["hie.yaml"] @@ -154,7 +157,7 @@ biosCradleDeps fp deps = do initCradle fp assertCradle isBiosCradle - loadComponentOptions fp + loadComponentOptions fp [] assertComponentOptions $ \opts -> do deps @?= componentDependencies opts @@ -172,13 +175,13 @@ cabalTestCases :: ToolDependency -> [TestTree] cabalTestCases extraGhcDep = [ - biosTestCase "failing-cabal" $ runTestEnv "./failing-cabal" $ do - cabalAttemptLoad "MyLib.hs" + biosTestCaseAll "failing-cabal" $ runTestEnv "./failing-cabal" $ do + attemptCabalSingleTargetLoad "MyLib.hs" assertCradleError (\CradleError {..} -> do cradleErrorExitCode @?= ExitFailure 1 cradleErrorDependencies `shouldMatchList` ["failing-cabal.cabal", "cabal.project", "cabal.project.local"]) - , biosTestCase "failing-cabal-multi-repl-with-shrink-error-files" $ runTestEnv "./failing-multi-repl-cabal-project" $ do - cabalAttemptLoadFiles "multi-repl-cabal-fail/app/Main.hs" ["multi-repl-cabal-fail/src/Lib.hs", "multi-repl-cabal-fail/src/Fail.hs", "NotInPath.hs"] + , biosTestCaseMulti "failing-cabal-multi-repl-with-shrink-error-files" $ runTestEnv "./failing-multi-repl-cabal-project" $ do + attemptCabalLoad "multi-repl-cabal-fail/app/Main.hs" ["multi-repl-cabal-fail/src/Lib.hs", "multi-repl-cabal-fail/src/Fail.hs", "NotInPath.hs"] root <- askRoot multiSupported <- isCabalMultipleCompSupported' if multiSupported @@ -190,15 +193,15 @@ (makeRelative root <$> cradleErrorLoadingFiles) `shouldMatchList` ["multi-repl-cabal-fail/app/Main.hs","multi-repl-cabal-fail/src/Fail.hs","multi-repl-cabal-fail/src/Lib.hs"]) else assertLoadSuccess >>= \ComponentOptions {} -> do return () - , biosTestCase "simple-cabal" $ runTestEnv "./simple-cabal" $ do + , biosTestCaseAll "simple-cabal" $ runTestEnv "./simple-cabal" $ do testDirectoryM isCabalCradle "B.hs" - , biosTestCase "build-dir" $ runTestEnv "./simple-cabal" $ do + , biosTestCaseMulti "build-dir" $ runTestEnv "./simple-cabal" $ do initCradle "B.hs" assertCradle isCabalCradle root <- askRoot buildDir <- liftIO $ cabalBuildDir root -- use --multi-repl, as that was the codepath with the bug - loadFileGhcMultiStyle "B.hs" [] + loadFileGhc "B.hs" [] liftIO $ do -- Check we aren't trampling over dist-newstyle distNewstyleExists <- doesDirectoryExist (root "dist-newstyle") @@ -206,30 +209,50 @@ -- 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" + , 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' if multiSupported then do - loadComponentOptionsMultiStyle "sub-comp/Lib.hs" ["MyLib.hs"] + loadComponentOptions "sub-comp/Lib.hs" ["MyLib.hs"] assertComponentOptions $ \opts -> do -- Expect both the main component's cabal file and the enclosing cabal for the extra file, -- plus project files. @@ -241,17 +264,17 @@ ] else do -- On older cabal/ghc combos, multi-repl isn't supported; just ensure load succeeds. - loadComponentOptions "sub-comp/Lib.hs" + loadComponentOptions "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' if multiSupported then do - loadComponentOptionsMultiStyle "MyLib.hs" ["sub-comp/Lib.hs"] + loadComponentOptions "MyLib.hs" ["sub-comp/Lib.hs"] assertComponentOptions $ \opts -> do componentDependencies opts `shouldMatchList` [ "nested-cabal.cabal" @@ -260,27 +283,29 @@ , "cabal.project.local" ] else do - loadComponentOptions "MyLib.hs" + loadComponentOptions "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" , {- issue https://github.com/mpickering/hie-bios/issues/200 -} - biosTestCase "monorepo-cabal" $ runTestEnv "./monorepo-cabal" $ do + biosTestCaseAll "monorepo-cabal" $ runTestEnv "./monorepo-cabal" $ do testDirectoryM isCabalCradle "A/Main.hs" testDirectoryM isCabalCradle "B/MyLib.hs" , testGroup "Implicit cradle tests" $ - [ biosTestCase "implicit-cabal" $ runTestEnv "./implicit-cabal" $ do + [ biosTestCaseAll "implicit-cabal" $ runTestEnv "./implicit-cabal" $ do testImplicitDirectoryM isCabalCradle "Main.hs" - , biosTestCase "implicit-cabal-no-project" $ runTestEnv "./implicit-cabal-no-project" $ do + , biosTestCaseAll "implicit-cabal-no-project" $ runTestEnv "./implicit-cabal-no-project" $ do testImplicitDirectoryM isCabalCradle "Main.hs" - , biosTestCase "implicit-cabal-deep-project" $ runTestEnv "./implicit-cabal-deep-project" $ do + , biosTestCaseAll "implicit-cabal-deep-project" $ runTestEnv "./implicit-cabal-deep-project" $ do testImplicitDirectoryM isCabalCradle "foo/Main.hs" + , biosTestCase "implicit-cabal-deep-project-with-context" $ runTestModeEnv "./implicit-cabal-deep-project" LoadFileWithContext $ do + testImplicitDirectoryWithContextM isCabalCradle "foo/Main.hs" ["Main.hs"] ] , testGroupWithDependency extraGhcDep - [ biosTestCase "Appropriate ghc and libdir" $ runTestEnvLocal "./cabal-with-ghc" $ do + [ biosTestCaseAll "Appropriate ghc and libdir" $ runTestEnv "./cabal-with-ghc" $ do initCradle "src/MyLib.hs" assertCradle isCabalCradle loadRuntimeGhcLibDir @@ -288,32 +313,27 @@ loadRuntimeGhcVersion assertGhcVersionIs extraGhcVersion step "Find Component Options" - loadComponentOptions "src/MyLib.hs" + loadComponentOptions "src/MyLib.hs" [] _ <- assertLoadSuccess pure () ] , testGroup "Cabal cabalProject" - [ biosTestCase "cabal-with-project, options propagated" $ runTestEnv "cabal-with-project" $ do - opts <- cabalLoadOptions "src/MyLib.hs" - liftIO $ do - "-O2" `elem` componentOptions opts - @? "Options must contain '-O2'" - , biosTestCase "cabal-with-project, load" $ runTestEnv "cabal-with-project" $ do + [ biosTestCaseAll "cabal-with-project, options propagated" $ runTestEnv "cabal-with-project" $ do + _opts <- cabalLoadOptions "src/MyLib.hs" + assertOptionsContain "-O2" Nothing + , biosTestCaseAll "cabal-with-project, load" $ runTestEnv "cabal-with-project" $ do testDirectoryM isCabalCradle "src/MyLib.hs" - , biosTestCase "multi-cabal-with-project, options propagated" $ runTestEnv "multi-cabal-with-project" $ do - optsAppA <- cabalLoadOptions "appA/src/Lib.hs" - liftIO $ do - "-O2" `elem` componentOptions optsAppA - @? "Options must contain '-O2'" - optsAppB <- cabalLoadOptions "appB/src/Lib.hs" - liftIO $ do - "-O2" `notElem` componentOptions optsAppB - @? "Options must not contain '-O2'" - , biosTestCase "multi-cabal-with-project, load" $ runTestEnv "multi-cabal-with-project" $ do + , biosTestCaseAll "multi-cabal-with-project, options propagated" $ runTestEnv "multi-cabal-with-project" $ do + _optsAppA <- cabalLoadOptions "appA/src/Lib.hs" + assertOptionsContain "-O2" (Just "appA") + , biosTestCaseAll "multi-cabal-with-project, options not propagated" $ runTestEnv "multi-cabal-with-project" $ do + _optsAppB <- cabalLoadOptions "appB/src/Lib.hs" + assertOptionsDoNotContain "-O2" (Just "appB") + , biosTestCaseAll "multi-cabal-with-project, load" $ runTestEnv "multi-cabal-with-project" $ do testDirectoryM isCabalCradle "appB/src/Lib.hs" testDirectoryM isCabalCradle "appB/src/Lib.hs" , testGroupWithDependency extraGhcDep - [ biosTestCase "Honours extra ghc setting" $ runTestEnv "cabal-with-ghc-and-project" $ do + [ biosTestCaseAll "Honours extra ghc setting" $ runTestEnv "cabal-with-ghc-and-project" $ do initCradle "src/MyLib.hs" assertCradle isCabalCradle loadRuntimeGhcLibDir @@ -321,17 +341,17 @@ loadRuntimeGhcVersion assertGhcVersionIs extraGhcVersion step "Find Component Options" - loadComponentOptions "src/MyLib.hs" + loadComponentOptions "src/MyLib.hs" [] _ <- assertLoadSuccess pure () ] - , biosTestCase "force older Cabal version in custom setup" $ runTestEnv "cabal-with-custom-setup" $ do + , biosTestCaseAll "force older Cabal version in custom setup" $ runTestEnv "cabal-with-custom-setup" $ do -- Specifically tests whether cabal 3.16 works as expected with -- an older lib:Cabal version that doesn't support '--with-repl'. -- This test doesn't hurt for other cases as well, so we enable it for -- all configurations. testDirectoryM isCabalCradle "src/MyLib.hs" - , biosTestCase "force older Cabal version in custom setup with multi mode" $ runTestEnv "cabal-with-custom-setup" $ do + , biosTestCaseMulti "force older Cabal version in custom setup with multi mode" $ runTestEnv "cabal-with-custom-setup" $ do -- Specifically tests whether cabal 3.16 works as expected with -- an older lib:Cabal version that doesn't support '--with-repl'. -- This test doesn't hurt for other cases as well, so we enable it for @@ -344,29 +364,85 @@ loadRuntimeGhcVersion assertGhcVersion -- suffices to force loading cabal's `--enable-multi-repl` codepath - loadFileGhcMultiStyle target [] + loadFileGhc target [] + , biosTestCase "multi-cabal-with-load" $ runTestModeEnv "multi-cabal-with-load" LoadUnitsFromCradle $ do + opts <- componentOptions <$> cabalLoadOptions "appA/src/Lib.hs" + liftIO $ do + unless (any ("appA" `isInfixOf`) opts) $ + assertFailure $ "Missing appA: " ++ unwords opts + unless (all (not . ("appB" `isInfixOf`)) opts) $ + assertFailure $ "Included appB: " ++ unwords opts + , biosTestCase "multi-cabal-with-load-inferred" $ runTestModeEnv "multi-cabal-with-load" LoadUnitsInferred $ do + -- LoadUnitsInferred should be unaffected by componentsToLoad + opts <- componentOptions <$> cabalLoadOptions "appA/src/Lib.hs" + liftIO $ do + unless (any ("appA" `isInfixOf`) opts) $ + assertFailure $ "Missing appA: " ++ unwords opts + unless (any ("appB" `isInfixOf`) opts) $ + assertFailure $ "Missing appB: " ++ unwords opts + , biosTestCase "cabal-with-load" $ runTestModeEnv "cabal-with-load" LoadUnitsFromCradle $ do + opts <- componentOptions <$> cabalLoadOptions "appA/src/Lib.hs" + liftIO $ do + unless (any ("appA" `isInfixOf`) opts) $ + assertFailure $ "Missing appA: " ++ unwords opts + unless (all (not . ("appB" `isInfixOf`)) opts) $ + assertFailure $ "Included appB: " ++ unwords opts + , biosTestCase "multi-cabal-with-load-superset" $ runTestModeEnv "multi-cabal-with-load-superset" LoadUnitsFromCradle $ do + opts <- componentOptions <$> cabalLoadOptions "appA/src/Lib.hs" + liftIO $ do + unless (any ("appA" `isInfixOf`) opts) $ + assertFailure $ "Missing appA: " ++ unwords opts + unless (any ("appB" `isInfixOf`) opts) $ + assertFailure $ "Missing appB: " ++ unwords opts ] ] where - cabalAttemptLoad :: FilePath -> TestM () - cabalAttemptLoad fp = do - initCradle fp - assertCradle isCabalCradle - loadComponentOptions fp + attemptCabalSingleTargetLoad fp = attemptCabalLoad fp [] - cabalAttemptLoadFiles :: FilePath -> [FilePath] -> TestM () - cabalAttemptLoadFiles fp fps = do + attemptCabalLoad :: FilePath -> [FilePath] -> TestM () + attemptCabalLoad fp fps = do initCradle fp assertCradle isCabalCradle - loadComponentOptionsMultiStyle fp fps + loadComponentOptions fp fps cabalLoadOptions :: FilePath -> TestM ComponentOptions cabalLoadOptions fp = do initCradle fp assertCradle isCabalCradle - loadComponentOptions fp + loadComponentOptions fp [] assertLoadSuccess +assertOptionsContain :: [Char] -> Maybe String -> TestM () +assertOptionsContain flag munit = do + doesContain <- hasOption flag munit + liftIO $ doesContain @? ("Options must contain '" ++ flag ++ "'") + +assertOptionsDoNotContain :: [Char] -> Maybe String -> TestM () +assertOptionsDoNotContain flag munit = do + doesContain <- hasOption flag munit + liftIO $ not doesContain @? ("Options must not contain '" ++ flag ++ "'") + +hasOption :: [Char] -> Maybe String -> TestM Bool +hasOption flag munit = elem flag <$> do + options <- componentOptions <$> assertLoadSuccess + mode <- askLoadMode + let + common | Nothing <- munit = do + expandGhcOptionResponseFile options + | Just unit <- munit = do + let (units, rest) = extractUnits options + fmap (concat . (rest:)) . forM units $ \ resp_file -> do + unit_flags <- expandGhcOptionResponseFile [resp_file] + if and [ unit `isInfixOf` uid | ("-this-unit-id":uid:_) <- tails unit_flags + ] + then pure unit_flags + else pure [] + liftIO $ case mode of + LoadFile -> return options + LoadFileWithContext -> expandGhcOptionResponseFile options + LoadUnitsFromCradle -> common + LoadUnitsInferred -> common + stackTestCases :: [TestTree] stackTestCases = [ expectFailBecause "stack repl does not fail on an invalid cabal file" $ @@ -380,6 +456,8 @@ , biosTestCase "multi-stack" $ runTestEnv "./multi-stack" $ do {- tests if both components can be loaded -} testDirectoryM isStackCradle "app/Main.hs" testDirectoryM isStackCradle "src/Lib.hs" + , biosTestCaseMulti "multi-stack-multi-modes" $ runTestEnv "./multi-stack" $ do + testDirectoryM isStackCradle "app/Main.hs" , biosTestCase "nested-stack" $ runTestEnv "./nested-stack" $ do stackAttemptLoad "sub-comp/Lib.hs" assertComponentOptions $ \opts -> @@ -396,6 +474,22 @@ {- tests if both components can be loaded -} testDirectoryM isStackCradle "appA/src/Lib.hs" testDirectoryM isStackCradle "appB/src/Lib.hs" + , biosTestCase "multi-stack-with-load" $ runTestModeEnv "multi-stack-with-load" LoadUnitsFromCradle $ do + testDirectoryM isStackCradle "appA/src/LibA.hs" + assertComponentOptions $ \ opts0 -> do + let opts = componentOptions opts0 + unless (any ("appA" `isInfixOf`) opts) $ + assertFailure $ "Missing appA: " ++ unwords opts + unless (all (not . ("appB" `isInfixOf`)) opts) $ + assertFailure $ "Included appB: " ++ unwords opts + , biosTestCase "multi-stack-with-load-inferred" $ runTestModeEnv "multi-stack-with-load" LoadUnitsInferred $ do + testDirectoryM isStackCradle "appA/src/LibA.hs" + assertComponentOptions $ \ opts0 -> do + let opts = componentOptions opts0 + unless (any ("appA" `isInfixOf`) opts) $ + assertFailure $ "Missing appA: " ++ unwords opts + unless (any ("appB" `isInfixOf`) opts) $ + assertFailure $ "Missing appB: " ++ unwords opts , -- Test for special characters in the path for parsing of the ghci-scripts. -- Issue https://github.com/mpickering/hie-bios/issues/162 @@ -403,11 +497,11 @@ testDirectoryM isStackCradle "A.hs" testDirectoryM isStackCradle "B.hs" , testGroup "Implicit cradle tests" - [ biosTestCase "implicit-stack" $ runTestEnv "./implicit-stack" $ + [ biosTestCase "implicit-stack" $ runTestModeEnv "./implicit-stack" LoadFile $ do testImplicitDirectoryM isStackCradle "Main.hs" - , biosTestCase "implicit-stack-multi" $ runTestEnv "./implicit-stack-multi" $ do + , biosTestCase "implicit-stack-multi" $ runTestModeEnv "./implicit-stack-multi" LoadFile $ do testImplicitDirectoryM isStackCradle "Main.hs" - testImplicitDirectoryM isStackCradle "other-package/Main.hs" + testImplicitDirectoryM isStackCradle "other-package/Main.hs" ] ] where @@ -415,7 +509,7 @@ stackAttemptLoad fp = do initCradle fp assertCradle isStackCradle - loadComponentOptions fp + loadComponentOptions fp [] directTestCases :: [TestTree] directTestCases = @@ -456,11 +550,27 @@ infix 1 `shouldMatchList` -biosTestCase :: TestName -> (Bool -> Assertion) -> TestTree +biosTestCase :: TestName -> (TestConfig -> Assertion) -> TestTree biosTestCase name assertion = askOption @VerboseLogging (\case - VerboseLogging verbose -> testCase name (assertion verbose) + VerboseLogging verbose -> + testCaseSteps name (\ stepF -> testWrapper verbose stepF) ) + where + testWrapper verbose stepF = + assertion defConfig{testVerbose=verbose,testStepFunction=stepF} +biosTestCaseMulti :: TestName -> (TestConfig -> Assertion) -> TestTree +biosTestCaseMulti name act = testGroup name $ biosTestsForAllModes [LoadFileWithContext .. ] act + +biosTestCaseAll :: TestName -> (TestConfig -> Assertion) -> TestTree +biosTestCaseAll name act = testGroup name $ biosTestsForAllModes [minBound .. ] act + +biosTestsForAllModes :: [LoadMode] -> (TestConfig -> Assertion) -> [TestTree] +biosTestsForAllModes modes assertion = + [ biosTestCase (show mode) (\ conf -> assertion (conf{testLoadModeConfig=mode})) + | mode <- modes + ] + -- ------------------------------------------------------------------ -- Stack related helper functions -- ------------------------------------------------------------------ @@ -482,6 +592,7 @@ , ("tests" "projects" "implicit-stack-multi", "stack.yaml", ["."]) , ("tests" "projects" "multi-stack-with-yaml", "stack-alt.yaml", ["appA", "appB"]) , ("tests" "projects" "stack-with-yaml", "stack-alt.yaml", ["."]) + , ("tests" "projects" "multi-stack-with-load", "stack.yaml", ["appA", "appB"]) ] stackYaml :: String -> [FilePath] -> String 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, @@ -43,11 +45,9 @@ initCradle, initImplicitCradle, loadComponentOptions, - loadComponentOptionsMultiStyle, loadRuntimeGhcLibDir, loadRuntimeGhcVersion, loadFileGhc, - loadFileGhcMultiStyle, isCabalMultipleCompSupported', -- * Assertion helpers @@ -67,6 +67,7 @@ -- * High-level test helpers testDirectoryM, testImplicitDirectoryM, + testImplicitDirectoryWithContextM, findCradleForModuleM, ) where @@ -94,6 +95,8 @@ import Colog.Core import qualified Data.Text as Text import Data.Function ((&)) +import qualified Control.Exception as C +import System.Environment (lookupEnv) -- --------------------------------------------------------------------------- -- Test configuration and information @@ -105,8 +108,9 @@ { useTemporaryDirectory :: Bool , testProjectRoots :: FilePath , testVerbose :: Bool + , testStepFunction :: String -> IO () + , testLoadModeConfig :: LoadMode } - deriving (Eq, Show, Ord) data TestEnv ext = TestEnv { testCradleType :: Maybe (Cradle ext) @@ -115,26 +119,39 @@ , testGhcVersionResult :: Maybe (CradleLoadResult String) , testRootDir :: FilePath , testLogger :: L.LogAction IO (L.WithSeverity HIE.Log) + , testLoadMode :: LoadMode } defConfig :: TestConfig -defConfig = TestConfig True "./tests/projects" False +defConfig = + TestConfig + { useTemporaryDirectory = True + , testProjectRoots = "./tests/projects" + , testVerbose = False + , testStepFunction = unLogAction logStringStderr + , testLoadModeConfig = LoadFile + } -runTestEnv :: FilePath -> TestM a -> Bool -> IO a -runTestEnv fp act verbose = runTestEnv' defConfig{testVerbose=verbose} fp act +runTestEnv :: FilePath -> TestM a -> TestConfig -> IO a +runTestEnv fp act testConf = runTestEnv' testConf fp act -runTestEnvLocal :: FilePath -> TestM a -> Bool -> IO a -runTestEnvLocal fp act verbose = runTestEnv' defConfig{useTemporaryDirectory = False,testVerbose=verbose} fp act +runTestModeEnv :: FilePath -> LoadMode -> TestM a -> TestConfig -> IO a +runTestModeEnv fp loadMode act testConf = runTestEnv' testConf{testLoadModeConfig=loadMode} fp act +runTestEnvLocal :: FilePath -> TestM a -> TestConfig -> IO a +runTestEnvLocal fp act testConf = runTestEnv' testConf{useTemporaryDirectory = False} fp act + runTestEnv' :: TestConfig -> FilePath -> TestM a -> IO a runTestEnv' config root act = do -- We need to copy over the directory to somewhere outside the source tree -- when we test, since the cabal.project/stack.yaml/hie.yaml file in the root -- of this repository interferes with the test cradles! - let wrapper = + let wrapper r cont = if useTemporaryDirectory config - then withTempCopy - else \r cont -> cont r + then do + mkeep <- lookupEnv "KEEP_TEMP_DIRS" + withTempCopy (mkeep == Just "true") r cont + else cont r mkEnv root' = TestEnv { testCradleType = Nothing @@ -143,13 +160,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,6 +263,9 @@ askLogger :: TestM (L.LogAction IO (L.WithSeverity HIE.Log)) askLogger = gets testLogger +askLoadMode :: TestM LoadMode +askLoadMode = gets testLoadMode + -- --------------------------------------------------------------------------- -- Test setup helpers -- --------------------------------------------------------------------------- @@ -276,6 +297,7 @@ crd <- case mcfg of Just cfg -> liftIO $ loadCradle logger cfg Nothing -> liftIO $ loadImplicitCradle logger a_fp + step $ "Cradle: " ++ show crd setCradle crd initImplicitCradle :: FilePath -> TestM () @@ -286,21 +308,16 @@ crd <- liftIO $ loadImplicitCradle logger a_fp setCradle crd -loadComponentOptions :: FilePath -> TestM () -loadComponentOptions fp = do - a_fp <- normFile fp - crd <- askCradle - step $ "Initialise flags for: " <> fp - clr <- liftIO $ getCompilerOptions a_fp LoadFile crd - setLoadResult clr - -loadComponentOptionsMultiStyle :: FilePath -> [FilePath] -> TestM () -loadComponentOptionsMultiStyle fp fps = do +loadComponentOptions :: FilePath -> [FilePath] -> TestM () +loadComponentOptions fp extraFps = do a_fp <- normFile fp - a_fps <- 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 () @@ -324,32 +341,13 @@ 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 :: FilePath -> [FilePath] -> TestM () +loadFileGhc fp extraFps = do libdir <- askOrLoadLibDir a_fp <- normFile fp stepF <- askStep step "Cradle load" - loadComponentOptionsMultiStyle fp extraFps + loadComponentOptions fp extraFps opts <- assertLoadSuccess liftIO $ G.runGhc (Just libdir) $ do @@ -445,17 +443,20 @@ assertLibDirVersion loadRuntimeGhcVersion assertGhcVersion - loadFileGhc file + loadFileGhc file [] testImplicitDirectoryM :: (Cradle Void -> Bool) -> FilePath -> TestM () -testImplicitDirectoryM cradlePred file = do +testImplicitDirectoryM cradlePred file = testImplicitDirectoryWithContextM cradlePred file [] + +testImplicitDirectoryWithContextM :: (Cradle Void -> Bool) -> FilePath -> [FilePath] -> TestM () +testImplicitDirectoryWithContextM cradlePred file ctxt = do initImplicitCradle file assertCradle cradlePred loadRuntimeGhcLibDir assertLibDirVersion loadRuntimeGhcVersion assertGhcVersion - loadFileGhc file + loadFileGhc file ctxt findCradleForModuleM :: FilePath -> Maybe FilePath -> TestM () findCradleForModuleM fp expected' = do @@ -468,13 +469,21 @@ -- Copy Directory system utilities -- --------------------------------------------------------------------------- -withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a -withTempCopy srcDir f = - withSystemTempDirectory "hie-bios-test" $ \newDir -> do - exists <- doesDirectoryExist srcDir - when exists $ do - copyDir srcDir newDir - f newDir +withTempCopy :: Bool -> FilePath -> (FilePath -> IO a) -> IO a +withTempCopy keep srcDir f = getCanonicalTemporaryDirectory >>= \targetDir -> do + C.bracket + (liftIO (createTempDirectory targetDir template)) + cleanup $ \newDir -> do + exists <- doesDirectoryExist srcDir + when exists $ do + copyDir srcDir newDir + f newDir + where + template = "hie-bios-test" + cleanup dir | keep = return () + | otherwise = (liftIO . ignoringIOErrors . removeDirectoryRecursive) dir + ignoringIOErrors ioe = ioe `C.catch` (\e -> const (return ()) (e :: IOError)) + copyDir :: FilePath -> FilePath -> IO () copyDir src dst = do 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/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