diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,375 @@ +# Buck2 build system for Haskell projects + +Short summary: this is a [cabal external command][ext] `cabal buck2` +that allows you to use [Buck2](https://buck2.build) as the build +system for your Cabal project. + +# Quick start + +First [download a buck2 +binary](https://buck2.build/docs/getting_started/install/), unpack it +and put it on your `PATH`. + +Then + +``` +cabal install cabal-buck2 +``` + +Then in the root of your project or package: + +``` +git clone https://github.com/simonmar/haskell-buck2.git buck2 +cabal buck2 --enable-tests +``` + +Then you can use `buck2` as the build tool, e.g. + +``` +buck2 build //... +``` + +To build all the components, or + +``` +buck2 test //... +``` + +To run your tests. + +Note that you need to re-run `cabal buck2 --enable-tests` if you +modify the `cabal.project` or any of the `.cabal` files. + +Not all Cabal features are supported - see [limitations](#limitations). + +# Why? + +(skip this section if you know why you want buck2) + +Why might you want to use `buck2` as the build system compared with +just using `cabal`? Well, first off let me be clear that you *still +need Cabal*, because the Buck2 support doesn't know how to solve +package dependencies or build them. So the workflow consists of first +running `cabal buck2` to solve and build the dependencies, but once you've +done that you can switch to `buck2` for building. The idea is that +`buck2` is a more pleasant experience because: + +* It's [faster than Cabal, particularly for rebuilds](#performance). + +* It supports different build modes out of the box: the default is to + build in `dev` mode (unoptimised with dynamic linking) but adding + `-m opt` gives you optimisation and static linking. Note that Cabal + doesn't have a purely dynamic build mode: it always uses `-dynamic-too` + for libraries, which has a significant built-time performance cost. + +* The Buck2 build is extensible. If you have anything that needs to be + generated as part of your build, or any non-standard tooling, then + hooking that up using Buck2 is far easier than Cabal. Furthermore + Buck2 knows how to rebuild things correctly when either the build + system or the code generator components change. + +* It works a lot better than Cabal when you have non-Haskell code (e.g. C/C++ or Rust) in your project, because + * Buck2 understands dependencies between C/C++ source files and header files (Cabal doesn't: [issue #4306](https://github.com/haskell/cabal/issues/4306)), so when you modify a C/C++ header the correct things are rebuilt. + * Buck2 builds C/C++ files in parallel, while Cabal doesn't ([issue #7127](https://github.com/haskell/cabal/issues/7127)) + +* You can use [remote execution and caching](https://buck2.build/docs/users/remote_execution/) (I haven't tried this with `cabal buck2` yet). + +Finally, if you have an existing codebase using Buck2 then this is the +basis of something that could "buckify" Cabal packages to integrate +into your build system. It needs a bit of work to be suitable for that +use case, though: `cabal buck2` builds all the external dependencies +and installs them in the Cabal store, whereas to integrate with an +existing build system you would want to satisfy those external +dependencies from the build system itself. + +# How complete is it? + +I've used it to build a few largish projects, in particular the Cabal +project itself which consists of about 16 packages and a few hundred +source files. It can also build [Glean](https://glean.software), which +has some complex build requirements including custom codegen, FFI & +hsc2hs. + +There are a few [limitations](#limitations), however. + +# What `cabal buck2` does + +You can run `cabal buck2` in a project or a single Cabal package. It +does the following: + +1. Solves the `build-depends` constraints of your package(s) and + builds all the dependencies, much like `cabal build all --only-dependencies` + would. + +2. Generates some files, notably: + + * `BUCK` and `BUCK.cabal.bzl` in each package, these are the Buck2 + build targets + + * `cabal-buck2/autogen` in each package, this is where we put the + files that Cabal autogenerates, such as `cabal_macros.h` and + `Paths_.hs`. + + * `third-party/haskell`: tells Buck2 about all the prebuilt package + dependencies, either in the Cabal store or in GHC's package + DB. In here we also record the GHC version you're using, and the + paths to any tool dependencies. + +# Buck2 quick start + +To build your code: + +``` +buck2 build //... +``` + +The `//...` is Buck2's syntax for "all targets recursively below the +current directory". You can also build specific target(s), for example +`buck2 build cabal-install:cabal` would build the `cabal` target in +the `cabal-install` package. For more details see [Target +Pattern](https://buck2.build/docs/concepts/target_pattern/) in the +Buck2 docs. + +Next you can run your tests: + +``` +buck2 test //... +``` + +# Customising the build + +`cabal buck2` will generate all the `BUCK` files if they don't exist, +but you can also write your own if you want (`cabal buck2` won't +overwrite them). + +The `BUCK` file usually goes in the same directory as your source +files. The targets that `cabal buck2` produces go in the +`BUCK.cabal.bzl` file, and are generated by a call to +`generated_targets()` from the `BUCK` file. This call takes some +arguments that you can use to override or transform the generated +targets - take a look at the comments in the generated code to see +how. + +You can also completely override the generated targets and write a +`BUCK` file with your own rules, while still making use of the +pre-built dependencies that `cabal buck2` produces. For example, the +`BUCK` file for a simple Haskell library might look something like + +``` +load("//buck2:haskell.bzl", "haskell_library") + +haskell_library( + name = "my-package", + srcs = [ + "Some/Module.hs", + ], + packages = [ + "unordered-containers", + ], + visibility = ["PUBLIC"], +) +``` + +and the `BUCK` file for a test might look like + +``` +load("//buck2:haskell.bzl", "haskell_test") + +haskell_test( + name = "my-test", + srcs = { + "Main.hs" : "my-test.hs", + }, + deps = [ + "//:my-package", + ], + packages = [ + "test-framework", + "test-framework-hunit", + "HUnit", + ], +) +``` + +You can find docs on how to write `BUCK` files in the Buck2 docs, e.g. [haskell_library](https://buck2.build/docs/prelude/rules/haskell/haskell_library/). + +# Build modes + +The Buck2 build system has two build modes: + + * `dev`: the default, builds everything with `-O0` and dynamic linking. This is intended to give you the quickest edit-compile-test turnaround. + * `opt`: enable `-O` and link statically. This takes longer but the code runs faster. + +To build with `opt`, use `-m opt`, e.g. + +``` +buck2 build my-package:my-program -m opt +``` + +There are other build options that can be selected in a similar way, such as `-m prof` to enable profiling. See `constraints/BUCK` for details. + +# Performance + +I ran some experiments building the Cabal project itself - 16 packages +and 641 source files (one package, `hackage-security`, is not part of +the project but has to be built locally nonetheless because it depends +on `Cabal-syntax` which *is* part of the project). + +Buck2 shines when it comes to rebuilds: the dependency graph is cached +in memory, and it knows when build steps can be omitted because the +inputs haven't changed. + +![Buck2 vs Cabal build times](https://raw.githubusercontent.com/simonmar/cabal-buck2/refs/heads/master/perf-chart.svg) + +**Caveats** + +* Results tend to be +/- a few seconds from run to run +* I didn't dig into the results in any detail +* It's just one set of data points. Different projects and different choices of edits could give different results. However, I did perform a similar +experiment with the [persistent](https://github.com/yesodweb/persistent) +project, and got similar results. + +## Raw results and details + +### Clean build + +* Optimised: + * Default Cabal build: **280s** + * `cabal build all --enable-tests --enable-benchmarks -j` + * Buck2 build (opt mode, including `cabal buck2`): **259s** + * `cabal buck2 --enable-tests --enable-benchmarks && buck2 build //... -m opt` + * Not much difference here, as we expect. + +* Unoptimised / dynamic: + * Cabal build with -O0 -dynamic: **136s** + * `cabal build all --enable-tests --enable-benchmarks -j --disable-optimisation --enable-executable-dynamic` + * Buck2 build (dev mode, including `cabal buck2`): **78s** + * `cabal buck2 --enable-tests --enable-benchmarks && buck2 build //... -m dev` + * Cabal is using `-dynamic-too` for libraries, while Buck2 is building everything purely dynamic. + +### Edit + rebuild + +Next I made a single edit (added an extension to +`Language.Haskell.Extension`) and rebuilt everything: + +* Optimised: + * Cabal: **197s** + * Buck2: **179s** + +* Unoptimised / dynamic: + * Cabal: **85s** + * Buck2: **55s** + +# Limitations + +## It's an external command, not builtin to `cabal-install` + +This has some implications: + +* `cabal` passes only the arguments after `buck2`, so global flags + given before it (`cabal --store-dir=... buck2`) don't reach the + tool. Use the environment (`CABAL_DIR`) instead. + +* Nothing checks that your `cabal` binary matches the version of the + `cabal-install` library that `cabal-buck2` was built against. Try to + make sure they match, or confusion will undoubtedly ensue. + +## Builds currently use `--make` + +The current Buck2 prelude uses `ghc --make` to build each component +(library, executable). Ideally we should expose the full per-module +dependencies to Buck2 so that it can exploit parallelism across +packages for faster builds/rebuilds. It's entirely possible to do +this, indeed the functionality already exists in [Tweag's Haskell/Buck2 +integration](https://github.com/tweag/buck2-haskell). + +## Custom build type + +The `cabal buck2` command doesn't run the actual `Setup.hs` code for a +package with the (legacy) Custom build type. If you rely on this, use +Hooks instead. + +## **Template Haskell and `prof`** + +A module that defines a splice must live in a *different* +`haskell_library()` from any module that uses it, when profiling (`-m +prof`). If not, the build will likely complain about a link error or a +missing object file at compile-time. + +The situation with Template Haskell and profiling is complex, as is +the reason for this limitation. + +* Without `-fexternal-interpreter`: GHC loads object code at + compile-time into its own process. Since GHC is itself a + dynamically-linked non-profiled executable, the objects it loads + must be shared, non-profiled, objects. So we have to build all the + dependencies of the current packages as shared libraries. This is + fine, except for the current package: GHC expects to find the + `.dyn_o` objects for the current package in the current `-odir`. But + Buck2 doesn't work this way: it builds the two instances of the + package separately. It's not clear if this is easily fixable. + +* With `-fexternal-interpreter`, we could load the profiled non-shared + objects. However, this method uses the RTS runtime linker, which is + known to have some limitations and can't load some objects, + particularly on certain architectures. This is the main reason that + GHC switched to dynamic linking. So we don't go this route. + +## No support for Cabal's `foreign-library` + +Nothing fundamental blocking this, it's just a TODO. + +## Preprocessors like `hspec-discover` + +The `hspec-discover` preprocessor is designed to be invoked by GHC via +the `-pgmF` flag to specify a custom preprocessor. The problem is that +`hspec-discover` searches the filesystem to find other source files; +these other source files amount to implicit inputs to the compilation, +but when using Buck2 all inputs must be explicit (this is so that +compilation steps can be executed remotely). + +To build an `hspec-discover` test with Buck2, you have to run the +preprocessor using a `genrule()` that takes all the source files as an +input. For example, if your test is in `test/Spec.hs`: + +``` +filegroup( + name = "srcs", + srcs = glob(["**/*.hs"]) +) + +genrule( + name = 'spec-gen', + cmd = "$(location third-party-haskell//:hspec-discover-exe) $(location :srcs)/test/Spec.hs test/Spec.hs ${OUT}", + out = "test/Spec.hs" +) + +haskell_test( + name = 'spec', + srcs = { + 'Main.hs': ':spec-gen', + ... + }, + ... +) +``` + +# Acknowledgments + +Most of the code and modifications to the standard Buck2 prelude were +developed with the help of Claude Code using Claude Sonnet 5/5.5. + +The Haskell support already in the Buck2 prelude was developed by Meta +and is in production use internally for building +[Glean](https://glean.software). This project just fixes a few things +and adds some functionality needed to support building Cabal projects. + +# Related projects + +[Tweag](https://tweag.io) also worked on a [Haskell integration for +Buck2](https://www.youtube.com/watch?v=bbFnrTAIK9Q). This project has +no code in common with theirs, except for the shared upstream prelude +code. Tweag's integration is more sophisticated and was aimed at using +Buck2's improved scalability to build large Haskell projects. + +[ext]: https://cabal.readthedocs.io/en/stable/external-commands.html diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,29 @@ +-- | @cabal buck2@, as an external command: @cabal@ runs @cabal-buck2@ with the +-- arguments after the command name. +module Main (main) where + +import Distribution.Client.CmdBuck2 (buck2Action, buck2Command) +import Distribution.Client.Errors (CabalInstallException) +import Distribution.Client.Setup (defaultGlobalFlags) +import Distribution.Simple.Command + ( CommandParse (..) + , CommandUI (commandDefaultFlags) + , commandParseArgs + ) +import Distribution.Simple.Utils (VerboseException, die', isUserException, topHandler) +import Distribution.Verbosity (defaultVerbosityHandles, mkVerbosity, normal) +import Data.Proxy (Proxy (..)) +import System.Environment (getArgs) + +main :: IO () +main = topHandler (isUserException (Proxy @(VerboseException CabalInstallException))) $ do + args <- getArgs + -- `cabal help buck2` runs `cabal-buck2 buck2 --help`. + let args' = case args of + "buck2" : rest -> rest + _ -> args + case commandParseArgs buck2Command True args' of + CommandHelp help -> putStr (help "cabal") + CommandList opts -> putStr (unlines opts) + CommandErrors errs -> die' (mkVerbosity defaultVerbosityHandles normal) (unlines errs) + CommandReadyToGo (flags, extraArgs) -> buck2Action (flags (commandDefaultFlags buck2Command)) extraArgs defaultGlobalFlags diff --git a/cabal-buck2.cabal b/cabal-buck2.cabal new file mode 100644 --- /dev/null +++ b/cabal-buck2.cabal @@ -0,0 +1,96 @@ +cabal-version: 3.8 +name: cabal-buck2 +version: 0.1.0.0 +synopsis: Build a Cabal project with buck2 (the `cabal buck2` external command) +license: BSD-3-Clause +build-type: Simple +author: Simon Marlow +maintainer: Simon Marlow +category: Build Tool +description: + This is a [Cabal external command](https://cabal.readthedocs.io/en/stable/external-commands.html) `cabal buck2` that allows + you to use [Buck2](https://buck2.build) as the build system for your + Cabal project. For more details see the package README. + +tested-with: GHC==9.14.1, GHC==9.12.4, GHC==9.10.3, GHC==9.8.2, GHC==9.6.4, GHC==9.4.8 + +extra-doc-files: README.md, changelog.md +extra-source-files: + test/fixtures/**/*.c + test/fixtures/**/*.cabal + test/fixtures/**/*.h + test/fixtures/**/*.hs + test/fixtures/**/*.project + test/fixtures/**/.buckconfig + test/fixtures/**/.gitkeep + test/fixtures/**/PACKAGE + +homepage: https://github.com/simonmar/cabal-buck2 +bug-reports: https://github.com/simonmar/cabal-buck2/issues + +source-repository head + type: git + location: https://github.com/simonmar/cabal-buck2.git + +common warnings + ghc-options: -Wall -Wcompat -Wno-unused-do-bind + +library + import: warnings + hs-source-dirs: src + default-language: GHC2021 + default-extensions: TypeOperators, NoImportQualifiedPost + exposed-modules: + Distribution.Client.CmdBuck2 + Distribution.Client.Buck2.BuildDependencies + Distribution.Client.Buck2.Configure + Distribution.Client.Buck2.Generate + Distribution.Client.Buck2.LocalPackages + Distribution.Client.Buck2.Prebuilt + Distribution.Client.Buck2.Schedule + Distribution.Client.Buck2.Setup + Distribution.Client.Buck2.Spec + Distribution.Client.Buck2.Starlark + Distribution.Client.Buck2.Unpack + Distribution.Client.Buck2.Write + build-depends: + , async >=2.2.6 && <2.3 + , base >=4.17 && <4.24 + , bytestring >=0.11.5 && <0.12 + , Cabal ==3.18.* + , Cabal-syntax ==3.18.* + , cabal-install ==3.18.1.0 + , containers >=0.6.7 && <0.7 + , directory >=1.3.8 && <1.4 + , filepath ==1.4.* + , stm >=2.5.1 && <2.6 + +executable cabal-buck2 + import: warnings + main-is: Main.hs + hs-source-dirs: app + default-language: GHC2021 + build-depends: + , base >=4.17 && <4.24 + , Cabal + , cabal-buck2 + , cabal-install + +-- `cabal test` runs `cabal-buck2` on the projects in `test/fixtures` +-- and checks the files it generates. The tests don't need buck2, and +-- use a private `CABAL_DIR` and the packages installed with GHC only +-- (the fixtures set `active-repositories: :none`), so they need no +-- network access. + +test-suite fixtures + import: warnings + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: GHC2021 + build-tool-depends: cabal-buck2:cabal-buck2 + build-depends: + , base >=4.17 && <4.24 + , directory + , filepath + , process diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +# 0.1.0.0 + + * For `cabal-install` version 3.18 diff --git a/src/Distribution/Client/Buck2/BuildDependencies.hs b/src/Distribution/Client/Buck2/BuildDependencies.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/BuildDependencies.hs @@ -0,0 +1,73 @@ +-- | Building the dependencies of a project, and nothing else: everything +-- @cabal build all --only-dependencies@ would build, except the packages +-- that buck2 builds from source itself (see 'isBuiltLocally'). +module Distribution.Client.Buck2.BuildDependencies + ( buildDependencies + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Distribution.Client.CmdBuild as CmdBuild +import Distribution.Client.CmdErrorMessages (renderCannotPruneDependencies, reportTargetProblems) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.ProjectConfig (projectConfigWithBuilderRepoContext) +import Distribution.Client.ProjectOrchestration + +import Distribution.Client.ProjectPlanning hiding + ( pruneInstallPlanToTargets -- we want the one from 'ProjectOrchestration'. + ) + +import Distribution.Simple.Utils (dieWithException, notice) + +import Distribution.Client.Buck2.LocalPackages (isBuiltLocally) +import Distribution.Client.Buck2.Unpack (unpackInplaceSources) +import Distribution.Client.Errors (CabalInstallException (ReportCannotPruneDependencies)) + +-- | Build every dependency of the selected targets, excluding packages +-- that are forced to build locally (see 'isBuiltLocally'). +-- This is similar but not quite the same as the code for @CmdBuild@. +buildDependencies :: Verbosity -> ProjectBaseContext -> [TargetSelector] -> IO ProjectBuildContext +buildDependencies verbosity baseCtx targetSelectors = do + buildCtx@ProjectBuildContext{elaboratedPlanOriginal, elaboratedShared} <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + targets <- + either (reportTargetProblems verbosity "buck2") return $ + resolveTargetsFromSolver + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + let elaboratedPlan' = pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan + excluded = + Map.keysSet targets + <> Set.fromList + [ elabUnitId elab + | InstallPlan.Configured elab <- InstallPlan.toList elaboratedPlan' + , isBuiltLocally elab + ] + elaboratedPlan'' <- + either (dieWithException verbosity . ReportCannotPruneDependencies . renderCannotPruneDependencies) return $ + pruneInstallPlanToDependencies excluded elaboratedPlan' + return (elaboratedPlan'', targets) + + notice verbosity "cabal buck2: building dependencies" + printPlan verbosity baseCtx buildCtx + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + + unpackInplaceSources + verbosity + (distDirLayout baseCtx) + elaboratedShared + (projectConfigWithBuilderRepoContext verbosity (buildSettings baseCtx)) + [ elab + | InstallPlan.Configured elab <- InstallPlan.toList elaboratedPlanOriginal + , isBuiltLocally elab + , not (elabLocalToProject elab) + ] + return buildCtx diff --git a/src/Distribution/Client/Buck2/Configure.hs b/src/Distribution/Client/Buck2/Configure.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/Configure.hs @@ -0,0 +1,216 @@ +-- | Configure the components of the packages that buck2 builds from +-- source, to get the 'LocalBuildInfo'. +module Distribution.Client.Buck2.Configure + ( configureComponents + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Data.Map as Map + +import Control.Concurrent (getNumCapabilities, setNumCapabilities) +import Control.Concurrent.STM + ( atomically + , modifyTVar' + , newTVarIO + , readTVarIO + ) + +import Distribution.Client.DistDirLayout + ( DistDirLayout (distBuildDirectory) + ) +import qualified Distribution.Client.InLibrary as InLibrary +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning hiding (pruneInstallPlanToTargets) +import Distribution.Client.ProjectPlanning.Types + ( elabDistDirParams + , elabExeDependencyPaths + , elabOrderLibDependencies + ) +import Distribution.Client.Types.ReadyPackage (GenericReadyPackage (ReadyPackage)) +import Distribution.Client.Utils (numberOfProcessors) +import Distribution.Types.ParStrat (ParStratInstall, ParStratX (..)) + +import Distribution.Package (PackageName, packageName) +import Distribution.PackageDescription (PackageDescription) +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.Compiler (PackageDBX (GlobalPackageDB)) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.Program.Builtin (builtinPrograms) +import Distribution.Simple.Program.Db (prependProgramSearchPathNoLogging, restoreProgramDb, userSpecifyArgss) +import Distribution.Simple.Register (generateRegistrationInfo) +import Distribution.Simple.Utils (info) +import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Types.LocalBuildInfo + ( LocalBuildInfo + , componentNameCLBIs + , distPrefLBI + , relocatable + ) +import Distribution.Types.UnitId (UnitId) +import Distribution.Utils.Path (makeSymbolicPath) +import Distribution.Verbosity (defaultVerbosityHandles) + +import System.Directory (canonicalizePath) +import System.FilePath (()) + +import Distribution.Client.Buck2.LocalPackages (componentNamesFor, isBuiltLocally, packageSourceDir) +import Distribution.Client.Buck2.Schedule (runDependencyGraph) + +-- | Get a real 'LocalBuildInfo' for every component in the +-- 'ProjectBuildContext', keyed by package and component name. Only +-- components actually selected by the build targets (and whatever +-- they depend on) are configured. +-- +-- @installedIndex@ must cover the whole resolved dependency closure of the +-- project. Each library is added to it, configured and registered in-place, +-- before the components that depend on it are configured. +-- +-- Configuration happens concurrently as far as possible, because +-- this can take a while for projects with a lot of components to build. +configureComponents + :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> InstalledPackageIndex + -> IO (Map (PackageName, ComponentName) LocalBuildInfo) +configureComponents verbosity baseCtx buildCtx installedIndex = + configureComponentsConcurrently + verbosity + (distDirLayout baseCtx) + (parStratNumJobs (buildSettingNumJobs (buildSettings baseCtx))) + (pruneInstallPlanToTargets TargetActionBuild (targetsMap buildCtx) (elaboratedPlanOriginal buildCtx)) + (elaboratedShared buildCtx) + installedIndex + +-- | A real 'LocalBuildInfo' for one local (or quasi-local) *component*. +localBuildInfoFor + :: Verbosity + -> DistDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> InstalledPackageIndex + -> ElaboratedConfiguredPackage + -> IO LocalBuildInfo +localBuildInfoFor verbosity distDirLayout plan shared ipi elab = do + -- Real Cabal's own 'InLibrary.configure' falls back to *searching* the + -- working directory for a @.cabal@ file whenever + -- 'Cabal.configCabalFilePath' isn't set (see its own use of + -- 'tryFindPackageDesc') - so this has to be the package's own source + -- directory, matching 'setupHsScriptOptions''s own @srcdir@ in the + -- real build path ("Distribution.Client.ProjectBuilding.UnpackedPackage"), + -- not the buck2 command's actual cwd (the project root), or this fails + -- outright with "No cabal file found" for every package but one that + -- happens to be sitting at the project root itself. + pkgDir <- packageSourceDir verbosity distDirLayout elab + let verbHandles = defaultVerbosityHandles + -- Builtin preprocessors (alex, happy, hsc2hs, ...) restored as + -- known-but-unconfigured programs, and the compiler's own + -- already-configured programs - the same starting point a real + -- build's own 'Distribution.Client.SetupWrapper' constructs (see + -- its own comment "Note [Constructing the ProgramDb]") - plus + -- 'elabExeDependencyPaths'\/'elabProgramPathExtra' prepended onto + -- its search path. That part isn't optional the way the rest of + -- "Note [Constructing the ProgramDb]"'s extra layering is: a + -- component with e.g. @build-tool-depends: alex:alex@ needs + -- 'InLibrary.configure' below to be able to find *this* build's + -- own just-built @alex@ (never on a bare @$PATH@ - it only exists + -- under @dist-newstyle@) and query its version, the same way real + -- Cabal's own subprocess-based configure does via + -- 'setupHsScriptOptions''s @useExtraPathEnv@ - just via a search + -- path prepend instead of a subprocess's environment, since this + -- runs in-process. + -- The user-specified program arguments (@ghc-options:@ from + -- cabal.project, @--ghc-options@, ...) are applied by Cabal's own + -- top-level @configure@, which 'InLibrary.configure' skips - so + -- without this the 'LocalBuildInfo' wouldn't have them, unlike one + -- from a real @Setup configure@. + progDb = + userSpecifyArgss (Map.toList (elabProgramArgs elab)) $ + prependProgramSearchPathNoLogging + (elabExeDependencyPaths elab ++ elabProgramPathExtra elab) + [] + (restoreProgramDb builtinPrograms (pkgConfigCompilerProgs shared)) + buildType = PD.buildType (elabPkgDescription elab) + inputs = + InLibrary.libraryConfigureInputsFromElabPackage + verbHandles + buildType + progDb + shared + (ReadyPackage elab) + ipi + [] + builddir = makeSymbolicPath (distBuildDirectory distDirLayout (elabDistDirParams shared elab) "build") + commonFlags = setupHsCommonFlags verbosity (Just (makeSymbolicPath pkgDir)) builddir [] False + cfg <- + setupHsConfigureFlags + (fmap makeSymbolicPath . canonicalizePath) + plan + (ReadyPackage elab) + shared + commonFlags + InLibrary.configure inputs cfg + +-- | If @cname@ names a library component, produce the real, in-place +-- 'InstalledPackageInfo' for it. +libraryInstalledPackageInfo :: Verbosity -> LocalBuildInfo -> PackageDescription -> ComponentName -> IO (Maybe InstalledPackageInfo) +libraryInstalledPackageInfo verbosity lbi pkgDesc cname = case cname of + CLibName ln + | Just lib <- listToMaybe [l | l <- PD.allLibraries pkgDesc, PD.libName l == ln] + , (clbi : _) <- componentNameCLBIs lbi cname -> + Just <$> generateRegistrationInfo verbosity pkgDesc lib lbi clbi True (relocatable lbi) (distPrefLBI lbi) GlobalPackageDB + _ -> return Nothing + +-- | Obtain the 'LocalBuildInfo' for all the components by configuring +-- them concurrently as far as possible, respecting dependency constraints +-- and the @-jNUM@ flag. +configureComponentsConcurrently + :: Verbosity + -> DistDirLayout + -> Int + -- ^ Maximum number of components to configure at once (from + -- @-j@\/@jobs:@, like a @cabal build@ would use). + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> InstalledPackageIndex + -> IO (Map (PackageName, ComponentName) LocalBuildInfo) +configureComponentsConcurrently verbosity distDirLayout numJobs plan shared installedIndex = do + numCaps <- getNumCapabilities + info verbosity $ "cabal buck2: configuring components with up to " ++ show numJobs ++ " job(s)" + let wantedCaps = min numJobs numberOfProcessors + when (numCaps < wantedCaps) $ + setNumCapabilities wantedCaps + + let localElabs :: Map UnitId ElaboratedConfiguredPackage + localElabs = + Map.fromList + [ (elabUnitId elab, elab) + | InstallPlan.Configured elab <- InstallPlan.toList plan + , isBuiltLocally elab + ] + + indexVar <- newTVarIO installedIndex + componentLBIsVar <- newTVarIO Map.empty + + runDependencyGraph numJobs (Map.map elabOrderLibDependencies localElabs) $ \uid -> do + let elab = localElabs Map.! uid + pkgDesc = elabPkgDescription elab + idx <- readTVarIO indexVar + lbi <- localBuildInfoFor verbosity distDirLayout plan shared idx elab + for_ (componentNamesFor elab pkgDesc) $ \cname -> do + mipi <- libraryInstalledPackageInfo verbosity lbi pkgDesc cname + for_ mipi $ \ipi -> atomically $ modifyTVar' indexVar (PackageIndex.insert ipi) + atomically $ modifyTVar' componentLBIsVar (Map.insert (packageName pkgDesc, cname) lbi) + + readTVarIO componentLBIsVar + +-- | How many jobs a parallel strategy allows to run at once: @-j@ with no +-- number means one per processor, @-jsem N@ is treated as @-jN@. +parStratNumJobs :: ParStratInstall -> Int +parStratNumJobs Serial = 1 +parStratNumJobs (NumJobs n) = fromMaybe numberOfProcessors n +parStratNumJobs (UseSem n) = n diff --git a/src/Distribution/Client/Buck2/Generate.hs b/src/Distribution/Client/Buck2/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/Generate.hs @@ -0,0 +1,658 @@ +-- | Generate all the info that buck2 needs to build the components of +-- a package, as a pure function from the 'PackageDescription', +-- 'LocalBuildInfo'(s) and a few other things. +-- +-- The buck2 build spec is described by the data types in +-- "Distribution.Client.Buck2.Spec", and will be emitted into +-- @BUCK.cabal.bzl@ and interpreted by @buck2@ to produce the final +-- build targets (the interpreter is @buck2/cabal.bzl@). It's done +-- this way rather than emitting targets directly so that a custom +-- @BUCK@ file can override or customise the targets. +-- +-- Here we also produce the content for the autogen files, such as +-- @cabal_macros.h@ and @Paths_.hs@. +-- +-- All the content we generate here will be written to files later in +-- "Distribution.Client.Buck2.Write". +module Distribution.Client.Buck2.Generate + ( LocalPackageIndex + , AutogenFile (..) + , PackageTargets (..) + , generatePackageTargets + , sourceCandidates + , libTargetName + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import System.FilePath ((<.>), ()) + +import Data.Either (fromLeft) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Distribution.Compat.NonEmptySet as NES +import Distribution.Compiler (CompilerFlavor (GHC)) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package (packageId, packageName) +import Distribution.PackageDescription + ( Benchmark (benchmarkInterface, benchmarkName) + , BenchmarkInterface (..) + , BuildInfo + , Executable (exeName, modulePath) + , Library (exposedModules, libBuildInfo, libName) + , LibraryName (..) + , PackageDescription + , TestSuite (testInterface, testName) + , TestSuiteInterface (..) + , buildToolDepends + , cSources + , cppOptions + , cxxOptions + , cxxSources + , defaultExtensions + , defaultLanguage + , extraLibs + , hcOptions + , hsSourceDirs + , includeDirs + , otherModules + , pkgBuildableComponents + , pkgconfigDepends + , targetBuildDepends + ) +import Distribution.Simple.Compiler (compilerInfo) +import Distribution.Types.Component (Component (..), componentBuildInfo, componentName) +import Distribution.Types.ComponentLocalBuildInfo (ComponentLocalBuildInfo) +import Distribution.Types.ComponentName (ComponentName) +import Distribution.Types.Dependency (depLibraries, depPkgName) +import Distribution.Types.ExeDependency (ExeDependency (..)) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo (compiler, hostPlatform, withPrograms), componentNameCLBIs, localUnitId) +import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.Types.PkgconfigDependency (PkgconfigDependency (..)) +import Distribution.Types.PkgconfigName (unPkgconfigName) +import Distribution.Types.UnqualComponentName (unUnqualComponentName) +import Distribution.Utils.Path (getSymbolicPath) + +import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) +import Distribution.Simple.Build.PathsModule (generatePathsModule) +import Distribution.Simple.BuildPaths (autogenPathsModuleName) +import Distribution.Simple.InstallDirs + ( PathTemplate + , PathTemplateVariable (TestSuiteNameVar) + , fromPathTemplate + , initialPathTemplateEnv + , substPathTemplate + , toPathTemplate + ) +import Distribution.Simple.Program.Builtin (ghcProgram) +import Distribution.Simple.Program.Db (lookupProgram) +import Distribution.Simple.Program.Types (programOverrideArgs) +import Distribution.Simple.Utils (ordNub) + +import Distribution.Client.Buck2.Spec + +-- | Maps every local project package's name to the buck2 cell-relative +-- directory its @BUCK@ file lives in (@.@ for one at the project root), so +-- a dependency on another local package can be turned into a fully +-- qualified target label - plus the set of other packages its main +-- library's @reexported-modules@ re-export from (see 'classifyDeps'). +type LocalPackageIndex = Map PackageName (FilePath, [PackageName]) + +-- | A generated file that lives in the package's @cabal-buck2\/autogen@ +-- directory (a component's @cabal_macros.h@, the package's own +-- @Paths_\@ module, a @detailed-0.9@ test-suite's stub @Main@), and +-- needs an @export_file()@ entry in @cabal-buck2\/autogen\/BUCK@ (see +-- "Distribution.Client.Buck2.Write", which writes both) so it can be +-- referenced - by a component's @cabal_component@, or by a hand-written rule +-- elsewhere in the project - as a real, buck2-tracked target instead of an +-- untracked path string. +data AutogenFile = AutogenFile + { autogenName :: String + -- ^ The name of its @export_file()@ target. + , autogenPath :: FilePath + -- ^ Relative to @cabal-buck2\/autogen@. + , autogenContents :: String + } + deriving (Eq, Ord) + +-- | What is generated for one package: its build spec, +-- and the autogen files it needs. +data PackageTargets = PackageTargets + { ptSpec :: BuildSpec + , ptComponentCount :: Int + , ptAutogenFiles :: [AutogenFile] + } + +-- | One component's contribution to a 'PackageTargets': its entry in the +-- spec (none if it was skipped), its autogen files, and the warnings +-- produced along the way. +data ComponentTargets = ComponentTargets + { ctSpec :: [SpecComponent] + , ctAutogen :: [AutogenFile] + , ctWarnings :: [String] + } + +instance Semigroup ComponentTargets where + ComponentTargets s1 a1 w1 <> ComponentTargets s2 a2 w2 = ComponentTargets (s1 ++ s2) (a1 ++ a2) (w1 ++ w2) + +instance Monoid ComponentTargets where + mempty = ComponentTargets [] [] [] + +componentTargets :: SpecComponent -> [AutogenFile] -> ComponentTargets +componentTargets component files = mempty{ctSpec = [component], ctAutogen = files} + +-- | Generate the buck2 targets for every buildable component of a local +-- package, along with the warnings for the components that had to be +-- skipped (and why). This does no IO: the source files it looks for are +-- given as a set of paths (relative to the package's directory), which +-- must include every path 'sourceCandidates' lists that exists. +generatePackageTargets + :: LocalPackageIndex + -> FilePath + -- ^ The package's own buck2 cell-relative directory (@.@ at the project + -- root). + -> Map (PackageName, ComponentName) LocalBuildInfo + -> Set String + -- ^ Every @build-tool-depends:@ executable name + -- "Distribution.Client.Buck2.Prebuilt" resolved a real *external* + -- binary for (and generated an @export_file()@ target for) - see + -- 'specComponent'. + -> Map (PackageName, ComponentName) [PathTemplate] + -- ^ The project's @test-options:@ for each test-suite (see 'testSuiteArgs'). + -> Set FilePath + -> PackageDescription + -> (Maybe PackageTargets, [String]) +generatePackageTargets localIndex rootRelPkgDir componentLBIs externalBuildTools projectTestOptions sources pkgDesc = + (targets, concatMap ctWarnings results) + where + generate = generateComponent localIndex componentLBIs externalBuildTools projectTestOptions sources pkgDesc + comps = pkgBuildableComponents pkgDesc + + -- Worked out ahead of the other components, so that one that + -- build-depends on a library of this package that won't get a rule + -- (unresolvable modules) can skip itself too, instead of emitting a + -- rule whose @deps@ references a target that was never generated - + -- buck2 fails that outright at analysis time ("Unknown target"), for + -- the *entire* build, the same class of problem 'resolveModules' + -- exists to avoid for a single component's own missing source file. + -- Libraries themselves never depend on this set. + skippedLibs = + Set.fromList [libName lib | comp@(CLib lib) <- comps, null (ctSpec (generate Set.empty comp))] + + results = map (generate skippedLibs) comps + components = concatMap ctSpec results + targets + | null components = Nothing + | otherwise = + Just + PackageTargets + { ptSpec = packageSpec pkgDesc rootRelPkgDir (packageGhcOptions pkgDesc componentLBIs) components + , ptComponentCount = length components + , ptAutogenFiles = dedupAutogenFiles (concatMap ctAutogen results) + } + +-- | Look up a component's 'LocalBuildInfo' and +-- 'ComponentLocalBuildInfo' -- 'Nothing' if either lookup fails +-- (e.g. a component that isn't part of the elaborated build plan, +-- such as a test-suite when tests aren't enabled), in which case +-- callers skip the component. +lbiClbiFor :: PackageDescription -> Map (PackageName, ComponentName) LocalBuildInfo -> Component -> Maybe (LocalBuildInfo, ComponentLocalBuildInfo) +lbiClbiFor pkgDesc componentLBIs comp = do + lbi <- Map.lookup (packageName pkgDesc, componentName comp) componentLBIs + clbi <- listToMaybe (componentNameCLBIs lbi (componentName comp)) + return (lbi, clbi) + +-- | Two components referencing the same autogen file (the package's +-- @Paths_\@ module) each produce it; keep one entry per target, at the +-- position of the first, with the contents of the last. +dedupAutogenFiles :: [AutogenFile] -> [AutogenFile] +dedupAutogenFiles files = + [ f{autogenContents = latest Map.! autogenName f} + | f <- nubBy ((==) `on` autogenName) files + ] + where + latest = Map.fromList [(autogenName f, autogenContents f) | f <- files] + +generateComponent + :: LocalPackageIndex + -> Map (PackageName, ComponentName) LocalBuildInfo + -> Set String + -> Map (PackageName, ComponentName) [PathTemplate] + -> Set FilePath + -> PackageDescription + -> Set LibraryName + -> Component + -> ComponentTargets +generateComponent localIndex componentLBIs externalBuildTools projectTestOptions sources pkgDesc skippedLibs comp = case comp of + CLib lib -> library (libTargetName (packageName pkgDesc) (libName lib)) lib + CExe exe -> ifNotOnSkippedLib (componentBuildInfo comp) (unUnqualComponentName (exeName exe)) Executable $ executable exe + CTest test -> ifNotOnSkippedLib (componentBuildInfo comp) (unUnqualComponentName (testName test)) TestSuite $ testSuite test + CBench bench -> ifNotOnSkippedLib (componentBuildInfo comp) (unUnqualComponentName (benchmarkName bench)) Benchmark $ benchmark bench + CFLib _ -> skip "foreign library (not supported yet)" + where + skip = skipBecause [] + + -- Skip a component, with the warnings for the problems that led to it + -- followed by the skip itself. + skipBecause problems why = + mempty{ctWarnings = problems ++ ["cabal buck2: skipping " ++ why ++ " in package " ++ unPackageName (packageName pkgDesc)]} + + -- A component that build-depends on one of *this same package's* + -- own libraries, when that library was itself skipped (see + -- 'skippedLibs'), can't be built either - it would emit a rule + -- whose own @deps@ references a target that was never generated, + -- which buck2 rejects outright ("Unknown target") at analysis time + -- for the whole build, not just a warning. cabal-testsuite's own + -- @test-runtime-deps@ executable (build-depends on cabal-testsuite's + -- own library) is exactly this case. + ifNotOnSkippedLib bi targetName kind act = + case [ln | d <- targetBuildDepends bi, depPkgName d == packageName pkgDesc, ln <- NES.toList (depLibraries d), ln `Set.member` skippedLibs] of + (ln : _) -> + skip + ( kindName kind + ++ " " + ++ targetName + ++ " (depends on " + ++ libTargetName (packageName pkgDesc) ln + ++ ", itself skipped)" + ) + [] -> act + + library targetName lib = case lbiClbiFor pkgDesc componentLBIs comp of + Nothing -> skip ("library " ++ targetName ++ " (no LocalBuildInfo found for it in the elaborated build plan)") + Just (lbi, clbi) -> case resolveModules sources pkgDesc (Just (lbi, clbi)) bi (exposedModules lib ++ otherModules bi) of + Left problems -> skipBecause problems ("library " ++ targetName ++ " (couldn't resolve all its modules)") + Right (srcs, srcAutogen) -> + componentTargets + (specComponent localIndex externalBuildTools Library targetName bi){scSrcs = srcs} + (macrosHeader targetName pkgDesc lbi clbi : srcAutogen) + where + bi = libBuildInfo lib + + -- An executable, benchmark or test-suite: all the same shape (a main + -- module over some others), differing only in the spec's kind and test + -- arguments. + executableLike kind targetName lbi clbi bi mainSrc otherSrcs testArgs srcAutogen = + componentTargets + (specComponent localIndex externalBuildTools kind targetName bi){scMainIs = Just mainSrc, scSrcs = otherSrcs, scTestArgs = testArgs} + (macrosHeader targetName pkgDesc lbi clbi : srcAutogen) + + -- The shape shared by an executable, an @exitcode-stdio-1.0@ + -- test-suite and benchmark: a @main-is@ file over the @other-modules@. + mainIsComponent kind targetName bi mainIs extra = case lbiClbiFor pkgDesc componentLBIs comp of + Nothing -> skip (kindName kind ++ " " ++ targetName ++ " (no LocalBuildInfo found for it in the elaborated build plan)") + Just (lbi, clbi) -> case (resolveMainIs sources bi mainIs, resolveModules sources pkgDesc (Just (lbi, clbi)) bi (otherModules bi)) of + (Right mainSrc, Right (otherSrcs, srcAutogen)) -> + executableLike kind targetName lbi clbi bi (SrcFile mainSrc) otherSrcs (extra lbi) srcAutogen + (mainRes, othersRes) -> + skipBecause (problemsOf mainRes ++ problemsOf othersRes) (kindName kind ++ " " ++ targetName ++ " (couldn't resolve all its modules)") + + executable exe = mainIsComponent Executable targetName bi (getSymbolicPath (modulePath exe)) (const []) + where + bi = componentBuildInfo (CExe exe) + targetName = unUnqualComponentName (exeName exe) + + -- A benchmark's own 'BenchmarkExeV10' is exactly 'TestSuiteExeV10's + -- shape (a version-tagged main-is path over the same 'BuildInfo') - + -- and unlike a test-suite, @cabal bench@ has no special "run it and + -- report a testsuite-style result" semantics of its own, just + -- "build and run this executable" - so this maps onto the same thing + -- as an executable. + benchmark bench = case benchmarkInterface bench of + BenchmarkExeV10 _ver mainIs -> mainIsComponent Benchmark targetName bi (getSymbolicPath mainIs) (const []) + _ -> + skip + ( "benchmark " + ++ targetName + ++ " (only exitcode-stdio-1.0 benchmarks are supported)" + ) + where + bi = componentBuildInfo (CBench bench) + targetName = unUnqualComponentName (benchmarkName bench) + + testSuite test = case testInterface test of + TestSuiteExeV10 _ver mainIs -> mainIsComponent TestSuite targetName bi (getSymbolicPath mainIs) testArgs + -- A @detailed-0.9@ test-suite's own module (named via + -- @test-module:@, not @other-modules:@ - real Cabal synthesises a + -- whole separate internal sub-library exposing just this one + -- module, see 'Distribution.Simple.Build.testSuiteLibV09AsLibAndExe') + -- exports @tests :: IO ['Distribution.TestSuite.Test']@, and real + -- Cabal's own Setup.hs generates a tiny stub 'Main' importing it + -- and calling into 'Distribution.Simple.Test.LibV09.stubMain' - + -- which then blocks reading a @(logFilePath, testSuiteName)@ pair + -- off *stdin*, written by the parent @cabal test@ process, before + -- it'll run anything at all (see that module's own 'stubMain'). + -- That stdin handshake has nothing to do with buck2 - a + -- @haskell_test()@ just execs the compiled binary and checks its + -- exit code, the same as @exitcode-stdio-1.0@ - so reusing real + -- Cabal's own stub verbatim would need a wrapper script to feed it + -- a fake handshake for no real benefit (nothing here ever reads + -- the machine-readable log it writes). Generates a self-contained + -- stub instead, calling only 'Distribution.TestSuite's own public + -- API directly (a real, documented, GHC-version-independent + -- interface - not reimplementing anything real Cabal doesn't + -- already expose for exactly this purpose): runs every 'Test' + -- in turn, printing a human-readable pass\/fail\/error line per + -- test to stdout, exiting non-zero if anything failed or errored. + -- Needs no new build-depends beyond what real Cabal already + -- requires the user to declare for their own @tests@ module to + -- even type-check (@Distribution.TestSuite@ lives in the @Cabal@ + -- library itself). + TestSuiteLibV09 _ver testModule -> case lbiClbiFor pkgDesc componentLBIs comp of + Nothing -> skip ("test-suite " ++ targetName ++ " (no LocalBuildInfo found for it in the elaborated build plan)") + Just (lbi, clbi) -> case (resolveModules sources pkgDesc (Just (lbi, clbi)) bi [testModule], resolveModules sources pkgDesc (Just (lbi, clbi)) bi (otherModules bi)) of + (Right (testModSrc, testModAutogen), Right (otherSrcs, otherAutogen)) -> + let (stubSrc, stubFile) = detailedTestStub targetName testModule + in executableLike TestSuite targetName lbi clbi bi stubSrc (testModSrc ++ otherSrcs) (testArgs lbi) (stubFile : testModAutogen ++ otherAutogen) + (testModRes, othersRes) -> + skipBecause (problemsOf testModRes ++ problemsOf othersRes) ("test-suite " ++ targetName ++ " (couldn't resolve all its modules)") + _ -> + skip + ( "test-suite " + ++ targetName + ++ " (only exitcode-stdio-1.0 and detailed-0.9 test-suites are supported)" + ) + where + bi = componentBuildInfo (CTest test) + targetName = unUnqualComponentName (testName test) + testArgs lbi = testSuiteArgs pkgDesc lbi test (Map.findWithDefault [] (packageName pkgDesc, componentName comp) projectTestOptions) + + problemsOf = fromLeft [] + +-- | A package's build spec. +packageSpec :: PackageDescription -> FilePath -> [String] -> [SpecComponent] -> BuildSpec +packageSpec pkgDesc rootRelPkgDir projectGhcOptions components = + BuildSpec + { specPackageName = unPackageName (packageName pkgDesc) + , specPackageDir = rootRelPkgDir + , specGhcOptions = projectGhcOptions + , specComponents = components + } + +-- | A component of a build spec, from its 'BuildInfo'. The kind-specific +-- parts (main module, other sources, test arguments) are left empty. +specComponent :: LocalPackageIndex -> Set String -> ComponentKind -> String -> BuildInfo -> SpecComponent +specComponent localIndex externalBuildTools kind name bi = + SpecComponent + { scKind = kind + , scName = name + , scMainIs = Nothing + , scSrcs = [] + , scTestArgs = [] + , scGhcOptions = hcOptions GHC bi + , scCppOptions = cppOptions bi + , scLanguage = prettyShow <$> defaultLanguage bi + , scExtensions = map prettyShow (defaultExtensions bi) + , scExtraLibraries = extraLibs bi + , scDeps = map depSpec (libraryDeps localIndex bi) + , scBuildTools = mapMaybe buildToolSpec (ordNub [(pn, exe) | ExeDependency pn exe _ <- buildToolDepends bi]) + , scCSources = map getSymbolicPath (cSources bi) + , scCxxSources = map getSymbolicPath (cxxSources bi) + , scCxxOptions = cxxOptions bi + , scIncludeDirs = map getSymbolicPath (includeDirs bi) + , scPkgconfig = ordNub [unPkgconfigName n | PkgconfigDependency n _ <- pkgconfigDepends bi] + } + where + depSpec (pn, ln) = + SpecDep + { depPackage = unPackageName pn + , depLibrary = case ln of + LSubLibName n -> Just (unUnqualComponentName n) + LMainLibName -> Nothing + , depDir = fst <$> Map.lookup pn localIndex + } + -- A tool that's neither built by this project nor resolved to a real + -- external binary can't be put on PATH by buck2: dropped, silently - + -- most build-tool-depends are Setup.hs-time tools nothing needs on PATH. + buildToolSpec (pn, exe) = case Map.lookup pn localIndex of + Just (dir, _) -> Just (LocalTool n dir) + Nothing + | n `Set.member` externalBuildTools -> Just (ExternalTool n) + | otherwise -> Nothing + where + n = unUnqualComponentName exe + +-- | The project-supplied GHC options (see 'ghcProgramArgs') for a +-- package. Cabal gives every component of a package the same ones (they +-- come from the package's @cabal.project@ stanza, not from anything +-- per-component), so any one component's will do; empty if none of its +-- components were configured at all. +packageGhcOptions :: PackageDescription -> Map (PackageName, ComponentName) LocalBuildInfo -> [String] +packageGhcOptions pkgDesc componentLBIs = + fromMaybe [] . listToMaybe $ + [ ghcProgramArgs lbi + | comp <- pkgBuildableComponents pkgDesc + , Just (lbi, _) <- [lbiClbiFor pkgDesc componentLBIs comp] + ] + +-- | Extra GHC arguments the *project* supplies rather than the @.cabal@ +-- file: @ghc-options:@ under @package@\/@program-options@ in +-- @cabal.project@, or @--ghc-options@ on the command line. Cabal applies +-- these to every GHC invocation for the component, after the @.cabal@ +-- file's own @ghc-options@ (so they can override them) - taken from the +-- configured @ghc@ program in the 'LocalBuildInfo', which is exactly +-- where Cabal itself finds them, rather than reading the elaborated plan. +ghcProgramArgs :: LocalBuildInfo -> [String] +ghcProgramArgs lbi = + -- cabal-install itself adds @-hide-all-packages@ to every GHC invocation + -- (a workaround for custom Setup scripts that call GHC directly), which + -- means nothing for a buck2 rule - the rule already passes it, and it's + -- position-sensitive among GHC's package flags. + filter (/= "-hide-all-packages") $ + maybe [] programOverrideArgs (lookupProgram ghcProgram (withPrograms lbi)) + +-- | The arguments @cabal test@ would pass to this test-suite's executable +-- for the project's @test-options:@ (\/@--test-options@), with the same +-- @$pkgid@\/@$test-suite@-style template variables expanded - Cabal's own +-- expansion (in "Distribution.Simple.Test.ExeV10") isn't exported. +testSuiteArgs :: PackageDescription -> LocalBuildInfo -> TestSuite -> [PathTemplate] -> [String] +testSuiteArgs pkgDesc lbi test = map (fromPathTemplate . substPathTemplate env) + where + env = + initialPathTemplateEnv (packageId pkgDesc) (localUnitId lbi) (compilerInfo (compiler lbi)) (hostPlatform lbi) + ++ [(TestSuiteNameVar, toPathTemplate (unUnqualComponentName (testName test)))] + +-- | This component's @cabal_macros.h@, exactly as real Cabal generates it +-- ahead of a build. Produced unconditionally, like real Cabal: harmless for a +-- component that never enables CPP (the header only matters if\/when cpp +-- actually runs). @cabal_component@ (in buck2\/cabal.bzl's rules) is what +-- wires the component up to include it. +macrosHeader :: String -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> AutogenFile +macrosHeader targetName pkgDesc lbi clbi = + AutogenFile + { autogenName = targetName ++ "-cabal-macros" + , autogenPath = targetName "cabal_macros.h" + , autogenContents = generateCabalMacrosHeader pkgDesc lbi clbi + } + +-- | The buck2 target name for one of a package's libraries: the package +-- name itself for the main (unnamed) library, matching every other +-- reference to it (@packages = [...]@, other packages' @build-depends@, +-- ...); the sub-library's own unqualified name otherwise - always unique +-- within one package's BUCK file, since Cabal itself already requires +-- every component name in a package to be distinct. +libTargetName :: PackageName -> LibraryName -> String +libTargetName pn LMainLibName = unPackageName pn +libTargetName _ (LSubLibName n) = unUnqualComponentName n + +-- | Every library a component depends on: its @build-depends@ (each of which may name +-- more than one library of a package via @pkg:sublib@ - see +-- 'depLibraries'), closed over the reexports of local packages. +libraryDeps :: LocalPackageIndex -> BuildInfo -> [(PackageName, LibraryName)] +libraryDeps localIndex bi = closeOverReexports [] directDeps + where + directDeps = + ordNub + [ (depPkgName d, ln) + | d <- targetBuildDepends bi + , ln <- NES.toList (depLibraries d) + ] + -- A local package's buck2 haskell_library() rule only ever declares + -- its own real source modules - unlike a real GHC package db entry, + -- it has no way to also claim modules reexported (`reexported- + -- modules:` in the .cabal file) from elsewhere. So a component that + -- depends on a local package with reexports (e.g. `Cabal` re- + -- exporting a chunk of `Cabal-syntax`) needs the reexport's origin + -- package added as an explicit direct dependency too, or - once + -- compile.bzl's `-hide-all-packages` is in effect - GHC can't find + -- the reexported module at all: "Could not load module ...". This + -- closure adds those origins (transitively, in case a reexporting + -- package itself depends on another reexporting package). + closeOverReexports seen [] = seen + closeOverReexports seen (p@(pn, _) : rest) + | p `elem` seen = closeOverReexports seen rest + | otherwise = + let origins = maybe [] snd (Map.lookup pn localIndex) + in closeOverReexports (p : seen) (rest ++ [(o, LMainLibName) | o <- origins]) + +-- | Resolve each module in @hs-source-dirs@ to its real file, trying +-- @.hs@\/@.lhs@\/@.hsc@ (and the other extensions buck2\/haskell.bzl knows +-- how to preprocess) in turn - returning @(moduleName, source)@ pairs for the +-- dict form of @srcs@, which - unlike the plain-list form - is unaffected +-- by @hs-source-dirs@ not matching the BUCK package's own directory. Files +-- are looked up in @sources@ (see 'sourceCandidates'). The package's +-- @Paths_\@ module (if listed) is special-cased: no such file exists +-- anywhere - Cabal's own Setup.hs generates it fresh on every real build - +-- so 'pathsModuleFile' stands one in, which needs this component's real +-- 'LocalBuildInfo'\/'ComponentLocalBuildInfo' (see 'lbiClbiFor'); without +-- one that module fails to resolve, like a missing source file. Also returns +-- the autogen files picked up along the way - in practice just the +-- @Paths_\@ one, at most once, if that module was among @mods@. +-- +-- 'Left' (with a description of each module that couldn't be resolved) if +-- *any* module couldn't be - the caller skips the whole component in that +-- case, rather than emitting a rule that references a source file that +-- doesn't exist: buck2 doesn't merely warn about that, it fails outright +-- while evaluating the @BUCK@ file, which (since a @buck2 build //...@ +-- evaluates every @BUCK@ file up front) would otherwise take the *entire* +-- build down over one unresolvable module in one component of one package. +resolveModules :: Set FilePath -> PackageDescription -> Maybe (LocalBuildInfo, ComponentLocalBuildInfo) -> BuildInfo -> [ModuleName.ModuleName] -> Either [String] ([(String, Src)], [AutogenFile]) +resolveModules sources pkgDesc mlbiClbi bi mods = + case partitionEithers (map (resolveOne sources pkgDesc mlbiClbi bi) mods) of + ([], triples) -> Right ([(n, v) | (n, v, _) <- triples], concat [fs | (_, _, fs) <- triples]) + (problems, _) -> Left problems + +resolveOne :: Set FilePath -> PackageDescription -> Maybe (LocalBuildInfo, ComponentLocalBuildInfo) -> BuildInfo -> ModuleName.ModuleName -> Either String (String, Src, [AutogenFile]) +resolveOne sources pkgDesc mlbiClbi bi m + | m == autogenPathsModuleName pkgDesc = case mlbiClbi of + Nothing -> + Left $ "cabal buck2: couldn't generate " ++ prettyShow m ++ " (no LocalBuildInfo available for this component)" + Just (lbi, clbi) -> + let file = pathsModuleFile pkgDesc lbi clbi m + in Right (prettyShow m, SrcAutogen (autogenName file), [file]) + | otherwise = case firstExisting sources (moduleCandidates bi m) of + Just real -> Right (prettyShow m, SrcFile real, []) + Nothing -> + Left $ + "cabal buck2: couldn't find a source file for module " + ++ prettyShow m + ++ " under " + ++ intercalate ", " (sourceDirs bi) + +-- | Cabal's own Setup.hs generates a @Paths_\@ module fresh at +-- configure\/build time (giving @version@\/@getDataFileName@\/etc) - no +-- real source file for it exists anywhere to find. Generated here from +-- real Cabal's own 'generatePathsModule' (given this component's real +-- 'LocalBuildInfo'\/'ComponentLocalBuildInfo' - see 'lbiClbiFor'), so +-- install-dir\/relocatability logic matches a plain @cabal build@ exactly. +-- It is referenced from @srcs@ by its @export_file()@ target rather than a +-- path: @cabal-buck2\/autogen\/@ has its own @BUCK@ file, so it is a +-- different buck2 package from the one the sources are in, and a file living +-- there can no longer be named by a package-relative path. +pathsModuleFile :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ModuleName.ModuleName -> AutogenFile +pathsModuleFile pkgDesc lbi clbi m = + AutogenFile + { autogenName = ModuleName.toFilePath m + , autogenPath = ModuleName.toFilePath m <.> "hs" + , autogenContents = generatePathsModule pkgDesc lbi clbi + } + +-- | A @detailed-0.9@ test-suite's own stub @Main@ - see 'testSuite's own +-- haddock for why this is a from-scratch driver over +-- @Distribution.TestSuite@'s public API, not real Cabal's own +-- @Setup.hs@-generated one (@Distribution.Simple.Test.LibV09.stubMain@, +-- which expects a handshake over stdin buck2 has no way to provide). +-- Returned as the test-suite's @main_is@ source, along with the file, +-- referenced by target for the same reason as 'pathsModuleFile'. +detailedTestStub :: String -> ModuleName.ModuleName -> (Src, AutogenFile) +detailedTestStub targetName testModule = (SrcAutogen name, file) + where + name = targetName ++ "-stub-main" + file = AutogenFile{autogenName = name, autogenPath = targetName "Main.hs", autogenContents = contents} + contents = + unlines + [ "-- @generated by `cabal buck2` - do not edit by hand." + , "module Main (main) where" + , "" + , "import Distribution.TestSuite" + , "import qualified " ++ prettyShow testModule ++ " as CabalBuck2TestModule" + , "import System.Exit (ExitCode (..), exitWith)" + , "" + , "main :: IO ()" + , "main = do" + , " ts <- CabalBuck2TestModule.tests" + , " oks <- mapM runTest ts" + , " exitWith (if and oks then ExitSuccess else ExitFailure 1)" + , "" + , "runTest :: Test -> IO Bool" + , "runTest (Test ti) = run ti >>= report (name ti)" + , "runTest (Group _ _ ts) = and <$> mapM runTest ts" + , "runTest (ExtraOptions _ t) = runTest t" + , "" + , "report :: String -> Progress -> IO Bool" + , "report n (Progress msg next) = putStrLn (n ++ \": \" ++ msg) >> next >>= report n" + , "report n (Finished Pass) = putStrLn (n ++ \": PASS\") >> return True" + , "report n (Finished (Fail msg)) = putStrLn (n ++ \": FAIL: \" ++ msg) >> return False" + , "report n (Finished (Error msg)) = putStrLn (n ++ \": ERROR: \" ++ msg) >> return False" + ] + +-- | The files a module's source could be, in order of preference: in each +-- of the @hs-source-dirs@ in turn, with each extension buck2/haskell.bzl's +-- own srcs-resolution (@_resolve_src@) knows to run through +-- hsc2hs()\/alex()\/happy(). +moduleCandidates :: BuildInfo -> ModuleName.ModuleName -> [FilePath] +moduleCandidates bi m = [dir ModuleName.toFilePath m <.> ext | dir <- sourceDirs bi, ext <- ["hs", "lhs", "hsc", "x", "y"]] + +mainIsCandidates :: BuildInfo -> FilePath -> [FilePath] +mainIsCandidates bi mainIs = [dir mainIs | dir <- sourceDirs bi] + +firstExisting :: Set FilePath -> [FilePath] -> Maybe FilePath +firstExisting sources = find (`Set.member` sources) + +-- | 'Left' if the main-is file couldn't be found - see 'resolveModules' +-- for why the caller must skip the whole component rather than emit a +-- rule pointing at a nonexistent file. +resolveMainIs :: Set FilePath -> BuildInfo -> FilePath -> Either [String] FilePath +resolveMainIs sources bi mainIs = + maybe (Left ["cabal buck2: couldn't find main-is file " ++ mainIs ++ " under " ++ intercalate ", " (sourceDirs bi)]) Right $ + firstExisting sources (mainIsCandidates bi mainIs) + +-- | Every path (relative to the package's directory) that +-- 'generatePackageTargets' may look for a component's source in. The +-- generator does no IO, so callers check which of these exist and pass those +-- in. +sourceCandidates :: PackageDescription -> [FilePath] +sourceCandidates pkgDesc = ordNub (concatMap candidates (pkgBuildableComponents pkgDesc)) + where + candidates comp = case comp of + CLib lib -> modules bi (exposedModules lib ++ otherModules bi) + CExe exe -> mainIs bi (getSymbolicPath (modulePath exe)) ++ modules bi (otherModules bi) + CTest test -> case testInterface test of + TestSuiteExeV10 _ main -> mainIs bi (getSymbolicPath main) ++ modules bi (otherModules bi) + TestSuiteLibV09 _ testModule -> modules bi (testModule : otherModules bi) + _ -> [] + CBench bench -> case benchmarkInterface bench of + BenchmarkExeV10 _ main -> mainIs bi (getSymbolicPath main) ++ modules bi (otherModules bi) + _ -> [] + CFLib _ -> [] + where + bi = componentBuildInfo comp + modules bi = concatMap (moduleCandidates bi) + mainIs = mainIsCandidates + +sourceDirs :: BuildInfo -> [FilePath] +sourceDirs bi = case map getSymbolicPath (hsSourceDirs bi) of + [] -> ["."] + ds -> ds diff --git a/src/Distribution/Client/Buck2/LocalPackages.hs b/src/Distribution/Client/Buck2/LocalPackages.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/LocalPackages.hs @@ -0,0 +1,129 @@ +-- | Which packages of a project @cabal buck2@ builds from source with buck2 +-- (rather than leaving to cabal), and facts about them that come from the +-- elaborated install plan rather than from their @.cabal@ files. +module Distribution.Client.Buck2.LocalPackages + ( isBuiltLocally + , packageSourceDir + , componentNamesFor + , builtLocalPackages + , wantedBuildTools + , projectTestOptions + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Data.Map as Map + +import Distribution.Client.DistDirLayout (DistDirLayout (distUnpackedSrcDirectory)) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.ProjectPlanning + ( ElaboratedConfiguredPackage (..) + , ElaboratedInstallPlan + ) +import Distribution.Client.ProjectPlanning.Types + ( BuildStyle (BuildAndInstall) + , ElaboratedPackageOrComponent (ElabComponent, ElabPackage) + , elabComponentName + ) +import Distribution.Client.Types.PackageLocation (PackageLocation (..)) + +import Distribution.Package (PackageName, packageId, packageName) +import Distribution.PackageDescription (PackageDescription) +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.InstallDirs (PathTemplate) +import Distribution.Simple.Utils (die', ordNub) +import Distribution.Types.Component (componentBuildInfo, componentName) +import Distribution.Types.ComponentName (ComponentName (CTestName)) +import Distribution.Types.ExeDependency (ExeDependency (..)) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + + +-- | Does buck2 (rather than cabal) build this package from source? True +-- for every genuinely local package, *plus* every non-local one whose own +-- build was forced 'inplace' by depending on one - when a non-local +-- package is forced inplace it must be built by buck2 from source too, +-- otherwise the build would contain multiple incompatible versions of the +-- local dependency. A real-world example is hackage-security in the cabal +-- project, which is not a local package but depends on the local +-- Cabal-syntax. +isBuiltLocally :: ElaboratedConfiguredPackage -> Bool +isBuiltLocally elab = elabLocalToProject elab || elabBuildStyle elab /= BuildAndInstall + +-- | Real on-disk source directory for any package buck2 builds from +-- source - a genuinely local one (always 'LocalUnpackedPackage') or an +-- inplace non-local one, resolved the same way +-- 'Distribution.Client.ProjectPlanning.Types.dataDirEnvVarForPackage' +-- does for the same 'BuildInplaceOnly' case: a plain source checkout +-- uses its own path directly, anything fetched as a tarball\/repo was +-- already unpacked to 'distUnpackedSrcDirectory' to be built inplace in +-- the first place. +packageSourceDir :: Verbosity -> DistDirLayout -> ElaboratedConfiguredPackage -> IO FilePath +packageSourceDir verbosity distDirLayout elab = case elabPkgSourceLocation elab of + LocalUnpackedPackage dir -> return dir + _ | elabLocalToProject elab -> unsupported + LocalTarballPackage{} -> return unpackedPath + RemoteTarballPackage{} -> return unpackedPath + RepoTarballPackage{} -> return unpackedPath + RemoteSourceRepoPackage _ (Just localCheckout) -> return localCheckout + RemoteSourceRepoPackage{} -> unsupported + where + unpackedPath = distUnpackedSrcDirectory distDirLayout (elabPkgSourceId elab) + unsupported = + die' verbosity $ + "cabal buck2: local package " + ++ prettyShow (packageId elab) + ++ " isn't an unpacked local directory - can't generate a BUCK file for it." + +-- | The buildable component names for one elaborated node - either the +-- single component 'elabComponentName' itself names (per-component +-- elaboration, @ElabComponent@), or *every* buildable component of the +-- whole package it configured (whole-package elaboration, +-- @ElabPackage@ - see 'elabComponentName's own haddock, "there could be +-- more, but default this": one @configureFinal@ call in that mode +-- genuinely produces a 'ComponentLocalBuildInfo' for every component of +-- the package internally, regardless of which single one +-- 'elabComponentName' defaults to). +componentNamesFor :: ElaboratedConfiguredPackage -> PackageDescription -> [ComponentName] +componentNamesFor elab pkgDesc = case elabPkgOrComp elab of + ElabComponent _ -> maybeToList (elabComponentName elab) + ElabPackage _ -> [componentName comp | comp <- PD.pkgBuildableComponents pkgDesc] + +-- | The source directory and (whole-package) 'PackageDescription' of every +-- package buck2 builds from source. Per-component elaboration gives each +-- such package one 'ElaboratedConfiguredPackage' per component, all +-- sharing the same directory and 'PackageDescription', so there is one +-- entry per directory here. +builtLocalPackages :: Verbosity -> DistDirLayout -> ElaboratedInstallPlan -> IO [(FilePath, PackageDescription)] +builtLocalPackages verbosity distDirLayout plan = + fmap (nubBy ((==) `on` fst)) . sequenceA $ + [ do + dir <- packageSourceDir verbosity distDirLayout elab + return (dir, elabPkgDescription elab) + | InstallPlan.Configured elab <- InstallPlan.toList plan + , isBuiltLocally elab + ] + +-- | Every @pkg:exe@ named in any component's @build-tool-depends:@ across +-- the given packages. +wantedBuildTools :: [(FilePath, PackageDescription)] -> [(PackageName, UnqualComponentName)] +wantedBuildTools pkgs = + ordNub + [ (pn, exeName) + | (_dir, pkgDesc) <- pkgs + , comp <- PD.pkgBuildableComponents pkgDesc + , ExeDependency pn exeName _ <- PD.buildToolDepends (componentBuildInfo comp) + ] + +-- | The project's @test-options:@ for each test-suite that has any - only +-- the elaborated package knows them (they aren't part of the @.cabal@ file +-- or the 'LocalBuildInfo'). +projectTestOptions :: ElaboratedInstallPlan -> Map (PackageName, ComponentName) [PathTemplate] +projectTestOptions plan = + Map.fromList + [ ((packageName elab, cname), elabTestTestOptions elab) + | InstallPlan.Configured elab <- InstallPlan.toList plan + , isBuiltLocally elab + , not (null (elabTestTestOptions elab)) + , cname@CTestName{} <- componentNamesFor elab (elabPkgDescription elab) + ] diff --git a/src/Distribution/Client/Buck2/Prebuilt.hs b/src/Distribution/Client/Buck2/Prebuilt.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/Prebuilt.hs @@ -0,0 +1,558 @@ +-- | Register all the external packages and tools that the project +-- depends on for buck2 under @third-party/haskell@. +-- +-- Here's what we generate: +-- +-- * @third-party/haskell/ghc-bin@: symlink to the GHC bin dir +-- +-- * @third-party/haskell/ghc-@: a symlink to the GHC lib dir +-- +-- * @third-party/haskell/cabal-store@: symlink to the Cabal store +-- +-- * @third-party/haskell/build-tools@: contains symlinks to all the build +-- tools this project depends on +-- +-- * @third-party/haskell/BUCK@: all the @haskell_prebuilt_library()@ rules +-- for every external package that this project depends on. These +-- are either GHC built-in packages in @ghc-@ or Cabal store +-- packages in @cabal-store@. +-- +-- * @third-party/haskell/tools.bzl@: paths and constants for tools we +-- depend on. +module Distribution.Client.Buck2.Prebuilt + ( generatePrebuilt + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Data.ByteString as BS +import Data.Char (isHexDigit) +import Data.List (stripPrefix) +import qualified Data.Map as Map + +import System.Directory + ( createDirectoryIfMissing + , createFileLink + , doesFileExist + , doesPathExist + , removeDirectoryRecursive + , removeFile + ) +import System.FilePath + ( isAbsolute + , isPathSeparator + , joinPath + , makeRelative + , pathSeparator + , splitDirectories + , splitPath + , takeDirectory + , (<.>) + , () + ) + +import qualified Distribution.Client.InstallPlan as InstallPlan + +import Distribution.Client.DistDirLayout + ( CabalDirLayout (cabalStoreDirLayout) + , StoreDirLayout (storeDirectory, storePackageDBPath) + ) +import Distribution.Client.ProjectPlanning + ( ElaboratedConfiguredPackage (elabInstallDirs) + , ElaboratedInstallPlan + , ElaboratedSharedConfig (pkgConfigCompiler, pkgConfigCompilerProgs, pkgConfigPlatform) + ) +import Distribution.Client.ProjectPlanning.Types (elabComponentName) +import Distribution.Types.ComponentName (ComponentName (CExeName)) + +import Distribution.InstalledPackageInfo (parseInstalledPackageInfo) +import Distribution.Package (HasUnitId (installedUnitId), packageName, packageVersion) +import Distribution.Simple.BuildPaths (exeExtension) +import Distribution.Simple.Compiler + ( Compiler (compilerProperties) + , compilerVersion + ) +import Distribution.Simple.GHC (getGlobalPackageDB) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.Program.Builtin (ghcProgram) +import Distribution.Simple.Program.Db (lookupProgram) +import Distribution.Simple.Program.Types (programPath) +import Distribution.Simple.Utils (die', notice, ordNub, warn) +import Distribution.Types.InstalledPackageInfo + ( InstalledPackageInfo + ( depends + , extraLibraries + , hsLibraries + , includeDirs + , libraryDirs + , libraryDynDirs + , sourceLibName + ) + ) +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.UnitId (UnitId, unUnitId) +import Distribution.Types.UnqualComponentName (UnqualComponentName, unUnqualComponentName) + +import Distribution.Client.Buck2.Generate (libTargetName) +import Distribution.Client.Buck2.Starlark + +-- | Generate\/refresh @third-party\/haskell@ from the dependency closure +-- of an already-built, already-pruned install plan. Returns: +-- +-- * The name of every @wantedBuildTools@ pair this project's own +-- dependency closure resolved a real binary for - each one also +-- gets a real @export_file()@ target in the generated +-- @third-party\/haskell\/BUCK@ (@\/\/third-party\/haskell:\-exe@), +-- for "Distribution.Client.Buck2.Generate" to reference from a +-- component's own @build_tool_depends@ (see that module's own +-- @buildToolDependsArg@) - a real buck2 dependency edge, not a +-- host-filesystem symlink farm resolved once at generation time (the +-- wanted pair's own *local*-package half, if any, is a completely +-- separate case handled entirely by "Distribution.Client.Buck2.Generate" itself, referencing +-- that package's own real, already-generated @haskell_binary()@ +-- target directly - this function only ever sees, and only needs to +-- handle, already-installed *external* dependencies). +-- * The real, already-parsed 'InstalledPackageInfo' for every resolved +-- dependency - callers that need a real +-- 'Distribution.Simple.PackageIndex.InstalledPackageIndex' (e.g. to +-- build a genuine 'LocalBuildInfo' via "Distribution.Client.InLibrary", +-- the way "Distribution.Client.Buck2.Configure" does) can build one directly +-- from this via 'PackageIndex.fromList' without a second, independent +-- walk of the same @.conf@ files. +generatePrebuilt + :: Verbosity + -> FilePath + -- ^ project root (the buck2 cell root) + -> CabalDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -- ^ 'elaboratedPlanToExecute': already pruned to exactly the (test\/ + -- benchmark-flag-aware) dependency closure that was just built. Never + -- contains a package buck2 builds from source itself (a local package, + -- or a non-local one built @inplace@ because it depends on one - see + -- 'Distribution.Client.Buck2.LocalPackages.isBuiltLocally'): those get a real @haskell_library()@ from + -- "Distribution.Client.Buck2.Generate" instead, and are excluded from + -- this plan before it's even built. So every unit id here is either a + -- GHC global\/boot package or one installed to the cabal store. + -> [(PackageName, UnqualComponentName)] + -- ^ Every @pkg:exe@ named in any local component's own + -- @build-tool-depends:@, across the whole project - see this + -- function's own return-value haddock above. + -> IO (Set String, [InstalledPackageInfo]) +generatePrebuilt verbosity projectRoot cabalDirLayout shared depsPlan wantedBuildTools = do + ghcProg <- + maybe (die' verbosity "cabal buck2: no 'ghc' program configured for this project - internal error.") return $ + lookupProgram ghcProgram (pkgConfigCompilerProgs shared) + let compiler = pkgConfigCompiler shared + ghcVersionStr = prettyShow (compilerVersion compiler) + ghcDynamic = Map.lookup "GHC Dynamic" (compilerProperties compiler) == Just "YES" + storeLayout = cabalStoreDirLayout cabalDirLayout + storeDB = storePackageDBPath storeLayout compiler + storeRootAbs = storeDirectory storeLayout compiler + targetDir = projectRoot "third-party" "haskell" + ghcBinAbs = takeDirectory (programPath ghcProg) + + globalDB <- getGlobalPackageDB verbosity ghcProg + let globalRootAbs = takeDirectory globalDB + + allUnitIds = ordNub [installedUnitId pkg | pkg <- InstallPlan.toList depsPlan] + paths = + RepoPaths + { rpGhcVersion = ghcVersionStr + , rpGlobalRootAbs = globalRootAbs + , rpStoreRootAbs = storeRootAbs + , rpStoreDbRel = makeRelative storeRootAbs storeDB + } + + createDirectoryIfMissing True targetDir + ensureSymlink (targetDir ("ghc-" ++ ghcVersionStr)) globalRootAbs + ensureSymlink (targetDir "ghc-bin") ghcBinAbs + + notice verbosity "cabal buck2: resolving prebuilt dependency closure" + packages <- catMaybes <$> traverse (readPackage verbosity paths storeDB) allUnitIds + let alexPath = findToolBinary paths shared depsPlan "alex" + happyPath = findToolBinary paths shared depsPlan "happy" + -- Every @build-tool-depends: pkg:exe@ pair the *external* + -- (already-installed) dependency closure can resolve a real + -- binary for - a local-package pair is never in `depsPlan` at all + -- (see this function's own haddock on that parameter), so this + -- silently, correctly resolves to nothing for one; entirely + -- 'Distribution.Client.Buck2.Generate's own job to notice that case and reference the + -- local package's real target directly instead. + buildToolPaths = + Map.fromList + [ (unUnqualComponentName exeName, path) + | (pn, exeName) <- ordNub wantedBuildTools + , Just path <- [findExeBinaryAbs shared depsPlan pn exeName] + ] + + -- Needed by any package's own library files, *and* independently by + -- alex/happy's/any build-tool-depends executable's own binary path - + -- a build-tool-only dependency (an executable, no library) + -- contributes no ResolvedPackage at all (see readPackage), so + -- checking `packages` alone would miss a project that needs alex/ + -- happy/a preprocessor tool but nothing else store-installed. + when + ( any ((== StoreDb) . rpDbKind) packages + || any inStore (alexPath : happyPath : map (toRepoRelative paths) (Map.elems buildToolPaths)) + ) + $ ensureSymlink (targetDir "cabal-store") storeRootAbs + + -- An earlier version generated a filtered copy of the store's package db here. + removeStaleStoreDB (targetDir "store-db") + + notice verbosity "cabal buck2: generating third-party/haskell/BUCK" + writeBuckFile targetDir paths packages buildToolPaths + + writeToolsFile targetDir ghcVersionStr ghcDynamic alexPath happyPath + + return (Map.keysSet buildToolPaths, map rpInfo packages) + +-- | The repo-relative anchors every generated path is expressed against: +-- the symlinks 'generatePrebuilt' just created, plus the GHC version +-- string (needed for both the global db's own relative path and +-- shared-library sonames). +data RepoPaths = RepoPaths + { rpGhcVersion :: String + , rpGlobalRootAbs :: FilePath + , rpStoreRootAbs :: FilePath + , rpStoreDbRel :: FilePath + -- ^ The store's package db, relative to 'rpStoreRootAbs'. + } + +-- | Which of the two package dbs a unit id's @.conf@ lives in - decided +-- entirely by the unit id's own shape, no searching required (unlike the +-- Python predecessor, which had to glob for the store root, not knowing +-- its ABI-tag suffix in advance): GHC's global\/boot packages have a plain +-- @name-version@ id; a package installed to the store gets a +-- hash-suffixed one. (An @-inplace@ id - a package buck2 builds itself - +-- never gets here: see 'generatePrebuilt's plan parameter.) +data PkgDbKind = GlobalDb | StoreDb + deriving (Eq) + +classifyUnitId :: UnitId -> PkgDbKind +classifyUnitId uid + | hasStoreHashSuffix s = StoreDb + | otherwise = GlobalDb + where + s = unUnitId uid + hasStoreHashSuffix rs = case break (== '-') (reverse rs) of + (revSuffix, '-' : _) -> length revSuffix >= 20 && all isHexDigit revSuffix + _ -> False + +-- | A resolved package: its metadata plus which package db it came from +-- (needed to pick the right @db =@ value in the generated rule, and to +-- know where to find its @.conf@ file). +data ResolvedPackage = ResolvedPackage + { rpInfo :: InstalledPackageInfo + , rpUnitId :: UnitId + , rpDbKind :: PkgDbKind + , rpStaticLibs :: [FilePath] + , rpProfiledLibs :: [FilePath] + , rpSharedLibs :: [(String, FilePath)] + } + +confPath :: FilePath -> FilePath -> UnitId -> FilePath +confPath globalRootAbs storeDB uid = case classifyUnitId uid of + GlobalDb -> globalRootAbs "package.conf.d" unUnitId uid <.> "conf" + StoreDb -> storeDB unUnitId uid <.> "conf" + +readPackage :: Verbosity -> RepoPaths -> FilePath -> UnitId -> IO (Maybe ResolvedPackage) +readPackage verbosity paths storeDB uid = do + let dbKind = classifyUnitId uid + path = confPath (rpGlobalRootAbs paths) storeDB uid + exists <- doesFileExist path + if not exists + then do + warn verbosity $ + "cabal buck2: no .conf file for " + ++ unUnitId uid + ++ " (expected at " + ++ path + ++ "); packages are only found in GHC's global package db and the cabal store, not in other package dbs" + return Nothing + else do + contents <- BS.readFile path + case parseInstalledPackageInfo contents of + Left errs -> do + warn verbosity $ "cabal buck2: couldn't parse " ++ path ++ ": " ++ intercalate "; " (toList errs) + return Nothing + Right (_warnings, ipi0) -> do + -- '${pkgroot}' is the directory *containing* the package db (one + -- level above the .conf file's own db directory, e.g. + -- ".../lib" for a ".../lib/package.conf.d/.conf" file) - + -- not the db directory itself. + let ipi = mungePkgroot (takeDirectory (takeDirectory path)) ipi0 + isRts = prettyShow (packageName ipi) == "rts" + staticLibs <- findLibs paths (libraryDirs ipi) ["lib" ++ stem <.> "a" | stem <- hsLibraries ipi] + -- GHC doesn't build profiled RTS libraries the normal way - see + -- gen-haskell-prebuilt.py's own note on this, which this + -- inherits without fully understanding why either. + profiledLibs <- + if isRts + then return [] + else findLibs paths (libraryDirs ipi) ["lib" ++ stem ++ "_p" <.> "a" | stem <- hsLibraries ipi] + sharedLibs <- findSharedLibs paths ipi + return $ Just (ResolvedPackage ipi uid dbKind staticLibs profiledLibs sharedLibs) + +-- | Resolve each candidate filename against @dirs@ in turn, keeping only +-- the ones that actually exist on disk (unlike gen-haskell-prebuilt.py's +-- Python predecessor, this doesn't assume every @hs-libraries@ stem has a +-- library of every flavour - e.g. rts's second stem, \"Cffi\", only ever +-- ships as a static archive, never as a @.so@). +findLibs :: RepoPaths -> [FilePath] -> [String] -> IO [FilePath] +findLibs paths dirs fnames = catMaybes <$> traverse (findOne paths dirs) fnames + +findOne :: RepoPaths -> [FilePath] -> String -> IO (Maybe FilePath) +findOne paths dirs fname = go dirs + where + go [] = return Nothing + go (d : ds) = do + let absPath = d fname + exists <- doesFileExist absPath + if exists + then return (toRepoRelative paths absPath) + else go ds + +findSharedLibs :: RepoPaths -> InstalledPackageInfo -> IO [(String, FilePath)] +findSharedLibs paths ipi = catMaybes <$> traverse oneStem (hsLibraries ipi) + where + dirs = libraryDynDirs ipi ++ libraryDirs ipi + oneStem stem = do + let soname = "lib" ++ stem ++ "-ghc" ++ rpGhcVersion paths ++ ".so" + mpath <- findOne paths dirs soname + return ((,) soname <$> mpath) + +-- | @.conf@ files use @${pkgroot}@ (the directory containing the package +-- db) as a portable stand-in for their own absolute location - GHC's own +-- @ghc-pkg@ expands this when it serves package info, but reading the +-- file directly (as 'parseInstalledPackageInfo' does here) doesn't, so +-- library-dirs\/include-dirs come back as literal, unusable +-- @"${pkgroot}/..."@ strings unless expanded by hand. Mirrors +-- 'Distribution.Simple.Program.HcPkg.mungePackagePaths', which isn't +-- exported. +mungePkgroot :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +mungePkgroot pkgroot ipi = + ipi + { libraryDirs = map munge (libraryDirs ipi) + , libraryDynDirs = map munge (libraryDynDirs ipi) + , includeDirs = map munge (includeDirs ipi) + } + where + munge p = maybe p collapseDotDot (stripPkgroot p) + stripPkgroot p = case splitPath p of + (root : rest) -> case stripPrefix "${pkgroot}" root of + Just [sep] | isPathSeparator sep -> Just (pkgroot joinPath rest) + _ -> Nothing + _ -> Nothing + +-- | @${pkgroot}@ substitution routinely produces a @.../package.conf.d/ +-- ../lib/...@ path (since @${pkgroot}@ is the db directory, and the real +-- libraries live next to it, not under it) - harmless as a real filesystem +-- path, but buck2 rejects any @attrs.source()@ containing a literal +-- @".."@ component ("expected a normalized path"), so it has to be +-- collapsed before it ever reaches a generated rule. Unlike +-- 'System.FilePath.normalise' (which only tidies separators\/dots, not +-- @".."@ segments - not safe in general with symlinks in play, but safe +-- here since every path this is applied to is already fully resolved: +-- real, non-symlink directories under GHC's own libdir or the cabal +-- store). +collapseDotDot :: FilePath -> FilePath +collapseDotDot = joinPath . reverse . foldl' step [] . splitDirectories + where + step (top : rest) ".." | top /= ".." && top /= [pathSeparator] = rest + step stack "." = stack + step stack seg = seg : stack + +-- | Point @link@ at @target@, creating or repointing it as needed. +ensureSymlink :: FilePath -> FilePath -> IO () +ensureSymlink link target = do + exists <- doesPathExist link + when exists $ removeFile link + createFileLink target link + +-- | Remove the filtered package db that earlier versions generated. +removeStaleStoreDB :: FilePath -> IO () +removeStaleStoreDB dir = do + exists <- doesPathExist dir + when exists $ removeDirectoryRecursive dir + +writeBuckFile :: FilePath -> RepoPaths -> [ResolvedPackage] -> Map String FilePath -> IO () +writeBuckFile targetDir paths packages buildToolPaths = + writeFile (targetDir "BUCK") (renderFile header [] calls) + where + header = "@generated by `cabal buck2` - do not edit by hand.\nRe-run `cabal buck2` to update." + uidToTarget = Map.fromList [(rpUnitId p, targetName p) | p <- packages] + calls = + [prebuiltCall paths uidToTarget p | p <- packages] + ++ [buildToolExportCall name relPath | (name, relPath) <- Map.toList (Map.mapMaybe (toRepoRelative paths) buildToolPaths)] + +-- | One @export_file()@ per resolved @build-tool-depends@ executable - +-- gives it a real buck2 target ('DefaultInfo' with a single default +-- output, basename forced to the tool's own bare name, executable bit +-- forced on regardless of whatever @copy_file@'s own default happens to +-- preserve) that any component's own @build_tool_depends@ can reference +-- directly, the same @export_file()@ primitive this project already +-- uses for autogen files - see "Distribution.Client.Buck2.Generate"'s +-- own @buildToolDependsArg@ for the consuming side, and +-- @buck2\/prelude\/decls\/haskell_common.bzl@'s own comment on the attr +-- for why this needs to be a real target at all (not a host-filesystem +-- symlink, superseded by this). +buildToolExportCall :: String -> FilePath -> Call +buildToolExportCall name relPath = + call + "export_file" + [ ("name", str (name ++ "-exe")) + , ("src", str relPath) + , ("out", str name) + , ("mode", str "copy") + , ("executable_bit_override", VBool True) + , ("visibility", strList ["PUBLIC"]) + ] + +-- | Unlike a local package (one @haskell_library()@ per library, main or +-- named sub-library alike - see 'libTargetName'), a *prebuilt* one used +-- to get exactly one @haskell_prebuilt_library()@ per package name, +-- regardless of how many of its libraries were actually in the +-- dependency closure - a real bug, not just a theoretical gap: a package +-- with an internal sub-library (e.g. @attoparsec@'s own +-- @attoparsec-internal@) resolves to *two* units here, and buck2 +-- rejected the second @haskell_prebuilt_library()@ outright as a +-- duplicate target the first time this was tried against a real, +-- large project. 'sourceLibName' (parsed straight from the @.conf@, +-- the exact same 'LibraryName' a local package's own 'libName' would +-- give) is what 'libTargetName' needs to tell them apart, the same way +-- it already does for local packages. +targetName :: ResolvedPackage -> String +targetName p = libTargetName (packageName (rpInfo p)) (sourceLibName (rpInfo p)) + +prebuiltCall :: RepoPaths -> Map UnitId String -> ResolvedPackage -> Call +prebuiltCall paths uidToTarget p = + call + "haskell_prebuilt_library" + ( [ ("name", str (targetName p)) + , ("version", str (prettyShow (packageVersion (rpInfo p)))) + , ("id", str (unUnitId (rpUnitId p))) + , ("db", str (if rpDbKind p == GlobalDb then globalDbRel else "cabal-store" rpStoreDbRel paths)) + , ("static_libs", strList (rpStaticLibs p)) + ] + ++ [("profiled_static_libs", strList (rpProfiledLibs p)) | not (null (rpProfiledLibs p))] + ++ [("pic_profiled_static_libs", strList (rpProfiledLibs p)) | not (null (rpProfiledLibs p))] + ++ [("shared_libs", VDict [(soname, str sopath) | (soname, sopath) <- rpSharedLibs p])] + ++ [("cxx_header_dirs", strList headerDirs) | not (null headerDirs)] + ++ [("exported_linker_flags", strList extraLinkerFlags) | not (null extraLinkerFlags)] + ++ [("deps", strList depTargets) | not (null depTargets)] + ++ [("visibility", strList ["PUBLIC"])] + ) + where + info = rpInfo p + globalDbRel = ("ghc-" ++ rpGhcVersion paths) "package.conf.d" + headerDirs = mapMaybe (toRepoRelative paths) (includeDirs info) + extraLinkerFlags = ["-l" ++ lib | lib <- extraLibraries info] + depTargets = ordNub [":" ++ t | d <- depends info, Just t <- [Map.lookup d uidToTarget]] + +-- | Convert an absolute path under GHC's libdir or the cabal store into +-- one relative to @third-party\/haskell@, via whichever symlink +-- 'generatePrebuilt' pointed there actually contains it - the same +-- translation gen-haskell-prebuilt.py's own @abs_to_rel@ did. +toRepoRelative :: RepoPaths -> FilePath -> Maybe FilePath +toRepoRelative paths path + | not (isAbsolute path) = Nothing + | otherwise = + relTo (rpGlobalRootAbs paths) ("ghc-" ++ rpGhcVersion paths) path + <|> relTo (rpStoreRootAbs paths) "cabal-store" path + +relTo :: FilePath -> FilePath -> FilePath -> Maybe FilePath +relTo root repoRelPrefix path = + let r = makeRelative root path + in if r /= path then Just (repoRelPrefix r) else Nothing + +-- | The store-installed binary path (repo-relative, like everything else +-- 'toRepoRelative' produces) for a build-tool dependency package - e.g. +-- @alex@\/@happy@, needed by buck2/alex_happy.bzl to preprocess @.x@\/@.y@ +-- sources - or 'Nothing' if the project doesn't need it at all. A +-- simplified 'CmdListBin.elaboratedPackage'\/@bin_file'@: alex\/happy are +-- always external Hackage dependencies, never a local package, so the +-- inplace-build-style branch that logic also has to handle never applies +-- here, and (being plain, single-executable packages) their own +-- executable is always named after the package itself, with no need to +-- resolve a target selector to find out which component that is. +findToolBinary :: RepoPaths -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> String -> Maybe FilePath +findToolBinary paths shared plan toolName = + listToMaybe + [ rel + | pkg <- InstallPlan.toList plan + , Just elab <- [configuredOrInstalled pkg] + , prettyShow (packageName elab) == toolName + , let absPath = InstallDirs.bindir (elabInstallDirs elab) toolName <.> exeExtension (pkgConfigPlatform shared) + , Just rel <- [toRepoRelative paths absPath] + ] + +-- | The real, absolute binary path for one @pkg:exe@ pair - 'Nothing' if +-- that package isn't in the resolved dependency closure at all, or has +-- no matching executable +-- component. Unlike 'findToolBinary' (which assumes the executable is +-- named after its own package - true for alex\/happy, both self-named +-- single-executable packages), this matches the package and executable +-- names independently, since a @build-tool-depends: pkg:exe@ entry can +-- legitimately name them differently. +-- +-- A package brought in purely as a @build-tool-depends@ needs commonly +-- elaborate to *two* distinct plan nodes for the same package name - a +-- whole-package one (@elabComponentName@ @Nothing@ or some other +-- component) and a real per-executable one (@elabComponentName == +-- Just (CExeName exeName)@) - and only the latter's own +-- 'elabInstallDirs' has a real, populated @bindir@ (confirmed the hard +-- way: the former's own @bindir@ computes to a real-looking but +-- entirely empty directory, no error, just @createProcess: posix_spawnp: +-- does not exist@ at the point of actually trying to run it). Preferring +-- an exact component-name match - falling back to any match sharing the +-- package name only if none exists, the same as 'findToolBinary' always +-- did - fixes this without needing to know in advance which shape a +-- given package's own plan happens to take. +findExeBinaryAbs :: ElaboratedSharedConfig -> ElaboratedInstallPlan -> PackageName -> UnqualComponentName -> Maybe FilePath +findExeBinaryAbs shared plan pn exeName = + listToMaybe (exact ++ fallback) + where + candidates = + [ elab + | pkg <- InstallPlan.toList plan + , Just elab <- [configuredOrInstalled pkg] + , packageName elab == pn + ] + binPathFor elab = InstallDirs.bindir (elabInstallDirs elab) unUnqualComponentName exeName <.> exeExtension (pkgConfigPlatform shared) + exact = [binPathFor elab | elab <- candidates, elabComponentName elab == Just (CExeName exeName)] + fallback = [binPathFor elab | elab <- candidates] + +-- | Same package, in either of the two states a *non-local* dependency +-- that's actually going to be used can be in: 'Configured' (needs +-- building this run) or 'Installed' (already built and installed from a +-- previous run, nothing to do - which is what alex/happy settle into on +-- any @cabal buck2@ after the first, once their build is cached). Unlike +-- 'installedUnitId' (a 'HasUnitId' method, already defined uniformly +-- across all three 'GenericPlanPackage' constructors), there's no +-- existing helper for this, since most other call sites here only need +-- the unit id, not the full 'ElaboratedConfiguredPackage'. +configuredOrInstalled :: InstallPlan.GenericPlanPackage ipkg srcpkg -> Maybe srcpkg +configuredOrInstalled (InstallPlan.Configured spkg) = Just spkg +configuredOrInstalled (InstallPlan.Installed spkg) = Just spkg +configuredOrInstalled InstallPlan.PreExisting{} = Nothing + +inStore :: Maybe FilePath -> Bool +inStore = maybe False ("cabal-store" `isPrefixOf`) + +writeToolsFile :: FilePath -> String -> Bool -> Maybe FilePath -> Maybe FilePath -> IO () +writeToolsFile targetDir ghcVersionStr ghcDynamic alexPath happyPath = + writeFile (targetDir "tools.bzl") $ + unlines + [ "# @generated by `cabal buck2` - do not edit by hand." + , "# Re-run `cabal buck2` to update." + , "" + , "GHC_VERSION = " ++ show ghcVersionStr + , "GHC_BIN_DIR = \"third-party/haskell/ghc-bin\"" + , "GHC_DYNAMIC = " ++ (if ghcDynamic then "True" else "False") + , "" + , "ALEX = " ++ show ("third-party/haskell/" ++ fromMaybe "missing" alexPath) + , "HAPPY = " ++ show ("third-party/haskell/" ++ fromMaybe "missing" happyPath) + ] diff --git a/src/Distribution/Client/Buck2/Schedule.hs b/src/Distribution/Client/Buck2/Schedule.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/Schedule.hs @@ -0,0 +1,73 @@ +-- | Running a dependency graph of jobs concurrently. +module Distribution.Client.Buck2.Schedule + ( runDependencyGraph + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Control.Concurrent.Async as Async +import Control.Concurrent.STM + ( atomically + , modifyTVar' + , newTVarIO + , readTVar + , retry + , writeTVar + ) + +import Distribution.Simple.Utils (ordNub) + +-- | @runDependencyGraph n deps process@ runs @process k@ once for every key +-- @k@ of @deps@, on up to @n@ threads, but only after @process@ has finished +-- for each of the keys @deps@ lists for @k@. Dependencies that aren't keys of +-- @deps@ are ignored. Returns when every job has finished; if one throws, the +-- rest are cancelled and the exception is rethrown. The graph must be +-- acyclic. +-- +-- Jobs are scheduled by their direct dependencies alone, so a job is +-- available to run as soon as the jobs it depends on are done. +runDependencyGraph :: Ord k => Int -> Map k [k] -> (k -> IO ()) -> IO () +runDependencyGraph numWorkers deps process = do + let jobs = Map.keysSet deps + dependenciesOf = Map.map (ordNub . filter (`Set.member` jobs)) deps + dependents = Map.fromListWith (++) [(d, [k]) | (k, ds) <- Map.toList dependenciesOf, d <- ds] + totalJobs = Map.size deps + + remainingVar <- newTVarIO (Map.map length dependenciesOf) + readyVar <- newTVarIO [k | (k, []) <- Map.toList dependenciesOf] + finishedVar <- newTVarIO (0 :: Int) + + let finishJob k = do + remaining <- readTVar remainingVar + let (remaining', newlyReady) = + foldl' + ( \(rs, ready) d -> + let n = Map.findWithDefault 0 d rs - 1 + in (Map.insert d n rs, if n == 0 then d : ready else ready) + ) + (remaining, []) + (Map.findWithDefault [] k dependents) + writeTVar remainingVar remaining' + modifyTVar' readyVar (newlyReady ++) + modifyTVar' finishedVar (+ 1) + + nextJob = do + ready <- readTVar readyVar + case ready of + (k : rest) -> writeTVar readyVar rest >> return (Just k) + [] -> do + finished <- readTVar finishedVar + if finished == totalJobs then return Nothing else retry + + worker = do + mk <- atomically nextJob + for_ mk $ \k -> do + process k + atomically (finishJob k) + worker + + Async.replicateConcurrently_ numWorkers worker diff --git a/src/Distribution/Client/Buck2/Setup.hs b/src/Distribution/Client/Buck2/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/Setup.hs @@ -0,0 +1,45 @@ +-- | Set up the project for building with @buck2@ +module Distribution.Client.Buck2.Setup + ( checkBuck2Prelude + , ensureBuckconfigAndPackage + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath (()) + +import Distribution.Simple.Utils (die', notice) + + +-- | Check that the @buck2@ support code is at @buck2\/@ +checkBuck2Prelude :: Verbosity -> FilePath -> IO () +checkBuck2Prelude verbosity projectRoot = do + exists <- doesDirectoryExist (projectRoot "buck2") + unless exists $ + die' verbosity $ + unlines + [ "No 'buck2/' directory found in the project root." + , "Clone the buck2 prelude and support scripts with:" + , "" + , " git clone https://github.com/simonmar/haskell-buck2 buck2" + , "" + , "then re-run 'cabal buck2'." + ] + +-- | Copy @.buckconfig@ and @PACKAGE@ if they don't exist +ensureBuckconfigAndPackage :: Verbosity -> FilePath -> IO () +ensureBuckconfigAndPackage verbosity projectRoot = do + copyIfMissing verbosity (exampleDir ".buckconfig") (projectRoot ".buckconfig") + copyIfMissing verbosity (exampleDir "PACKAGE") (projectRoot "PACKAGE") + where + exampleDir = projectRoot "buck2" "example" + +copyIfMissing :: Verbosity -> FilePath -> FilePath -> IO () +copyIfMissing verbosity src dest = do + exists <- doesFileExist dest + unless exists $ do + contents <- readFile src + writeFile dest contents + notice verbosity $ "cabal buck2: created " ++ dest ++ " (from " ++ src ++ ")" diff --git a/src/Distribution/Client/Buck2/Spec.hs b/src/Distribution/Client/Buck2/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/Spec.hs @@ -0,0 +1,94 @@ +-- | The build spec: a description of a package's components from +-- which buck2\/cabal.bzl creates the buck2 rules. +-- "Distribution.Client.Buck2.Write" writes the spec into the +-- @BUCK.cabal.bzl@ file. +module Distribution.Client.Buck2.Spec + ( specSchemaVersion + , BuildSpec (..) + , ComponentKind (..) + , kindName + , SpecComponent (..) + , Src (..) + , SpecDep (..) + , SpecBuildTool (..) + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +-- | The version of the build spec format; must match @SCHEMA_VERSION@ in +-- buck2\/cabal.bzl. +specSchemaVersion :: Int +specSchemaVersion = 1 + +-- | A package's build spec: everything the generated rules are built from +-- that comes from Cabal rather than from buck2 conventions. +data BuildSpec = BuildSpec + { specPackageName :: String + , specPackageDir :: FilePath + -- ^ Relative to the buck2 cell root, @.@ at the root. + , specGhcOptions :: [String] + -- ^ Supplied by the project, not the @.cabal@ file. + , specComponents :: [SpecComponent] + } + +data ComponentKind = Library | Executable | TestSuite | Benchmark + deriving (Eq) + +-- | As it appears in the spec and in messages: @library@, @executable@, +-- @test-suite@ or @benchmark@. +kindName :: ComponentKind -> String +kindName Library = "library" +kindName Executable = "executable" +kindName TestSuite = "test-suite" +kindName Benchmark = "benchmark" + +-- | One component of a build spec. List fields are empty when the +-- corresponding @.cabal@ field is. +data SpecComponent = SpecComponent + { scKind :: ComponentKind + , scName :: String + -- ^ Also the name of the buck2 target. + , scMainIs :: Maybe Src + -- ^ The main module's source; not for a library. + , scSrcs :: [(String, Src)] + -- ^ Every other module (by module name) and its source. + , scTestArgs :: [String] + -- ^ The project's @test-options@ for a test-suite, with template variables + -- expanded. + , scGhcOptions :: [String] + , scCppOptions :: [String] + , scLanguage :: Maybe String + , scExtensions :: [String] + , scExtraLibraries :: [String] + , scDeps :: [SpecDep] + , scBuildTools :: [SpecBuildTool] + , scCSources :: [FilePath] + , scCxxSources :: [FilePath] + , scCxxOptions :: [String] + , scIncludeDirs :: [FilePath] + , scPkgconfig :: [String] + } + +-- | A source file of a component: either a real file in the package +-- (relative to its directory), or one generated into the package's +-- @cabal-buck2\/autogen@ directory, named by its @export_file()@ entry there +-- (see 'Distribution.Client.Buck2.Generate.AutogenFile'). +data Src = SrcFile FilePath | SrcAutogen String + +-- | A library a component depends on. +data SpecDep = SpecDep + { depPackage :: String + , depLibrary :: Maybe String + -- ^ The sub-library, if the main library isn't the one depended on. + , depDir :: Maybe FilePath + -- ^ The package's directory (relative to the cell root) if it's built by + -- this project. + } + +-- | An executable that a component's @build-tool-depends@ needs on @PATH@. +data SpecBuildTool + = -- | Built by this project, in the given directory. + LocalTool {toolExe :: String, toolDir :: FilePath} + | -- | An already-installed binary, exported from @third-party\/haskell@. + ExternalTool {toolExe :: String} diff --git a/src/Distribution/Client/Buck2/Starlark.hs b/src/Distribution/Client/Buck2/Starlark.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/Starlark.hs @@ -0,0 +1,116 @@ +-- | A minimal Starlark (BUCK file) pretty-printer. +-- +-- This deliberately doesn't attempt to represent the whole Starlark +-- language: it covers exactly the subset (string/int/bool scalars, lists, +-- dicts, @load@ statements and top-level rule calls) that generated +-- @BUCK@\/@.bzl@ files need, so every generator in "Distribution.Client.Buck2" +-- builds output through the same renderer instead of hand-formatting +-- strings. +module Distribution.Client.Buck2.Starlark + ( Value (..) + , str + , strList + , Call (..) + , call + , renderCall + , renderLoad + , renderBinding + , renderFile + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +-- | A Starlark expression, restricted to what BUCK files actually need: +-- scalars and (recursively) lists and dicts of them. +data Value + = VStr String + | VInt Int + | VBool Bool + | VList [Value] + | VDict [(String, Value)] + +str :: String -> Value +str = VStr + +strList :: [String] -> Value +strList = VList . map VStr + +-- | A single top-level rule invocation, e.g. @haskell_library(name = ..., ...)@. +data Call = Call + { callFn :: String + , callArgs :: [(String, Value)] + } + +call :: String -> [(String, Value)] -> Call +call = Call + +indent :: Int -> String +indent n = replicate (4 * n) ' ' + +-- | Render like Python's @repr@ for a single-quoted string: this is what +-- both buck2/gen-haskell-prebuilt.py's generated output and every +-- hand-written @.bzl@ file in buck2/ already use. +renderStr :: String -> String +renderStr s = '\'' : concatMap escape s ++ "'" + where + escape '\\' = "\\\\" + escape '\'' = "\\'" + escape '\n' = "\\n" + escape '\t' = "\\t" + escape c = [c] + +renderValue :: Int -> Value -> String +renderValue _ (VStr s) = renderStr s +renderValue _ (VInt n) = show n +renderValue _ (VBool b) = if b then "True" else "False" +renderValue _ (VList []) = "[]" +renderValue ind (VList xs) = + "[\n" + ++ concat [indent (ind + 1) ++ renderValue (ind + 1) x ++ ",\n" | x <- xs] + ++ indent ind + ++ "]" +renderValue _ (VDict []) = "{}" +renderValue ind (VDict kvs) = + "{\n" + ++ concat + [ indent (ind + 1) ++ renderStr k ++ ": " ++ renderValue (ind + 1) v ++ ",\n" + | (k, v) <- kvs + ] + ++ indent ind + ++ "}" + +-- | Render a rule call as a standalone top-level statement, one argument +-- per line (matching the style buck2/gen-haskell-prebuilt.py's own +-- generated BUCK file uses), terminated by a blank line. +renderCall :: Call -> String +renderCall (Call fn args) = + fn + ++ "(\n" + ++ concat + [ indent 1 ++ k ++ " = " ++ renderValue 1 v ++ ",\n" + | (k, v) <- args + ] + ++ ")\n" + +-- | Render a top-level @NAME = value@ statement. +renderBinding :: String -> Value -> String +renderBinding name v = name ++ " = " ++ renderValue 0 v ++ "\n" + +-- | Render a @load("target", "name1", "name2")@ statement. +renderLoad :: String -> [String] -> String +renderLoad target names = + "load(" ++ intercalate ", " (renderStr target : map renderStr names) ++ ")\n" + +-- | Render a full generated file: a header comment, the accumulated +-- @load@ statements, then each rule call in turn, separated by blank +-- lines. +renderFile :: String -> [(String, [String])] -> [Call] -> String +renderFile header loads calls = + unlines (map ("# " ++) headerLines) + ++ "\n" + ++ concatMap (uncurry renderLoad) loads + ++ "\n" + ++ intercalate "\n" (map renderCall calls) + where + headerLines = lines header diff --git a/src/Distribution/Client/Buck2/Unpack.hs b/src/Distribution/Client/Buck2/Unpack.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/Unpack.hs @@ -0,0 +1,101 @@ +-- | Unpacking the source of packages that buck2 builds, without building +-- anything. +module Distribution.Client.Buck2.Unpack + ( unpackInplaceSources + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) +import System.FilePath ((<.>), ()) + +import Distribution.Client.DistDirLayout (DistDirLayout (..)) +import Distribution.Client.FetchUtils (fetchPackage) +import Distribution.Client.ProjectPlanning + ( ElaboratedConfiguredPackage (..) + , ElaboratedSharedConfig + ) +import Distribution.Client.ProjectPlanning.Types (elabDistDirParams) +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.GlobalFlags (RepoContext) +import Distribution.Client.Types (PackageLocation (..)) + +import Distribution.Package (PackageId, packageId, packageName) +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, die', info, writeFileAtomic) +import Distribution.Verbosity (Verbosity) + +import qualified Data.ByteString.Lazy as LBS + +-- | Fetch (if not already downloaded) and unpack the source of each given +-- package to where an inplace build of it would find it (under +-- 'distUnpackedSrcDirectory'). Packages whose source isn't a tarball (a +-- user-managed local directory, a source-repository checkout) need no +-- unpacking and are left alone. +unpackInplaceSources + :: Verbosity + -> DistDirLayout + -> ElaboratedSharedConfig + -> ((RepoContext -> IO ()) -> IO ()) + -> [ElaboratedConfiguredPackage] + -> IO () +unpackInplaceSources verbosity distDirLayout sharedConfig withRepoCtx pkgs = + unless (null pkgs) $ + withRepoCtx $ \repoctx -> + for_ pkgs $ \pkg -> do + mtarball <- case elabPkgSourceLocation pkg of + LocalTarballPackage tarball -> return (Just tarball) + loc@RemoteTarballPackage{} -> fetched repoctx loc + loc@RepoTarballPackage{} -> fetched repoctx loc + _ -> return Nothing + for_ mtarball $ \tarball -> + unpackTarball + verbosity + distDirLayout + tarball + (packageId pkg) + (elabPkgDescriptionOverride pkg) + (distBuildDirectory distDirLayout (elabDistDirParams sharedConfig pkg)) + where + fetched repoctx loc = do + loc' <- fetchPackage verbosity repoctx loc + return $ case loc' of + RemoteTarballPackage _ tarball -> Just tarball + RepoTarballPackage _ _ tarball -> Just tarball + _ -> Nothing + +-- | Unpack a package's tarball to 'distUnpackedSrcDirectory', unless that's +-- already been done. If the index has a newer revision of the @.cabal@ file +-- than the tarball, that's the one used. +unpackTarball + :: Verbosity + -> DistDirLayout + -> FilePath + -> PackageId + -> Maybe LBS.ByteString + -> FilePath + -- ^ The package's build directory + -> IO () +unpackTarball verbosity distDirLayout tarball pkgid cabalFileOverride buildDir = do + let srcdir = distUnpackedSrcDirectory distDirLayout pkgid + srcrootdir = distUnpackedSrcRootDirectory distDirLayout + exists <- doesDirectoryExist srcdir + unless exists $ do + createDirectoryIfMissingVerbose verbosity True srcrootdir + info verbosity $ "Extracting " ++ tarball ++ " to " ++ srcrootdir ++ "..." + Tar.extractTarGzFile srcrootdir (prettyShow pkgid) tarball + + let cabalFile = srcdir prettyShow (packageName pkgid) <.> "cabal" + cabalFileExists <- doesFileExist cabalFile + unless cabalFileExists $ + die' verbosity $ + "The package description file " ++ cabalFile ++ " was not found in " ++ tarball + for_ cabalFileOverride $ \text -> do + info verbosity $ "Updating " ++ cabalFile ++ " with the latest revision from the index." + writeFileAtomic cabalFile text + + -- Some packages ship pre-processed files in a @dist@ directory inside the + -- tarball: move it to where the build directory is. + let shippedDist = srcdir "dist" + shippedDistExists <- doesDirectoryExist shippedDist + when shippedDistExists $ renameDirectory shippedDist buildDir diff --git a/src/Distribution/Client/Buck2/Write.hs b/src/Distribution/Client/Buck2/Write.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Buck2/Write.hs @@ -0,0 +1,239 @@ +-- | Writes the generated files to support building with buck2 +module Distribution.Client.Buck2.Write + ( writeAllPackages + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (makeRelative, takeDirectory, takeFileName, ()) + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package (packageName) +import Distribution.PackageDescription + ( Library (exposedModules, reexportedModules) + , PackageDescription + , library + ) +import Distribution.Simple.InstallDirs (PathTemplate) +import Distribution.Types.ComponentName (ComponentName) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo) +import Distribution.Types.ModuleReexport + ( ModuleReexport (moduleReexportOriginalName, moduleReexportOriginalPackage) + ) +import Distribution.Types.PackageName (PackageName) + +import Distribution.Simple.Utils (notice, ordNub, warn) + +import Distribution.Client.Buck2.Generate +import Distribution.Client.Buck2.Spec +import Distribution.Client.Buck2.Starlark + +-- | Writes the following files for each package: +-- +-- * @BUCK.cabal.bzl@ is fully regenerated on every run (it's marked +-- @\@generated@ and never hand-edited) and holds the package's build +-- spec, with a single @generated_targets()@ macro that creates the +-- rules from it. It would be nicer to put this under @cabal-buck2@ +-- with the other generated files, but unfortunately buck2 makes +-- that hard by not allowing relative @load()@ declarations. +-- * @BUCK@ is created only if it doesn't already exist, as a two-line +-- file that loads and calls that macro. This is the file a user is +-- free to hand-edit - to add extra targets or customise the +-- target generation. +-- * @cabal-buck2\/autogen@ contains the autogenerated files needed +-- to compile the package, such as @cabal_macros.h@ and @Paths_.hs@. +-- * @cabal-buck2\/autogen\/BUCK@ (see 'writeAutogenBuck') has +-- @export_file()@ rules for the autogen files, so they can be +-- easily referenced from anywhere else. +writeAllPackages :: Verbosity -> FilePath -> Map (PackageName, ComponentName) LocalBuildInfo -> Set String -> Map (PackageName, ComponentName) [PathTemplate] -> [(FilePath, PackageDescription)] -> IO () +writeAllPackages verbosity projectRoot componentLBIs externalBuildTools projectTestOptions pkgs = do + traverse_ (writeOnePackage verbosity localIndex projectRoot componentLBIs externalBuildTools projectTestOptions) pkgs + where + localIndex :: LocalPackageIndex + localIndex = + Map.fromList + [ (packageName pkgDesc, (rootRelativeDir projectRoot pkgDir, reexportOrigins pkgDesc)) + | (pkgDir, pkgDesc) <- pkgs + ] + -- Every module exposed by any local package's main library, to + -- resolve a `reexported-modules:` entry that names only the bare + -- module, not an explicit `origin-package:Module` - Cabal itself + -- resolves that form by searching the reexporting package's own + -- build-depends for whichever one actually defines it, which for a + -- \*local* origin this index can do too (an external origin doesn't + -- need this: its real .conf file already declares the reexport + -- directly to ghc-pkg). + moduleOwners :: Map.Map ModuleName.ModuleName PackageName + moduleOwners = + Map.fromList + [ (m, packageName pkgDesc) + | (_, pkgDesc) <- pkgs + , Just lib <- [library pkgDesc] + , m <- exposedModules lib + ] + reexportOrigins pkgDesc = + ordNub + [ pn + | Just lib <- [library pkgDesc] + , reexport <- reexportedModules lib + , Just pn <- [originPackage reexport] + , pn /= packageName pkgDesc + ] + originPackage reexport = case moduleReexportOriginalPackage reexport of + Just pn -> Just pn + Nothing -> Map.lookup (moduleReexportOriginalName reexport) moduleOwners + +rootRelativeDir :: FilePath -> FilePath -> FilePath +rootRelativeDir projectRoot pkgDir = case makeRelative projectRoot pkgDir of + "" -> "." + rel -> rel + +writeOnePackage :: Verbosity -> LocalPackageIndex -> FilePath -> Map (PackageName, ComponentName) LocalBuildInfo -> Set String -> Map (PackageName, ComponentName) [PathTemplate] -> (FilePath, PackageDescription) -> IO () +writeOnePackage verbosity localIndex projectRoot componentLBIs externalBuildTools projectTestOptions (pkgDir, pkgDesc) = do + sources <- Set.fromList <$> filterM (doesFileExist . (pkgDir )) (sourceCandidates pkgDesc) + let (mtargets, warnings) = generatePackageTargets localIndex (rootRelativeDir projectRoot pkgDir) componentLBIs externalBuildTools projectTestOptions sources pkgDesc + pkgName = packageName pkgDesc + traverse_ (warn verbosity) warnings + case mtargets of + Nothing -> warn verbosity $ "cabal buck2: no buck2 targets generated for package " ++ show pkgName + Just targets -> do + let bzlPath = pkgDir "BUCK.cabal.bzl" + buckPath = pkgDir "BUCK" + writeFile bzlPath (renderGeneratedBzl pkgName (ptSpec targets)) + buckExists <- doesFileExist buckPath + unless buckExists $ writeFile buckPath renderBuckWrapper + writeAutogenBuck pkgDir pkgName targets + notice verbosity $ + "cabal buck2: generated " + ++ (rootRelativeDir projectRoot pkgDir "BUCK.cabal.bzl") + ++ " (" + ++ show (ptComponentCount targets) + ++ " component(s))" + ++ (if buckExists then "" else ", created " ++ (rootRelativeDir projectRoot pkgDir "BUCK")) + +-- | Generate an @export_file()@ rule for each autogen file, so that +-- the files can be easily referenced from somewhere else, including +-- subdirs. +writeAutogenBuck :: FilePath -> PackageName -> PackageTargets -> IO () +writeAutogenBuck pkgDir pkgName targets + | null files = return () + | otherwise = do + createDirectoryIfMissing True autogenDir + for_ files $ \f -> do + createDirectoryIfMissing True (takeDirectory (autogenDir autogenPath f)) + writeFile (autogenDir autogenPath f) (autogenContents f) + writeFile (autogenDir "BUCK") (renderFile header [] exportCalls) + where + files = ptAutogenFiles targets + autogenDir = pkgDir "cabal-buck2" "autogen" + header = + "@generated by `cabal buck2` from " + ++ prettyShow pkgName + ++ ".cabal - do not edit by hand.\nRe-run `cabal buck2` after editing the .cabal file to refresh this file." + exportCalls = + [ call + "export_file" + [ ("name", str (autogenName f)) + , ("src", str (autogenPath f)) + , ("out", str (takeFileName (autogenPath f))) + , -- For @Paths_.hs@ it's important the exported file has the + -- same name, because the buck2 Haskell rules derive the + -- module name from it. + ("visibility", strList ["PUBLIC"]) + ] + | f <- files + ] + +renderGeneratedBzl :: PackageName -> BuildSpec -> String +renderGeneratedBzl pkgName spec = + unlines + [ "# @generated by `cabal buck2` from " ++ prettyShow pkgName ++ ".cabal - do not edit by hand." + , "# Re-run `cabal buck2` after editing the .cabal file to refresh this file." + , "" + ] + ++ renderLoad "//buck2:cabal.bzl" ["cabal_targets"] + ++ "\n" + ++ renderBinding "local_build_spec" (specValue spec) + ++ "\n" + -- kwargs: customisation passed by the BUCK file (see cabal_targets() + -- in buck2/cabal.bzl). + ++ "def generated_targets(**kwargs):\n cabal_targets(local_build_spec, **kwargs)\n" + +-- | A build spec as the Starlark dict that buck2\/cabal.bzl reads (see that +-- file for the schema). Optional keys are left out when empty. +specValue :: BuildSpec -> Value +specValue spec = + VDict $ + [ ("schema", VInt specSchemaVersion) + , ("package", VDict [("name", str (specPackageName spec)), ("dir", str (specPackageDir spec))]) + ] + ++ listField "ghc_options" (specGhcOptions spec) + ++ [("components", VList (map componentValue (specComponents spec)))] + +componentValue :: SpecComponent -> Value +componentValue c = + VDict $ + [("kind", str (kindName (scKind c))), ("name", str (scName c))] + ++ [("main_is", srcValue src) | Just src <- [scMainIs c]] + ++ [("srcs", VDict [(m, srcValue src) | (m, src) <- scSrcs c]) | not (null (scSrcs c))] + ++ listField "test_args" (scTestArgs c) + ++ listField "ghc_options" (scGhcOptions c) + ++ listField "cpp_options" (scCppOptions c) + ++ [("language", str lang) | Just lang <- [scLanguage c]] + ++ listField "extensions" (scExtensions c) + ++ listField "extra_libraries" (scExtraLibraries c) + ++ valuesField "deps" (map depValue (scDeps c)) + ++ valuesField "build_tools" (map buildToolValue (scBuildTools c)) + ++ listField "c_sources" (scCSources c) + ++ listField "cxx_sources" (scCxxSources c) + ++ listField "cxx_options" (scCxxOptions c) + ++ listField "include_dirs" (scIncludeDirs c) + ++ listField "pkgconfig" (scPkgconfig c) + +srcValue :: Src -> Value +srcValue (SrcFile path) = str path +srcValue (SrcAutogen name) = VDict [("autogen", str name)] + +depValue :: SpecDep -> Value +depValue d = + VDict $ + [("package", str (depPackage d))] + ++ [("library", str lib) | Just lib <- [depLibrary d]] + ++ [("dir", str dir) | Just dir <- [depDir d]] + +buildToolValue :: SpecBuildTool -> Value +buildToolValue (LocalTool exe dir) = VDict [("exe", str exe), ("dir", str dir)] +buildToolValue (ExternalTool exe) = VDict [("exe", str exe), ("external", VBool True)] + +-- | A list-valued field, omitted if empty. +listField :: String -> [String] -> [(String, Value)] +listField _ [] = [] +listField k xs = [(k, strList xs)] + +valuesField :: String -> [Value] -> [(String, Value)] +valuesField _ [] = [] +valuesField k xs = [(k, VList xs)] + +-- | Content of @BUCK@ in a package's directory +renderBuckWrapper :: String +renderBuckWrapper = + unlines + [ "# Hand-maintained: add extra targets below, or stop calling" + , "# generated_targets() to fully take over this package's BUCK rules." + , "#" + , "# generated_targets() can be customised (see cabal_targets() in" + , "# buck2/cabal.bzl), e.g." + , "#" + , "# generated_targets(" + , "# defaults = {\"*\": {\"compiler_flags\": [\"-O2\"]}}," + , "# overrides = {\"my-test\": {\"test_args\": [\"--quick\"]}}," + , "# )" + , "load(\":BUCK.cabal.bzl\", \"generated_targets\")" + , "" + , "generated_targets()" + ] diff --git a/src/Distribution/Client/CmdBuck2.hs b/src/Distribution/Client/CmdBuck2.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdBuck2.hs @@ -0,0 +1,153 @@ +-- | cabal-install CLI command: buck2 +-- +-- Sets up (or refreshes) a buck2 build for the current project, using the +-- prelude and support scripts checked out at @buck2\/@ (a checkout of +-- , see @buck2\/README.md@). +-- +-- There are 6 main pieces to this, each with a small API: +-- +-- 1. "Distribution.Client.Buck2.BuildDependencies": Build every +-- dependency (never the local packages themselves), the same as +-- @cabal build all --only-dependencies@ would. +-- +-- 2. "Distribution.Client.Buck2.Setup": Create +-- @.buckconfig@\/@PACKAGE@ if they don't exist yet. These are +-- boilerplate copied from @buck2\/example@. +-- +-- 3. "Distribution.Client.Buck2.Prebuilt": Tell @buck2@ about all +-- the library and tool dependencies. These are all recorded +-- under @third-party\/haskell@. +-- +-- 4. "Distribution.Client.Buck2.Configure": Configure every +-- component of the local packages, to get the 'LocalBuildInfo'. +-- +-- 5. "Distribution.Client.Buck2.Generate": Generate buck2 targets +-- for each local component to be built. A pure function of +-- 'PackageDescription', 'LocalBuildInfo' and a few other things. +-- +-- 6. "Distribution.Client.Buck2.Write": Write the generated buck2 +-- targets for each package to @BUCK.cabal.bzl@, and the autogen +-- files into @cabal-buck2/autogen@ in each package's directory. +module Distribution.Client.CmdBuck2 + ( buck2Command + , buck2Action + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.DistDirLayout (DistDirLayout (distProjectRootDirectory)) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) + , cfgVerbosity + , defaultNixStyleFlags + , nixStyleOptions + ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ScriptUtils + ( AcceptNoTargets (..) + , TargetContext (..) + , updateContextAndWriteProjectFile + , withContextAndSelectors + ) +import Distribution.Client.Setup + ( GlobalFlags + , InstallFlags (installOnlyDeps) + ) + +import Distribution.Simple.Command (CommandUI (..), usageAlternatives) +import Distribution.Simple.Flag (toFlag) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.Utils (die', notice) +import Distribution.Verbosity (normal) + +import Distribution.Client.Buck2.BuildDependencies (buildDependencies) +import Distribution.Client.Buck2.Configure (configureComponents) +import Distribution.Client.Buck2.LocalPackages + ( builtLocalPackages + , projectTestOptions + , wantedBuildTools + ) +import Distribution.Client.Buck2.Prebuilt (generatePrebuilt) +import Distribution.Client.Buck2.Setup + ( checkBuck2Prelude + , ensureBuckconfigAndPackage + ) +import Distribution.Client.Buck2.Write (writeAllPackages) + +-- | The @cabal buck2@ CLI command +buck2Command :: CommandUI (NixStyleFlags ()) +buck2Command = + CommandUI + { commandName = "buck2" + , commandSynopsis = "Set up (or refresh) a buck2 build for this project." + , commandUsage = usageAlternatives "buck2" ["[FLAGS]"] + , commandDescription = Just $ \_ -> + "Builds every dependency of the project (as `cabal build all " + ++ "--only-dependencies` would), then generates the buck2 build " + ++ "files (.buckconfig, PACKAGE, third-party/haskell, and a " + ++ "BUCK.cabal.bzl for each local package) needed to build the " + ++ "project with buck2 instead of cabal. Requires a checkout of " + ++ "https://github.com/simonmar/haskell-buck2 at ./buck2. See " + ++ "buck2/README.md for details.\n\n" + ++ "Flags that would normally be passed to `cabal build`/`cabal " + ++ "configure` (-f, --enable-profiling, --enable-tests, etc.) are " + ++ "honoured here too, and apply to the dependency build." + , commandNotes = Nothing + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + +-- | Implement @cabal buck2@ +buck2Action :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +buck2Action flags extraArgs globalFlags = do + unless (null extraArgs) $ + die' verbosity ("'cabal buck2' doesn't take any extra arguments: " ++ unwords extraArgs) + + withContextAndSelectors verbosity RejectNoTargets Nothing depsFlags ["all"] globalFlags BuildCommand $ + \targetCtx ctx targetSelectors -> do + baseCtx <- case targetCtx of + ProjectContext -> return ctx + GlobalContext -> return ctx + ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta + + let projectRoot = distProjectRootDirectory (distDirLayout baseCtx) + checkBuck2Prelude verbosity projectRoot + + buildCtx <- buildDependencies verbosity baseCtx targetSelectors + + ensureBuckconfigAndPackage verbosity projectRoot + + localPkgs <- builtLocalPackages verbosity (distDirLayout baseCtx) (elaboratedPlanOriginal buildCtx) + + (externalBuildTools, resolvedDeps) <- + generatePrebuilt + verbosity + projectRoot + (cabalDirLayout baseCtx) + (elaboratedShared buildCtx) + (elaboratedPlanToExecute buildCtx) + (wantedBuildTools localPkgs) + + -- 'generatePrebuilt' already found and parsed every real @.conf@ + -- file of the resolved dependency closure. + componentLBIs <- configureComponents verbosity baseCtx buildCtx (PackageIndex.fromList resolvedDeps) + + writeAllPackages + verbosity + projectRoot + componentLBIs + externalBuildTools + (projectTestOptions (elaboratedPlanOriginal buildCtx)) + localPkgs + + notice verbosity $ + unlines + [ "cabal buck2: done. You can now:" + , " buck2 build //... # build everything" + , " buck2 test //... # test everything" + , " buck2 build //... -m opt # build everything in opt mode" + ] + where + verbosity = cfgVerbosity normal flags + depsFlags = flags{installFlags = (installFlags flags){installOnlyDeps = toFlag True}} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,261 @@ +-- | Runs @cabal-buck2@ on the fixture projects in @test/fixtures@ and checks +-- the files it generates. None of these needs a buck2 binary, or a buck2 +-- prelude: the fixtures' @buck2@ directory only has to exist. +module Main (main) where + +import Control.Exception (SomeException, bracket, displayException, try) +import Control.Monad (forM_, unless, when) +import Data.List (isInfixOf) +import System.Directory + ( copyFile + , createDirectoryIfMissing + , doesDirectoryExist + , findExecutable + , getTemporaryDirectory + , listDirectory + , removeDirectoryRecursive + ) +import System.Environment (getEnvironment, lookupEnv) +import System.Exit (ExitCode (..), exitFailure) +import System.FilePath (()) +import System.IO (hPutStrLn, stderr) +import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode, getCurrentPid) + +main :: IO () +main = do + exe <- maybe (fail "cabal-buck2 not found on PATH") return =<< findExecutable "cabal-buck2" + results <- mapM (runTest exe) tests + let failures = [name | (name, False) <- zip (map fst tests) results] + unless (null failures) $ do + hPutStrLn stderr $ "FAILED: " ++ unwords failures + exitFailure + +tests :: [(String, Project -> IO ())] +tests = + [ ("basic", basic) + , ("disabled-stanzas", disabledStanzas) + , ("missing-module", missingModule) + ] + +-- | A copy of a fixture project, and how to run @cabal-buck2@ in it. +data Project = Project + { projectDir :: FilePath + , runBuck2 :: [String] -> IO (ExitCode, String) + -- ^ The exit code and the output (stdout and stderr). + } + +runTest :: FilePath -> (String, Project -> IO ()) -> IO Bool +runTest exe (name, test) = do + tmp <- getTemporaryDirectory + pid <- getCurrentPid + let dir = tmp ("cabal-buck2-test-" ++ show pid ++ "-" ++ name) + bracket (setup dir) (const (cleanup dir)) $ \project -> do + r <- try (test project) + case r of + Right () -> putStrLn ("PASS " ++ name) >> return True + Left e -> do + hPutStrLn stderr ("FAIL " ++ name ++ ": " ++ displayException (e :: SomeException)) + return False + where + -- The fixture is named after the test, except for tests that reuse one. + fixture = case name of + "disabled-stanzas" -> "basic" + _ -> name + setup dir = do + cleanup dir + copyTree ("test" "fixtures" fixture) (dir "project") + env <- getEnvironment + -- The compiler to use: $HC if it's set (as haskell-ci does), otherwise + -- whatever `ghc` is on the PATH. + compilerArgs <- maybe [] (\hc -> ["-w", hc]) <$> lookupEnv "HC" + -- A private cabal directory and config, so that the user's store and + -- config (which $CABAL_DIR and $CABAL_CONFIG may point to, as in + -- haskell-ci) are neither used nor changed. + let cabalDir = dir "cabal-dir" + cabalEnv = + [("CABAL_DIR", cabalDir), ("CABAL_CONFIG", cabalDir "config")] + ++ [kv | kv@(k, _) <- env, k `notElem` ["CABAL_DIR", "CABAL_CONFIG"]] + run args = do + (code, out, err) <- + readCreateProcessWithExitCode + (proc exe (compilerArgs ++ args)){cwd = Just (dir "project"), env = Just cabalEnv} + "" + return (code, out ++ err) + createDirectoryIfMissing True cabalDir + writeFile (cabalDir "config") "" + return Project{projectDir = dir "project", runBuck2 = run} + cleanup dir = do + exists <- doesDirectoryExist dir + when exists $ removeDirectoryRecursive dir + +copyTree :: FilePath -> FilePath -> IO () +copyTree from to = do + createDirectoryIfMissing True to + names <- listDirectory from + forM_ names $ \n -> do + isDir <- doesDirectoryExist (from n) + if isDir then copyTree (from n) (to n) else copyFile (from n) (to n) + +-- * Assertions + +-- | Run @cabal-buck2@ and check that it succeeded. +buck2 :: Project -> [String] -> IO String +buck2 project args = do + (code, out) <- runBuck2 project args + when (code /= ExitSuccess) $ failure ("cabal-buck2 " ++ unwords args ++ " failed:\n" ++ out) + return out + +failure :: String -> IO a +failure = ioError . userError + +readIn :: Project -> FilePath -> IO String +readIn project path = do + s <- readFile (projectDir project path) + length s `seq` return s + +assertContains :: String -> String -> String -> IO () +assertContains what needle haystack = + unless (needle `isInfixOf` haystack) $ + failure (what ++ ": expected to contain " ++ show needle ++ ", but it is:\n" ++ haystack) + +assertNotContains :: String -> String -> String -> IO () +assertNotContains what needle haystack = + when (needle `isInfixOf` haystack) $ + failure (what ++ ": expected not to contain " ++ show needle ++ ", but it is:\n" ++ haystack) + +-- * Tests + +-- | The main mapping rules, end to end: a plain library (lib-pkg), a second +-- package (exe-pkg) whose library depends on it, an executable with +-- @c-sources@, an exitcode-stdio-1.0 test-suite and a benchmark (both only +-- generated because tests and benchmarks are enabled), a @detailed-0.9@ +-- test-suite (which gets a generated stub @Main@), and a manual flag gating +-- @cpp-options@. +basic :: Project -> IO () +basic project = do + _ <- buck2 project ["--enable-tests", "--enable-benchmarks", "-f+loud"] + + -- The generated file is a build spec - a plain dict describing each + -- component as Cabal sees it - interpreted by buck2/cabal.bzl, which + -- decides which rules, labels and flags that becomes. + libBzl <- readIn project ("lib-pkg" "BUCK.cabal.bzl") + let lib = assertContains "lib-pkg/BUCK.cabal.bzl" + noLib = assertNotContains "lib-pkg/BUCK.cabal.bzl" + lib "local_build_spec" libBzl + lib "'kind': 'library'" libBzl + lib "'name': 'lib-pkg'" libBzl + noLib "haskell_library(" libBzl + -- Project-level options and test options are only recorded where they + -- apply. + noLib "'ghc_options'" libBzl + noLib "'test_args'" libBzl + + exeBzl <- readIn project ("exe-pkg" "BUCK.cabal.bzl") + let exe = assertContains "exe-pkg/BUCK.cabal.bzl" + forM_ ["library", "executable", "test-suite", "benchmark"] $ \kind -> + exe ("'kind': '" ++ kind ++ "'") exeBzl + exe "'name': 'exe-pkg-bench'" exeBzl + + -- A dependency on another local package carries that package's directory + -- (from which the target label is made). + exe "'package': 'lib-pkg'" exeBzl + exe "'dir': 'lib-pkg'" exeBzl + + -- C sources and include directories are recorded as written in the .cabal + -- file; cabal.bzl turns them into a cxx_library(). + exe "'cbits/helper.c'" exeBzl + exe "'include_dirs'" exeBzl + -- The manual flag's cpp-options. + exe "'-DLOUD'" exeBzl + + -- `ghc-options:` and `test-options:` from cabal.project (not the .cabal + -- file) reach the spec: the former once per package, the latter as + -- `test_args` with template variables expanded per test-suite. The + -- `-hide-all-packages` that cabal-install always adds (a workaround for + -- custom Setup.hs scripts) is deliberately not copied over. + exe "'ghc_options'" exeBzl + exe "'-fno-ignore-asserts'" exeBzl + assertNotContains "exe-pkg/BUCK.cabal.bzl" "-hide-all-packages" exeBzl + exe "'test_args'" exeBzl + exe "'--opt-one'" exeBzl + exe "'--opt-two=exe-pkg-test'" exeBzl + exe "'exe-pkg-detailed-test'" exeBzl + + -- Paths_.hs and the detailed-0.9 stub Main both live under + -- cabal-buck2/autogen/, which has its own BUCK file (see below): the spec + -- names them, and cabal.bzl refers to them by that file's export_file() + -- target. + exe "'Paths_exe_pkg': {" exeBzl + exe "'autogen': 'Paths_exe_pkg'" exeBzl + exe "'autogen': 'exe-pkg-detailed-test-stub-main'" exeBzl + + -- The hand-editable BUCK wrapper is created (only once) and loads the + -- generated file, whose entry point passes customisation through to + -- cabal.bzl's cabal_targets(). + wrapper <- readIn project ("exe-pkg" "BUCK") + assertContains "exe-pkg/BUCK" "generated_targets" wrapper + exe "def generated_targets(**kwargs):" exeBzl + + -- The detailed-0.9 test-suite's stub Main is our own generated driver + -- (not Cabal's stdin-driven one), importing the user's named test-module + -- directly. + let autogen = "exe-pkg" "cabal-buck2" "autogen" + stub <- readIn project (autogen "exe-pkg-detailed-test" "Main.hs") + assertContains "stub Main" "import qualified DetailedTests as CabalBuck2TestModule" stub + + -- cabal_macros.h and Paths_.hs come from Cabal's own generators, not + -- hand-rolled stand-ins. + macros <- readIn project (autogen "exe-pkg" "cabal_macros.h") + assertContains "cabal_macros.h" "CURRENT_PACKAGE_KEY" macros + paths <- readIn project (autogen "Paths_exe_pkg.hs") + assertContains "Paths_exe_pkg.hs" "version =" paths + + -- cabal-buck2/autogen/BUCK exports every autogen file as a real target + -- via export_file(): both what makes cabal_component's $(location ...) + -- reference a buck2-tracked dependency, and what lets a hand-written BUCK + -- file elsewhere refer to e.g. Paths_. + autogenBuck <- readIn project (autogen "BUCK") + let ab = assertContains "cabal-buck2/autogen/BUCK" + ab "name = 'exe-pkg-cabal-macros'" autogenBuck + ab "name = 'Paths_exe_pkg'" autogenBuck + ab "name = 'exe-pkg-detailed-test-stub-main'" autogenBuck + -- Each export_file() must set `out` to the real file's basename: without + -- it, `out` defaults to the rule's name, the artifact loses its extension, + -- and buck2 silently stops treating it as a Haskell source. + ab "out = 'Paths_exe_pkg.hs'" autogenBuck + ab "out = 'cabal_macros.h'" autogenBuck + ab "out = 'Main.hs'" autogenBuck + +-- | A plain run, without @--enable-tests@ or @--enable-benchmarks@, must +-- succeed even though the package has test-suites and a benchmark. The +-- benchmark depends on @stm@, which nothing else in the fixture uses: since +-- its stanza isn't enabled, @stm@ is (correctly) absent from the dependency +-- plan that the installed package index is built from, so configuring the +-- benchmark anyway would fail with "the given installed package instance +-- does not exist". The disabled components just get no rule. +disabledStanzas :: Project -> IO () +disabledStanzas project = do + _ <- buck2 project [] + exeBzl <- readIn project ("exe-pkg" "BUCK.cabal.bzl") + let exe = "exe-pkg/BUCK.cabal.bzl" + assertContains exe "'kind': 'library'" exeBzl + assertContains exe "'kind': 'executable'" exeBzl + assertNotContains exe "'exe-pkg-bench'" exeBzl + assertNotContains exe "'kind': 'test-suite'" exeBzl + assertNotContains exe "'kind': 'benchmark'" exeBzl + +-- | A component whose sources can't all be found is skipped with a warning +-- saying why (a rule that names a missing file would take down the whole +-- buck2 build), and so is every component of the same package that depends +-- on it. Everything else is still generated. +missingModule :: Project -> IO () +missingModule project = do + out <- buck2 project [] + assertContains "output" "for module Absent" out + assertContains "output" "skipping library broken-pkg" out + assertContains "output" "skipping executable uses-lib" out + + bzl <- readIn project ("broken-pkg" "BUCK.cabal.bzl") + assertContains "broken-pkg/BUCK.cabal.bzl" "'name': 'standalone'" bzl + assertNotContains "broken-pkg/BUCK.cabal.bzl" "'name': 'uses-lib'" bzl + assertNotContains "broken-pkg/BUCK.cabal.bzl" "'kind': 'library'" bzl diff --git a/test/fixtures/basic/.buckconfig b/test/fixtures/basic/.buckconfig new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/.buckconfig @@ -0,0 +1,4 @@ +# Placeholder: this test only checks `cabal buck2`'s generated files, it +# never actually invokes a real buck2 binary, so this doesn't need to be +# a functional buck2 config - it only needs to exist so that +# `ensureBuckconfigAndPackage` sees it's already there and leaves it alone. diff --git a/test/fixtures/basic/PACKAGE b/test/fixtures/basic/PACKAGE new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/PACKAGE @@ -0,0 +1,1 @@ +# Placeholder - see .buckconfig. diff --git a/test/fixtures/basic/buck2/.gitkeep b/test/fixtures/basic/buck2/.gitkeep new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/buck2/.gitkeep diff --git a/test/fixtures/basic/cabal.project b/test/fixtures/basic/cabal.project new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/cabal.project @@ -0,0 +1,7 @@ +packages: lib-pkg exe-pkg + +package exe-pkg + ghc-options: -fno-ignore-asserts + test-options: --opt-one --opt-two=$test-suite + +active-repositories: :none diff --git a/test/fixtures/basic/exe-pkg/app/Main.hs b/test/fixtures/basic/exe-pkg/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/exe-pkg/app/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Greet (greet) + +main :: IO () +main = putStrLn greet diff --git a/test/fixtures/basic/exe-pkg/bench/Bench.hs b/test/fixtures/basic/exe-pkg/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/exe-pkg/bench/Bench.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "ok" diff --git a/test/fixtures/basic/exe-pkg/cbits/helper.c b/test/fixtures/basic/exe-pkg/cbits/helper.c new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/exe-pkg/cbits/helper.c @@ -0,0 +1,3 @@ +#include + +int exe_pkg_helper(void) { return 42; } diff --git a/test/fixtures/basic/exe-pkg/cbits/helper.h b/test/fixtures/basic/exe-pkg/cbits/helper.h new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/exe-pkg/cbits/helper.h @@ -0,0 +1,1 @@ +int exe_pkg_helper(void); diff --git a/test/fixtures/basic/exe-pkg/detailed-test/DetailedTests.hs b/test/fixtures/basic/exe-pkg/detailed-test/DetailedTests.hs new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/exe-pkg/detailed-test/DetailedTests.hs @@ -0,0 +1,16 @@ +module DetailedTests (tests) where + +import Distribution.TestSuite + +tests :: IO [Test] +tests = + return + [ Test + TestInstance + { run = return (Finished Pass) + , name = "always-passes" + , tags = [] + , options = [] + , setOption = \_ _ -> Left "no options" + } + ] diff --git a/test/fixtures/basic/exe-pkg/exe-pkg.cabal b/test/fixtures/basic/exe-pkg/exe-pkg.cabal new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/exe-pkg/exe-pkg.cabal @@ -0,0 +1,51 @@ +cabal-version: 2.4 +name: exe-pkg +version: 0.1.0.0 +build-type: Simple + +flag loud + description: Enable extra-loud output + default: False + manual: True + +library + exposed-modules: Greet + other-modules: Paths_exe_pkg + autogen-modules: Paths_exe_pkg + hs-source-dirs: src + build-depends: base, lib-pkg + default-language: Haskell2010 + default-extensions: CPP + if flag(loud) + cpp-options: -DLOUD + +executable exe-pkg-exe + main-is: Main.hs + hs-source-dirs: app + c-sources: cbits/helper.c + include-dirs: cbits + build-depends: base, exe-pkg + default-language: Haskell2010 + +test-suite exe-pkg-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + build-depends: base, exe-pkg + default-language: Haskell2010 + +benchmark exe-pkg-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + hs-source-dirs: bench + -- stm: used by nothing else in this fixture - see + -- disabled-stanzas.test.hs + build-depends: base, exe-pkg, stm + default-language: Haskell2010 + +test-suite exe-pkg-detailed-test + type: detailed-0.9 + test-module: DetailedTests + hs-source-dirs: detailed-test + build-depends: base, Cabal, exe-pkg + default-language: Haskell2010 diff --git a/test/fixtures/basic/exe-pkg/src/Greet.hs b/test/fixtures/basic/exe-pkg/src/Greet.hs new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/exe-pkg/src/Greet.hs @@ -0,0 +1,10 @@ +module Greet (greet) where + +import MyLib (myLib) + +greet :: String +#ifdef LOUD +greet = myLib ++ "!!!" +#else +greet = myLib +#endif diff --git a/test/fixtures/basic/exe-pkg/test/Spec.hs b/test/fixtures/basic/exe-pkg/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/exe-pkg/test/Spec.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "ok" diff --git a/test/fixtures/basic/lib-pkg/lib-pkg.cabal b/test/fixtures/basic/lib-pkg/lib-pkg.cabal new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/lib-pkg/lib-pkg.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.4 +name: lib-pkg +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MyLib + hs-source-dirs: src + build-depends: base + default-language: Haskell2010 diff --git a/test/fixtures/basic/lib-pkg/src/MyLib.hs b/test/fixtures/basic/lib-pkg/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/test/fixtures/basic/lib-pkg/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (myLib) where + +myLib :: String +myLib = "lib-pkg" diff --git a/test/fixtures/missing-module/.buckconfig b/test/fixtures/missing-module/.buckconfig new file mode 100644 --- /dev/null +++ b/test/fixtures/missing-module/.buckconfig @@ -0,0 +1,4 @@ +# Placeholder: this test only checks `cabal buck2`'s generated files, it +# never actually invokes a real buck2 binary, so this doesn't need to be +# a functional buck2 config - it only needs to exist so that +# `ensureBuckconfigAndPackage` sees it's already there and leaves it alone. diff --git a/test/fixtures/missing-module/PACKAGE b/test/fixtures/missing-module/PACKAGE new file mode 100644 --- /dev/null +++ b/test/fixtures/missing-module/PACKAGE @@ -0,0 +1,1 @@ +# Placeholder - see .buckconfig. diff --git a/test/fixtures/missing-module/broken-pkg/app/Standalone.hs b/test/fixtures/missing-module/broken-pkg/app/Standalone.hs new file mode 100644 --- /dev/null +++ b/test/fixtures/missing-module/broken-pkg/app/Standalone.hs @@ -0,0 +1,3 @@ +module Main where +main :: IO () +main = return () diff --git a/test/fixtures/missing-module/broken-pkg/app/UsesLib.hs b/test/fixtures/missing-module/broken-pkg/app/UsesLib.hs new file mode 100644 --- /dev/null +++ b/test/fixtures/missing-module/broken-pkg/app/UsesLib.hs @@ -0,0 +1,4 @@ +module Main where +import Present () +main :: IO () +main = return () diff --git a/test/fixtures/missing-module/broken-pkg/broken-pkg.cabal b/test/fixtures/missing-module/broken-pkg/broken-pkg.cabal new file mode 100644 --- /dev/null +++ b/test/fixtures/missing-module/broken-pkg/broken-pkg.cabal @@ -0,0 +1,22 @@ +cabal-version: 2.4 +name: broken-pkg +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Present, Absent + hs-source-dirs: src + build-depends: base + default-language: Haskell2010 + +executable uses-lib + main-is: UsesLib.hs + hs-source-dirs: app + build-depends: base, broken-pkg + default-language: Haskell2010 + +executable standalone + main-is: Standalone.hs + hs-source-dirs: app + build-depends: base + default-language: Haskell2010 diff --git a/test/fixtures/missing-module/broken-pkg/src/Present.hs b/test/fixtures/missing-module/broken-pkg/src/Present.hs new file mode 100644 --- /dev/null +++ b/test/fixtures/missing-module/broken-pkg/src/Present.hs @@ -0,0 +1,1 @@ +module Present where diff --git a/test/fixtures/missing-module/buck2/.gitkeep b/test/fixtures/missing-module/buck2/.gitkeep new file mode 100644 --- /dev/null +++ b/test/fixtures/missing-module/buck2/.gitkeep diff --git a/test/fixtures/missing-module/cabal.project b/test/fixtures/missing-module/cabal.project new file mode 100644 --- /dev/null +++ b/test/fixtures/missing-module/cabal.project @@ -0,0 +1,3 @@ +packages: broken-pkg + +active-repositories: :none