diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs index 8c1c501cf95..717fd6a5c7a 100644 --- a/Cabal-described/src/Distribution/Described.hs +++ b/Cabal-described/src/Distribution/Described.hs @@ -355,7 +355,7 @@ instance Described BenchmarkType where describe _ = "exitcode-stdio-1.0" instance Described BuildType where - describe _ = REUnion ["Simple","Configure","Custom","Make","Default"] + describe _ = REUnion ["Simple","Configure","Custom","Hooks","Make","Default"] instance Described CompilerFlavor where describe _ = REUnion diff --git a/Cabal-hooks/Cabal-hooks.cabal b/Cabal-hooks/Cabal-hooks.cabal new file mode 100644 index 00000000000..e9768013129 --- /dev/null +++ b/Cabal-hooks/Cabal-hooks.cabal @@ -0,0 +1,69 @@ +cabal-version: 2.2 +name: Cabal-hooks +version: 0.1 +copyright: 2023, Cabal Development Team +license: BSD-3-Clause +license-file: LICENSE +author: Cabal Development Team +maintainer: cabal-devel@haskell.org +homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +synopsis: API for the Hooks build-type +description: + User-facing API for the Hooks build-type. +category: Distribution +build-type: Simple + +extra-source-files: + readme.md changelog.md + +source-repository head + type: git + location: https://github.com/haskell/cabal/ + subdir: Cabal-hooks + +library + default-language: Haskell2010 + hs-source-dirs: src + + build-depends: + Cabal-syntax >= 3.11 && < 3.13, + Cabal >= 3.11 && < 3.13, + base >= 4.9 && < 5, + containers >= 0.5.0.0 && < 0.8, + filepath >= 1.3.0.1 && < 1.5, + transformers >= 0.5.6.0 && < 0.7 + + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + + exposed-modules: + Distribution.Simple.SetupHooks + + other-extensions: + BangPatterns + CPP + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImplicitParams + KindSignatures + LambdaCase + NondecreasingIndentation + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + Trustworthy + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances diff --git a/Cabal-hooks/LICENSE b/Cabal-hooks/LICENSE new file mode 100644 index 00000000000..c134f098c03 --- /dev/null +++ b/Cabal-hooks/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2003-2023, Cabal Development Team. +See the AUTHORS file for the full list of copyright holders. + +See */LICENSE for the copyright holders of the subcomponents. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Cabal-hooks/changelog.md b/Cabal-hooks/changelog.md new file mode 100644 index 00000000000..ea633b2936a --- /dev/null +++ b/Cabal-hooks/changelog.md @@ -0,0 +1,6 @@ +# Changelog for `Cabal-hooks` + +## 0.1 – December 2023 + + * Initial release of the `Hooks` API. + diff --git a/Cabal-hooks/readme.md b/Cabal-hooks/readme.md new file mode 100644 index 00000000000..9304784efe6 --- /dev/null +++ b/Cabal-hooks/readme.md @@ -0,0 +1,64 @@ +# `Cabal-hooks` + +This library provides an API for the `Cabal` `Hooks` build type. + +## What is the `Hooks` build type? + +The `Hooks` build type is a new `Cabal` build type that is scheduled to +replace the `Custom` build type, providing better integration with +the rest of the Haskell ecosystem. + +The original specification for the `Hooks` build type can be found in +the associated [Haskell Foundation Tech Proposal](https://github.com/haskellfoundation/tech-proposals/pull/60). + +These *setup hooks* allow package authors to customise the configuration and +building of a package by providing certain hooks that get folded into the +general package configuration and building logic within `Cabal`. + +## Defining a package with custom hooks + +To use the `Hooks` build type, you will need to + + * Update your `.cabal` file by: + + - using `cabal-version >= 3.14`, + - declaring `build-type: Hooks`, + - declaring a `custom-setup` stanza, with a `setup-depends` + field which includes a dependency on `Cabal-hooks`. + + * Define a Haskell module `SetupHooks`, which must be placed + at the root of your project and must define a value + `setupHooks :: SetupHooks`. + +That is, your `.cabal` file should contain the following + +```cabal +-- my-package.cabal +cabal-version: 3.14 +name: my-package +build-type: Hooks + +custom-setup + setup-depends: + Cabal-hooks >= 0.1 && < 0.2 +``` + +and your `SetupHooks.hs` file should look like: + +```haskell +-- SetupHooks.hs +module SetupHooks ( setupHooks ) where + +-- Cabal-hooks +import Distribution.Simple.SetupHooks + +setupHooks :: SetupHooks +setupHooks = ... + -- use the API provided by 'Distribution.Simple.SetupHooks' + -- to define the hooks relevant to your package +``` + +## Using the API + +The [Haddock documentation](https://hackage.haskell.org/package/Cabal-hooks) +should help you get started using this library's API. diff --git a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs new file mode 100644 index 00000000000..48929bd4ce5 --- /dev/null +++ b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs @@ -0,0 +1,479 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module: Distribution.Simple.SetupHooks +Description: Interface for the @Hooks@ @build-type@. + +This module defines the interface for the @Hooks@ @build-type@. + +To write a package that implements @build-type: Hooks@, you should define +a module @SetupHooks.hs@ which exports a value @setupHooks :: 'SetupHooks'@. +This is a record that declares actions that should be hooked into the +cabal build process. + +See 'SetupHooks' for more details. +-} +module Distribution.Simple.SetupHooks + ( -- * Hooks + + -- $setupHooks + SetupHooks(..) + , noSetupHooks + + -- * Configure hooks + + -- $configureHooks + , ConfigureHooks(..) + , noConfigureHooks + -- ** Per-package configure hooks + , PreConfPackageInputs(..) + , PreConfPackageOutputs(..) -- See Note [Not hiding SetupHooks constructors] + , noPreConfPackageOutputs + , PreConfPackageHook + , PostConfPackageInputs(..) + , PostConfPackageHook + -- ** Per-component configure hooks + , PreConfComponentInputs(..) + , PreConfComponentOutputs(..) -- See Note [Not hiding SetupHooks constructors] + , noPreConfComponentOutputs + , PreConfComponentHook + , ComponentDiff(..), emptyComponentDiff, buildInfoComponentDiff + , LibraryDiff, ForeignLibDiff, ExecutableDiff + , TestSuiteDiff, BenchmarkDiff + , BuildInfoDiff + + -- * Build hooks + + , BuildHooks(..), noBuildHooks + , BuildingWhat(..), buildingWhatVerbosity, buildingWhatDistPref + + -- ** Pre-build rules + + -- $preBuildRules + , PreBuildComponentInputs(..) + , PreBuildComponentRules + + -- ** Post-build hooks + , PostBuildComponentInputs(..) + , PostBuildComponentHook + + -- ** Rules + , Rules + , rules + , noRules + , Rule + , Dependency (..) + , RuleOutput (..) + , RuleId + , staticRule, dynamicRule + -- *** Rule inputs/outputs + + -- $rulesDemand + , Location + , findFileInDirs + , autogenComponentModulesDir + , componentBuildDir + + -- *** Actions + , RuleCommands(..) + , Command + , mkCommand + , Dict(..) + + -- *** Rules API + + -- $rulesAPI + , RulesM + , registerRule + , registerRule_ + + -- **** File/directory monitoring + , addRuleMonitors + , module Distribution.Simple.FileMonitor.Types + + -- * Install hooks + , InstallHooks(..), noInstallHooks + , InstallComponentInputs(..), InstallComponentHook + + -- * Re-exports + + -- ** Hooks + -- *** Configure hooks + , ConfigFlags(..) + -- *** Build hooks + , BuildFlags(..), ReplFlags(..), HaddockFlags(..), HscolourFlags(..) + -- *** Install hooks + , CopyFlags(..) + + -- ** @Hooks@ API + -- + -- | These are functions provided as part of the @Hooks@ API. + -- It is recommended to import them from this module as opposed to + -- manually importing them from inside the Cabal module hierarchy. + + -- *** Copy/install functions + , installFileGlob + + -- *** Interacting with the program database + , Program(..), ConfiguredProgram(..), ProgArg + , ProgramLocation(..) + , ProgramDb + , addKnownPrograms + , configureUnconfiguredProgram + , simpleProgram + + -- ** General @Cabal@ datatypes + , Verbosity, Compiler(..), Platform(..), Suffix(..) + + -- *** Package information + , LocalBuildConfig, LocalBuildInfo, PackageBuildDescr + -- NB: we can't simply re-export all the fields of LocalBuildConfig etc, + -- due to the presence of duplicate record fields. + -- Ideally, we'd like to e.g. re-export LocalBuildConfig qualified, + -- but qualified re-exports aren't a thing currently. + + , PackageDescription(..) + + -- *** Component information + , Component(..), ComponentName(..), componentName + , BuildInfo(..), emptyBuildInfo + , TargetInfo(..), ComponentLocalBuildInfo(..) + + -- **** Components + , Library(..), ForeignLib(..), Executable(..) + , TestSuite(..), Benchmark(..) + , LibraryName(..) + , emptyLibrary, emptyForeignLib, emptyExecutable + , emptyTestSuite, emptyBenchmark + + ) +where +import Distribution.PackageDescription + ( PackageDescription(..) + , Library(..), ForeignLib(..) + , Executable(..), TestSuite(..), Benchmark(..) + , emptyLibrary, emptyForeignLib + , emptyExecutable, emptyBenchmark, emptyTestSuite + , BuildInfo(..), emptyBuildInfo + , ComponentName(..), LibraryName(..) + ) +import Distribution.Simple.BuildPaths + ( autogenComponentModulesDir ) +import Distribution.Simple.Compiler + ( Compiler(..) ) +import Distribution.Simple.Errors + ( CabalException(SetupHooksException) ) +import Distribution.Simple.FileMonitor.Types +import Distribution.Simple.Install + ( installFileGlob ) +import Distribution.Simple.LocalBuildInfo + ( componentBuildDir ) +import Distribution.Simple.PreProcess.Types + ( Suffix(..) ) +import Distribution.Simple.Program.Db + ( ProgramDb, addKnownPrograms + , configureUnconfiguredProgram + ) +import Distribution.Simple.Program.Find + ( simpleProgram ) +import Distribution.Simple.Program.Types + ( Program(..), ConfiguredProgram(..) + , ProgArg + , ProgramLocation(..) + ) +import Distribution.Simple.Setup + ( BuildFlags(..) + , ConfigFlags(..) + , CopyFlags(..) + , HaddockFlags(..) + , HscolourFlags(..) + , ReplFlags(..) + ) +import Distribution.Simple.SetupHooks.Errors +import Distribution.Simple.SetupHooks.Internal +import Distribution.Simple.SetupHooks.Rule as Rule +import Distribution.Simple.Utils + ( dieWithException, findFirstFile) +import Distribution.System + ( Platform(..) ) +import Distribution.Types.Component + ( Component(..), componentName ) +import Distribution.Types.ComponentLocalBuildInfo + ( ComponentLocalBuildInfo(..) ) +import Distribution.Types.LocalBuildInfo + ( LocalBuildInfo(..) ) +import Distribution.Types.LocalBuildConfig + ( LocalBuildConfig, PackageBuildDescr ) +import Distribution.Types.TargetInfo + ( TargetInfo(..) ) +import Distribution.Utils.ShortText + ( ShortText ) +import Distribution.Verbosity + ( Verbosity ) + +import Control.Monad + ( void ) +import Control.Monad.IO.Class + ( MonadIO(liftIO) ) +import Control.Monad.Trans.Class + ( lift ) +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.State as State +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.Writer.CPS as Writer +#else +import qualified Control.Monad.Trans.Writer.Strict as Writer +#endif +import Data.Foldable + ( for_ ) +import Data.List + ( nub ) +import Data.Map.Strict as Map + ( insertLookupWithKey ) +import System.FilePath + ( () ) + +-------------------------------------------------------------------------------- +-- Haddocks for the SetupHooks API + +{- $setupHooks +A Cabal package with @Hooks@ @build-type@ must define the Haskell module +@SetupHooks@ which defines a value @setupHooks :: 'SetupHooks'@. + +These *setup hooks* allow package authors to customise the configuration and +building of a package by providing certain hooks that get folded into the +general package configuration and building logic within @Cabal@. + +This mechanism replaces the @Custom@ @build-type@, providing better +integration with the rest of the Haskell ecosystem. + +Usage example: + +> -- In your .cabal file +> build-type: Hooks +> +> custom-setup +> setup-depends: +> base >= 4.18 && < 5, +> Cabal-hooks >= 0.1 && < 0.2 +> +> The declared Cabal version should also be at least 3.12. + +> -- In SetupHooks.hs, next to your .cabal file +> module SetupHooks where +> import Distribution.Simple.SetupHooks ( SetupHooks, noSetupHooks ) +> +> setupHooks :: SetupHooks +> setupHooks = +> noSetupHooks +> { configureHooks = myConfigureHooks +> , buildHooks = myBuildHooks } + +Note that 'SetupHooks' can be monoidally combined, e.g.: + +> module SetupHooks where +> import Distribution.Simple.SetupHooks +> import qualified SomeOtherLibrary ( setupHooks ) +> +> setupHooks :: SetupHooks +> setupHooks = SomeOtherLibrary.setupHooks <> mySetupHooks +> +> mySetupHooks :: SetupHooks +> mySetupHooks = ... +-} + +{- $configureHooks +Configure hooks can be used to augment the Cabal configure logic with +package-specific logic. The main principle is that the configure hooks can +feed into updating the 'PackageDescription' of a @cabal@ package. From then on, +this package configuration is set in stone, and later hooks (e.g. hooks into +the build phase) can no longer modify this configuration; instead they will +receive this configuration in their inputs, and must honour it. + +Configuration happens at two levels: + + * global configuration covers the entire package, + * local configuration covers a single component. + +Once the global package configuration is done, all hooks work on a +per-component level. The configuration hooks thus follow a simple philosophy: + + * All modifications to global package options must use `preConfPackageHook`. + * All modifications to component configuration options must use `preConfComponentHook`. + +For example, to generate modules inside a given component, you should: + + * In the per-component configure hook, declare the modules you are going to + generate by adding them to the `autogenModules` field for that component + (unless you know them ahead of time, in which case they can be listed + textually in the @.cabal@ file of the project). + * In the build hooks, describe the actions that will generate these modules. +-} + +{- $preBuildRules +Pre-build hooks are specified as a collection of pre-build 'Rules'. +Each t'Rule' consists of: + + - a specification of its static dependencies and outputs, + - the commands that execute the rule. + +Rules are constructed using either one of the 'staticRule' or 'dynamicRule' +smart constructors. Directly constructing a t'Rule' using the constructors of +that data type is not advised, as this relies on internal implementation details +which are subject to change in between versions of the `Cabal-hooks` library. + +Note that: + + - To declare the dependency on the output of a rule, one must refer to the + rule directly, and not to the path to the output executing that rule will + eventually produce. + To do so, registering a t'Rule' with the API returns a unique identifier + for that rule, in the form of a t'RuleId'. + - File dependencies and outputs are not specified directly by + 'FilePath', but rather use the 'Location' type (which is more convenient + when working with preprocessors). + - Rules refer to the actions that execute them using static pointers, in order + to enable serialisation/deserialisation of rules. + - Rules can additionally monitor files or directories, which determines + when to re-compute the entire set of rules. +-} + +{- $rulesDemand +Rules can declare various kinds of dependencies: + + - 'staticDependencies': files or other rules that a rule statically depends on, + - extra dynamic dependencies, using the 'DynamicRuleCommands' constructor, + - 'MonitorFilePath': additional files and directories to monitor. + +Rules are considered __out-of-date__ precisely when any of the following +conditions apply: + + [O1] there has been a (relevant) change in the files and directories + monitored by the rules, + [O2] the environment passed to the computation of rules has changed. + +If the rules are out-of-date, the build system is expected to re-run the +computation that computes all rules. + +After this re-computation of the set of all rules, we match up new rules +with old rules, by 'RuleId'. A rule is then considered __stale__ if any of +following conditions apply: + + [N] the rule is new, or + [S] the rule matches with an old rule, and either: + + [S1] a file dependency of the rule has been modified/created/deleted, or + a (transitive) rule dependency of the rule is itself stale, or + [S2] the rule is different from the old rule, e.g. the argument stored in + the rule command has changed, or the pointer to the action to run the + rule has changed. (This is determined using the @Eq Rule@ instance.) + +A stale rule becomes no longer stale once we run its associated action. The +build system is responsible for re-running the actions associated with +each stale rule, in dependency order. This means the build system is expected +to behave as follows: + + 1. Any time the rules are out-of-date, query the rules to obtain + up-to-date rules. + 2. Re-run stale rules. +-} + +{- $rulesAPI +Defining pre-build rules can be done in the following style: + +> {-# LANGUAGE BlockArguments, StaticPointers #-} +> myPreBuildRules :: PreBuildComponentRules +> myPreBuildRules = rules (static ()) $ \ preBuildEnvironment -> do +> let cmd1 = mkCommand (static Dict) $ static \ arg -> do { .. } +> cmd2 = mkCommand (static Dict) $ static \ arg -> do { .. } +> myData <- liftIO someIOAction +> addRuleMonitors [ monitorDirectory "someSearchDir" ] +> registerRule_ "rule_1_1" $ staticRule (cmd1 arg1) deps1 outs1 +> registerRule_ "rule_1_2" $ staticRule (cmd1 arg2) deps2 outs2 +> registerRule_ "rule_1_3" $ staticRule (cmd1 arg3) deps3 outs3 +> registerRule_ "rule_2_4" $ staticRule (cmd2 arg4) deps4 outs4 + +Here we use the 'rules', 'staticRule' and 'mkCommand' smart constructors, +rather than directly using the v'Rules', v'Rule' and v'Command' constructors, +which insulates us from internal changes to the t'Rules', t'Rule' and t'Command' +datatypes, respectively. + +We use 'addRuleMonitors' to declare a monitored directory that the collection +of rules as a whole depends on. In this case, we declare that they depend on the +contents of the "searchDir" directory. This means that the rules will be +computed anew whenever the contents of this directory change. +-} + +{- Note [Not hiding SetupHooks constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We would like to hide as many datatype constructors from the API as possible +and provide smart constructors instead, so that hook authors don't end up +depending on internal implementation details that are subject to change. + +However, doing so significantly degrades the Haddock documentation. So we +instead opt for exposing the constructor, but suggesting users use the +corresponding smart constructor instead. +-} + +-------------------------------------------------------------------------------- +-- API functions + +-- | Register a rule. Returns an identifier for that rule. +registerRule + :: ShortText -- ^ user-given rule name; + -- these should be unique on a per-package level + -> Rule -- ^ the rule to register + -> RulesM RuleId +registerRule nm !newRule = RulesT $ do + RulesEnv { rulesEnvNameSpace = ns + , rulesEnvVerbosity = verbosity } <- Reader.ask + oldRules <- lift $ State.get + let rId = RuleId { ruleNameSpace = ns, ruleName = nm } + (mbDup, newRules) = Map.insertLookupWithKey (\ _ new _old -> new) rId newRule oldRules + for_ mbDup $ \ oldRule -> + liftIO $ dieWithException verbosity + $ SetupHooksException + $ RulesException + $ DuplicateRuleId rId oldRule newRule + lift $ State.put newRules + return rId + +-- | Register a rule, discarding the produced 'RuleId'. +-- +-- Using this function means that you don't expect any other rules to ever +-- depend on any outputs of this rule. Use 'registerRule' to retain the +-- 'RuleId' instead. +registerRule_ + :: ShortText -- ^ user-given rule name; + -- these should be unique on a per-package level + -> Rule -- ^ the rule to register + -> RulesT IO () +registerRule_ i r = void $ registerRule i r + +-- | Declare additional monitored objects for the collection of all rules. +-- +-- When these monitored objects change, the rules are re-computed. +addRuleMonitors :: Monad m => [MonitorFilePath] -> RulesT m () +addRuleMonitors = RulesT . lift . lift . Writer.tell +{-# INLINEABLE addRuleMonitors #-} + +-- | Find a file in the given search directories. +findFileInDirs :: FilePath -> [FilePath] -> IO (Maybe Location) +findFileInDirs file dirs = + findFirstFile + (uncurry ()) + [ (path, file) + | path <- nub dirs + ] + + -- TODO: add API functions that search and declare the appropriate monitoring + -- at the same time. diff --git a/Cabal-syntax/src/Distribution/CabalSpecVersion.hs b/Cabal-syntax/src/Distribution/CabalSpecVersion.hs index eb029b5ffc9..3d1f9418e4a 100644 --- a/Cabal-syntax/src/Distribution/CabalSpecVersion.hs +++ b/Cabal-syntax/src/Distribution/CabalSpecVersion.hs @@ -34,6 +34,7 @@ data CabalSpecVersion | CabalSpecV3_8 | -- 3.10: no changes CabalSpecV3_12 + | CabalSpecV3_14 deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic) instance Binary CabalSpecVersion @@ -44,6 +45,7 @@ instance NFData CabalSpecVersion where rnf = genericRnf -- -- @since 3.0.0.0 showCabalSpecVersion :: CabalSpecVersion -> String +showCabalSpecVersion CabalSpecV3_14 = "3.14" showCabalSpecVersion CabalSpecV3_12 = "3.12" showCabalSpecVersion CabalSpecV3_8 = "3.8" showCabalSpecVersion CabalSpecV3_6 = "3.6" @@ -65,13 +67,14 @@ showCabalSpecVersion CabalSpecV1_2 = "1.2" showCabalSpecVersion CabalSpecV1_0 = "1.0" cabalSpecLatest :: CabalSpecVersion -cabalSpecLatest = CabalSpecV3_12 +cabalSpecLatest = CabalSpecV3_14 -- | Parse 'CabalSpecVersion' from version digits. -- -- It may fail if for recent versions the version is not exact. cabalSpecFromVersionDigits :: [Int] -> Maybe CabalSpecVersion cabalSpecFromVersionDigits v + | v == [3, 14] = Just CabalSpecV3_14 | v == [3, 12] = Just CabalSpecV3_12 | v == [3, 8] = Just CabalSpecV3_8 | v == [3, 6] = Just CabalSpecV3_6 @@ -95,6 +98,7 @@ cabalSpecFromVersionDigits v -- | @since 3.4.0.0 cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] +cabalSpecToVersionDigits CabalSpecV3_14 = [3, 14] cabalSpecToVersionDigits CabalSpecV3_12 = [3, 12] cabalSpecToVersionDigits CabalSpecV3_8 = [3, 8] cabalSpecToVersionDigits CabalSpecV3_6 = [3, 6] diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index cd299b87675..ae4c0cfec6b 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -761,6 +761,10 @@ checkForUndefinedCustomSetup gpd = do parseFailure zeroPos $ "Since cabal-version: 1.24 specifying custom-setup section is mandatory" + when (buildType pd == Hooks && isNothing (setupBuildInfo pd)) $ + parseFailure zeroPos $ + "Packages with build-type: Hooks require a custom-setup stanza" + ------------------------------------------------------------------------------- -- Post processing of internal dependencies ------------------------------------------------------------------------------- @@ -988,7 +992,7 @@ parseHookedBuildInfo' lexWarnings fs = do -- RFC5234 ABNF): -- -- @ --- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS +-- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-spec-version *WS -- -- spec-version = NUM "." NUM [ "." NUM ] -- diff --git a/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs b/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs index ba6cb0284a3..88280ca56f9 100644 --- a/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs +++ b/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs @@ -17,6 +17,7 @@ data LicenseListVersion deriving (Eq, Ord, Show, Enum, Bounded) cabalSpecVersionToSPDXListVersion :: CabalSpecVersion -> LicenseListVersion +cabalSpecVersionToSPDXListVersion CabalSpecV3_14 = LicenseListVersion_3_23 cabalSpecVersionToSPDXListVersion CabalSpecV3_12 = LicenseListVersion_3_23 cabalSpecVersionToSPDXListVersion CabalSpecV3_8 = LicenseListVersion_3_16 cabalSpecVersionToSPDXListVersion CabalSpecV3_6 = LicenseListVersion_3_10 diff --git a/Cabal-syntax/src/Distribution/Types/BuildType.hs b/Cabal-syntax/src/Distribution/Types/BuildType.hs index e80770843f3..b94279eaf2e 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildType.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildType.hs @@ -29,6 +29,7 @@ data BuildType Make | -- | uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) Custom + | Hooks deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary BuildType @@ -36,7 +37,7 @@ instance Structured BuildType instance NFData BuildType where rnf = genericRnf knownBuildTypes :: [BuildType] -knownBuildTypes = [Simple, Configure, Make, Custom] +knownBuildTypes = [Simple, Configure, Make, Custom, Hooks] instance Pretty BuildType where pretty = Disp.text . show @@ -49,6 +50,11 @@ instance Parsec BuildType where "Configure" -> return Configure "Custom" -> return Custom "Make" -> return Make + "Hooks" -> do + v <- askCabalSpecVersion + if v >= CabalSpecV3_14 + then return Hooks + else fail "build-type: 'Hooks'. This feature requires cabal-version >= 3.14." "Default" -> do v <- askCabalSpecVersion if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs index 2bc8e206666..9b36dd9d7ce 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs @@ -33,15 +33,15 @@ md5Check proxy md5Int = structureHash proxy @?= md5FromInteger md5Int md5CheckGenericPackageDescription :: Proxy GenericPackageDescription -> Assertion md5CheckGenericPackageDescription proxy = md5Check proxy #if MIN_VERSION_base(4,19,0) - 0x6639f65b143830a97e9c4f448b9cabb0 + 0x4acd7857947385180d814f36dc1a759e #else - 0x855933700dccfbcc1d642e3470c3702c + 0x3ff3fa6c3c570bcafa10b457b1208cc8 #endif md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion md5CheckLocalBuildInfo proxy = md5Check proxy #if MIN_VERSION_base(4,19,0) - 0x2ae73730f60c7c947e2cb63c4aac1e54 + 0x5f774efdb0aedcbf5263d3d99e38d50b #else - 0x906cbfdef0bcdfe5734499cfabc615f5 + 0x0f53d756836a410f72b31feb7d9f7b09 #endif diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index c264a39ad14..6b35ac92e12 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -106,6 +106,7 @@ library Distribution.Simple.Compiler Distribution.Simple.Configure Distribution.Simple.Errors + Distribution.Simple.FileMonitor.Types Distribution.Simple.Flag Distribution.Simple.GHC Distribution.Simple.GHCJS @@ -148,6 +149,9 @@ library Distribution.Simple.Test.Log Distribution.Simple.UHC Distribution.Simple.UserHooks + Distribution.Simple.SetupHooks.Errors + Distribution.Simple.SetupHooks.Internal + Distribution.Simple.SetupHooks.Rule Distribution.Simple.Utils Distribution.TestSuite Distribution.Types.AnnotatedId diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index f444a4c23fe..ef97b0d23be 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -510,7 +510,7 @@ checkPackageDescription (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) (PackageBuildWarning NoBuildType) checkP - (isJust setupBuildInfo_ && buildType pkg /= Custom) + (isJust setupBuildInfo_ && buildType pkg `notElem` [Custom, Hooks]) (PackageBuildWarning NoCustomSetup) -- Contents. diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 657e37cbbc1..85eabcbe93c 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/Cabal/src/Distribution/Simple.hs @@ -1,8 +1,12 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- {- Work around this warning: @@ -54,6 +58,8 @@ module Distribution.Simple , UserHooks (..) , Args , defaultMainWithHooks + , defaultMainWithSetupHooks + , defaultMainWithSetupHooksArgs , defaultMainWithHooksArgs , defaultMainWithHooksNoRead , defaultMainWithHooksNoReadArgs @@ -67,6 +73,7 @@ module Distribution.Simple import Control.Exception (try) import Distribution.Compat.Prelude +import Distribution.Compat.ResponseFile (expandResponse) import Prelude () -- local @@ -80,6 +87,7 @@ import Distribution.Simple.PackageDescription import Distribution.Simple.PreProcess import Distribution.Simple.Program import Distribution.Simple.Setup +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import Distribution.Simple.UserHooks import Distribution.Simple.Build @@ -92,11 +100,14 @@ import Distribution.License import Distribution.Pretty import Distribution.Simple.Bench import Distribution.Simple.BuildPaths -import Distribution.Simple.ConfigureScript +import Distribution.Simple.ConfigureScript (runConfigureScript) import Distribution.Simple.Errors import Distribution.Simple.Haddock import Distribution.Simple.Install import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.SetupHooks.Internal + ( SetupHooks + ) import Distribution.Simple.Test import Distribution.Simple.Utils import Distribution.Utils.Path @@ -105,8 +116,7 @@ import Distribution.Version import Language.Haskell.Extension -- Base - -import Distribution.Compat.ResponseFile (expandResponse) +import Data.List (unionBy, (\\)) import System.Directory ( doesDirectoryExist , doesFileExist @@ -115,8 +125,6 @@ import System.Directory ) import System.Environment (getArgs, getProgName) -import Data.List (unionBy, (\\)) - -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the -- action specified on the command line. @@ -128,6 +136,112 @@ defaultMain = getArgs >>= defaultMainHelper simpleUserHooks defaultMainArgs :: [String] -> IO () defaultMainArgs = defaultMainHelper simpleUserHooks +defaultMainWithSetupHooks :: SetupHooks -> IO () +defaultMainWithSetupHooks setup_hooks = + getArgs >>= defaultMainWithSetupHooksArgs setup_hooks + +defaultMainWithSetupHooksArgs :: SetupHooks -> [String] -> IO () +defaultMainWithSetupHooksArgs setupHooks = + defaultMainHelper $ + simpleUserHooks + { confHook = setup_confHook + , buildHook = setup_buildHook + , copyHook = setup_copyHook + , instHook = setup_installHook + , replHook = setup_replHook + , haddockHook = setup_haddockHook + , hscolourHook = setup_hscolourHook + } + where + setup_confHook + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo + setup_confHook = + configure_setupHooks + (SetupHooks.configureHooks setupHooks) + + setup_buildHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () + setup_buildHook pkg_descr lbi hooks flags = + build_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + flags + (allSuffixHandlers hooks) + + setup_copyHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> CopyFlags + -> IO () + setup_copyHook pkg_descr lbi _hooks flags = + install_setupHooks + (SetupHooks.installHooks setupHooks) + pkg_descr + lbi + flags + + setup_installHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () + setup_installHook = + defaultInstallHook_setupHooks + (SetupHooks.installHooks setupHooks) + + setup_replHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> ReplFlags + -> [String] + -> IO () + setup_replHook pkg_descr lbi hooks flags args = + repl_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + flags + (allSuffixHandlers hooks) + args + + setup_haddockHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> HaddockFlags + -> IO () + setup_haddockHook pkg_descr lbi hooks flags = + haddock_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + (allSuffixHandlers hooks) + flags + + setup_hscolourHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> HscolourFlags + -> IO () + setup_hscolourHook pkg_descr lbi hooks flags = + hscolour_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + (allSuffixHandlers hooks) + flags + -- | A customizable version of 'defaultMain'. defaultMainWithHooks :: UserHooks -> IO () defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks @@ -256,12 +370,12 @@ configureAction globalFlags hooks flags args = do let epkg_descr = (pkg_descr0, pbi) - localbuildinfo0 <- confHook hooks epkg_descr flags' + lbi1 <- confHook hooks epkg_descr flags' -- remember the .cabal filename if we know it -- and all the extra command line args let localbuildinfo = - localbuildinfo0 + lbi1 { pkgDescrFile = mb_pd_file , extraConfigArgs = args } @@ -769,9 +883,9 @@ simpleUserHooks = , replHook = defaultReplHook , copyHook = \desc lbi _ f -> install desc lbi f , -- 'install' has correct 'copy' behavior with params - testHook = defaultTestHook + instHook = defaultInstallHook + , testHook = defaultTestHook , benchHook = defaultBenchHook - , instHook = defaultInstallHook , cleanHook = \p _ _ f -> clean p f , hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f , haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f @@ -903,19 +1017,30 @@ defaultInstallHook -> UserHooks -> InstallFlags -> IO () -defaultInstallHook pkg_descr localbuildinfo _ flags = do +defaultInstallHook = + defaultInstallHook_setupHooks SetupHooks.noInstallHooks + +defaultInstallHook_setupHooks + :: SetupHooks.InstallHooks + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () +defaultInstallHook_setupHooks inst_hooks pkg_descr localbuildinfo _ flags = do let copyFlags = defaultCopyFlags { copyDest = installDest flags , copyCommonFlags = installCommonFlags flags } - install pkg_descr localbuildinfo copyFlags + install_setupHooks inst_hooks pkg_descr localbuildinfo copyFlags let registerFlags = defaultRegisterFlags { regInPlace = installInPlace flags , regPackageDB = installPackageDB flags } - when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + when (hasLibs pkg_descr) $ + register pkg_descr localbuildinfo registerFlags defaultBuildHook :: PackageDescription diff --git a/Cabal/src/Distribution/Simple/Bench.hs b/Cabal/src/Distribution/Simple/Bench.hs index da4788adce0..3d22f2dc42d 100644 --- a/Cabal/src/Distribution/Simple/Bench.hs +++ b/Cabal/src/Distribution/Simple/Bench.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -53,13 +55,13 @@ bench args pkg_descr lbi flags = do let verbosity = fromFlag $ benchmarkVerbosity flags benchmarkNames = args pkgBenchmarks = PD.benchmarks pkg_descr - enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi) + enabledBenchmarks = LBI.enabledBenchLBIs pkg_descr lbi mbWorkDir = flagToMaybe $ benchmarkWorkingDir flags i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path -- Run the benchmark - doBench :: PD.Benchmark -> IO ExitCode - doBench bm = + doBench :: (PD.Benchmark, LBI.ComponentLocalBuildInfo) -> IO ExitCode + doBench (bm, _clbi) = case PD.benchmarkInterface bm of PD.BenchmarkExeV10 _ _ -> do let cmd = i $ LBI.buildDir lbi makeRelativePathEx (name name <.> exeExtension (LBI.hostPlatform lbi)) @@ -100,7 +102,7 @@ bench args pkg_descr lbi flags = do [] -> return enabledBenchmarks names -> for names $ \bmName -> let benchmarkMap = zip enabledNames enabledBenchmarks - enabledNames = map PD.benchmarkName enabledBenchmarks + enabledNames = map (PD.benchmarkName . fst) enabledBenchmarks allNames = map PD.benchmarkName pkgBenchmarks in case lookup (mkUnqualComponentName bmName) benchmarkMap of Just t -> return t @@ -112,6 +114,7 @@ bench args pkg_descr lbi flags = do let totalBenchmarks = length bmsToRun notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." exitcodes <- traverse doBench bmsToRun + let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) unless allOk exitFailure where diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index e4e40b5fb5f..a198f3d2f4f 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -23,9 +25,11 @@ module Distribution.Simple.Build ( -- * Build build + , build_setupHooks -- * Repl , repl + , repl_setupHooks , startInterpreter -- * Build preparation @@ -94,6 +98,13 @@ import Distribution.Simple.Setup.Build import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Config import Distribution.Simple.Setup.Repl +import Distribution.Simple.SetupHooks.Internal + ( BuildHooks (..) + , BuildingWhat (..) + , noBuildHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks import Distribution.Simple.ShowBuildInfo import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils @@ -127,70 +138,107 @@ build -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> IO () -build pkg_descr lbi flags suffixes = do - let distPref = fromFlag $ buildDistPref flags - verbosity = fromFlag $ buildVerbosity flags - checkSemaphoreSupport verbosity (compiler lbi) flags - targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags) - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - info verbosity $ - "Component build order: " - ++ intercalate - ", " - ( map - (showComponentName . componentLocalName . targetCLBI) - componentsToBuild - ) +build = build_setupHooks noBuildHooks - when (null targets) $ - -- Only bother with this message if we're building the whole package - setupMessage verbosity "Building" (packageId pkg_descr) - - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - -- Before the actual building, dump out build-information. - -- This way, if the actual compilation failed, the options have still been - -- dumped. - dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags $ lbi)) pkg_descr lbi $ - flags - - -- Now do the actual building - (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do - preBuildComponent verbosity lbi target - let comp = targetComponent target - clbi = targetCLBI target - bi = componentBuildInfo comp - progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) - lbi' = - lbi - { withPrograms = progs' - , withPackageDB = withPackageDB lbi ++ [internalPackageDB] - , installedPkgs = index - } - let numJobs = buildNumJobs flags - par_strat <- - toFlag <$> case buildUseSemaphore flags of - Flag sem_name -> case numJobs of - Flag{} -> do - warn verbosity $ "Ignoring -j due to --semaphore" - return $ UseSem sem_name - NoFlag -> return $ UseSem sem_name - NoFlag -> return $ case numJobs of - Flag n -> NumJobs n - NoFlag -> Serial - mb_ipi <- - buildComponent - flags - par_strat - pkg_descr - lbi' - suffixes - comp - clbi - distPref - return (maybe index (Index.insert `flip` index) mb_ipi) +build_setupHooks + :: BuildHooks + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> IO () +build_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild}) + pkg_descr + lbi + flags + suffixHandlers = do + checkSemaphoreSupport verbosity (compiler lbi) flags + targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags) + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) + info verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) - return () + when (null targets) $ + -- Only bother with this message if we're building the whole package + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + -- Before the actual building, dump out build-information. + -- This way, if the actual compilation failed, the options have still been + -- dumped. + dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags + + -- Now do the actual building + (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do + let comp = targetComponent target + clbi = targetCLBI target + bi = componentBuildInfo comp + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = + lbi + { withPrograms = progs' + , withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildNormal flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + preBuildComponent runPreBuildHooks verbosity lbi' target + + let numJobs = buildNumJobs flags + par_strat <- + toFlag <$> case buildUseSemaphore flags of + Flag sem_name -> case numJobs of + Flag{} -> do + warn verbosity $ "Ignoring -j due to --semaphore" + return $ UseSem sem_name + NoFlag -> return $ UseSem sem_name + NoFlag -> return $ case numJobs of + Flag n -> NumJobs n + NoFlag -> Serial + mb_ipi <- + buildComponent + flags + par_strat + pkg_descr + lbi' + suffixHandlers + comp + clbi + distPref + let postBuildInputs = + SetupHooks.PostBuildComponentInputs + { SetupHooks.buildFlags = flags + , SetupHooks.localBuildInfo = lbi' + , SetupHooks.targetInfo = target + } + for_ mbPostBuild ($ postBuildInputs) + return (maybe index (Index.insert `flip` index) mb_ipi) + + return () + where + distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) -- | Check for conditions that would prevent the build from succeeding. checkSemaphoreSupport @@ -277,66 +325,98 @@ repl -- ^ preprocessors to run before compiling -> [String] -> IO () -repl pkg_descr lbi flags suffixes args = do - let distPref = fromFlag $ replDistPref flags - verbosity = fromFlag $ replVerbosity flags - - target <- - readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of - -- This seems DEEPLY questionable. - [] -> case allTargetsInBuildOrder' pkg_descr lbi of - (target : _) -> return target - [] -> dieWithException verbosity $ FailedToDetermineTarget - [target] -> return target - _ -> dieWithException verbosity $ NoMultipleTargets - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] - debug verbosity $ - "Component build order: " - ++ intercalate - ", " - ( map - (showComponentName . componentLocalName . targetCLBI) - componentsToBuild - ) +repl = repl_setupHooks noBuildHooks - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - let lbiForComponent comp lbi' = - lbi' - { withPackageDB = withPackageDB lbi ++ [internalPackageDB] - , withPrograms = - addInternalBuildTools - pkg_descr - lbi' - (componentBuildInfo comp) - (withPrograms lbi') - } +repl_setupHooks + :: BuildHooks + -- ^ build hook + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> ReplFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> [String] + -> IO () +repl_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules}) + pkg_descr + lbi + flags + suffixHandlers + args = do + let distPref = fromFlag (replDistPref flags) + verbosity = fromFlag (replVerbosity flags) + + target <- + readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of + -- This seems DEEPLY questionable. + [] -> case allTargetsInBuildOrder' pkg_descr lbi of + (target : _) -> return target + [] -> dieWithException verbosity $ FailedToDetermineTarget + [target] -> return target + _ -> dieWithException verbosity $ NoMultipleTargets + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] + debug verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) - -- build any dependent components - sequence_ - [ do - let clbi = targetCLBI subtarget - comp = targetComponent subtarget - lbi' = lbiForComponent comp lbi - preBuildComponent verbosity lbi subtarget - buildComponent - mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}} - NoFlag - pkg_descr - lbi' - suffixes - comp - clbi - distPref - | subtarget <- safeInit componentsToBuild - ] - - -- REPL for target components - let clbi = targetCLBI target - comp = targetComponent target - lbi' = lbiForComponent comp lbi - preBuildComponent verbosity lbi target - replComponent flags verbosity pkg_descr lbi' suffixes comp clbi distPref + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + let lbiForComponent comp lbi' = + lbi' + { withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , withPrograms = + addInternalBuildTools + pkg_descr + lbi' + (componentBuildInfo comp) + (withPrograms lbi') + } + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildRepl flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + + -- build any dependent components + sequence_ + [ do + let clbi = targetCLBI subtarget + comp = targetComponent subtarget + lbi' = lbiForComponent comp lbi + preBuildComponent runPreBuildHooks verbosity lbi' subtarget + buildComponent + (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}}) + NoFlag + pkg_descr + lbi' + suffixHandlers + comp + clbi + distPref + | subtarget <- safeInit componentsToBuild + ] + + -- REPL for target components + let clbi = targetCLBI target + comp = targetComponent target + lbi' = lbiForComponent comp lbi + preBuildComponent runPreBuildHooks verbosity lbi' target + replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref -- | Start an interpreter without loading any package files. startInterpreter @@ -373,7 +453,7 @@ buildComponent numJobs pkg_descr lbi0 - suffixes + suffixHandlers comp@( CTest test@TestSuite{testInterface = TestSuiteLibV09{}} ) @@ -388,7 +468,7 @@ buildComponent let verbosity = fromFlag $ buildVerbosity flags let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity setupMessage' @@ -425,13 +505,13 @@ buildComponent numJobs pkg_descr lbi - suffixes + suffixHandlers comp clbi distPref = do let verbosity = fromFlag $ buildVerbosity flags - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi setupMessage' verbosity @@ -618,7 +698,7 @@ replComponent verbosity pkg_descr lbi0 - suffixes + suffixHandlers comp@( CTest test@TestSuite{testInterface = TestSuiteLibV09{}} ) @@ -627,7 +707,7 @@ replComponent inplaceDir <- absoluteWorkingDirLBI lbi0 let (pkg, lib, libClbi, lbi, _, _, _) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} @@ -637,12 +717,12 @@ replComponent verbosity pkg_descr lbi - suffixes + suffixHandlers comp clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi case comp of CLib lib -> do @@ -949,19 +1029,22 @@ replFLib flags pkg_descr lbi exe clbi = GHC -> GHC.replFLib flags NoFlag pkg_descr lbi exe clbi _ -> dieWithException verbosity REPLNotSupported --- | Pre-build steps for a component: creates the autogenerated files --- for a particular configured component. +-- | Creates the autogenerated files for a particular configured component, +-- and runs the pre-build hook. preBuildComponent - :: Verbosity + :: (LocalBuildInfo -> TargetInfo -> IO ()) + -- ^ pre-build hook + -> Verbosity -> LocalBuildInfo -- ^ Configuration information -> TargetInfo -> IO () -preBuildComponent verbosity lbi tgt = do +preBuildComponent preBuildHook verbosity lbi tgt = do let pkg_descr = localPkgDescr lbi clbi = targetCLBI tgt createDirectoryIfMissingVerbose verbosity True (interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi) writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi + preBuildHook lbi tgt -- | Generate and write to disk all built-in autogenerated files -- for the specified component. These files will be put in the diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 0a788af830c..3dfe0b7e0be 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -32,6 +32,7 @@ -- level. module Distribution.Simple.Configure ( configure + , configure_setupHooks , writePersistBuildConfig , getConfigStateFile , getPersistBuildConfig @@ -86,9 +87,21 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PreProcess import Distribution.Simple.Program -import Distribution.Simple.Program.Db (lookupProgramByName, modifyProgramSearchPath, prependProgramSearchPath) +import Distribution.Simple.Program.Db + ( ProgramDb (..) + , lookupProgramByName + , modifyProgramSearchPath + , prependProgramSearchPath + , updateConfiguredProgs + ) import Distribution.Simple.Setup.Common as Setup import Distribution.Simple.Setup.Config as Setup +import Distribution.Simple.SetupHooks.Internal + ( ConfigureHooks (..) + , applyComponentDiffs + , noConfigureHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentRequestedSpec @@ -435,17 +448,99 @@ configure :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo -configure (g_pkg_descr, hookedBuildInfo) cfg = do - -- Cabal pre-configure - (lbc1, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr +configure = configure_setupHooks noConfigureHooks + +configure_setupHooks + :: ConfigureHooks + -> (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +configure_setupHooks + (ConfigureHooks{preConfPackageHook, postConfPackageHook, preConfComponentHook}) + (g_pkg_descr, hookedBuildInfo) + cfg = do + -- Cabal pre-configure + let verbosity = fromFlag (configVerbosity cfg) + distPref = fromFlag $ configDistPref cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg + (lbc0, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr + + -- Package-wide pre-configure hook + lbc1 <- + case preConfPackageHook of + Nothing -> return lbc0 + Just pre_conf -> do + let programDb0 = LBC.withPrograms lbc0 + programDb0' = programDb0{unconfiguredProgs = Map.empty} + input = + SetupHooks.PreConfPackageInputs + { SetupHooks.configFlags = cfg + , SetupHooks.localBuildConfig = lbc0{LBC.withPrograms = programDb0'} + , -- Unconfigured programs are not supplied to the hook, + -- as these cannot be passed over a serialisation boundary + -- (see the "Binary ProgramDb" instance). + SetupHooks.compiler = comp + , SetupHooks.platform = platform + } + SetupHooks.PreConfPackageOutputs + { SetupHooks.buildOptions = opts1 + , SetupHooks.extraConfiguredProgs = progs1 + } <- + pre_conf input + -- The package-wide pre-configure hook returns BuildOptions that + -- overrides the one it was passed in, as well as an update to + -- the ProgramDb in the form of new configured programs to add + -- to the program database. + return $ + lbc0 + { LBC.withBuildOptions = opts1 + , LBC.withPrograms = + updateConfiguredProgs + (`Map.union` progs1) + programDb0 + } + + -- Cabal package-wide configure + (lbc2, pbd2, pkg_info) <- + finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps + + -- Package-wide post-configure hook + for_ postConfPackageHook $ \postConfPkg -> do + let input = + SetupHooks.PostConfPackageInputs + { SetupHooks.localBuildConfig = lbc2 + , SetupHooks.packageBuildDescr = pbd2 + } + postConfPkg input + + -- Per-component pre-configure hook + pkg_descr <- do + let pkg_descr2 = LBC.localPkgDescr pbd2 + applyComponentDiffs + verbosity + ( \c -> for preConfComponentHook $ \computeDiff -> do + let input = + SetupHooks.PreConfComponentInputs + { SetupHooks.localBuildConfig = lbc2 + , SetupHooks.packageBuildDescr = pbd2 + , SetupHooks.component = c + } + SetupHooks.PreConfComponentOutputs + { SetupHooks.componentDiff = diff + } <- + computeDiff input + return diff + ) + pkg_descr2 + let pbd3 = pbd2{LBC.localPkgDescr = pkg_descr} + + -- Cabal per-component configure + externalPkgDeps <- finalCheckPackage g_pkg_descr pbd3 hookedBuildInfo pkg_info + lbi <- configureComponents lbc2 pbd3 pkg_info externalPkgDeps - -- Cabal package-wide configure - (lbc2, pbd2, pkg_info) <- - finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps + writePersistBuildConfig mbWorkDir distPref lbi - -- Cabal per-component configure - externalPkgDeps <- finalCheckPackage g_pkg_descr pbd2 hookedBuildInfo pkg_info - configureComponents lbc2 pbd2 pkg_info externalPkgDeps + return lbi preConfigurePackage :: ConfigFlags diff --git a/Cabal/src/Distribution/Simple/Errors.hs b/Cabal/src/Distribution/Simple/Errors.hs index 1ca8c97c6c6..45029565e99 100644 --- a/Cabal/src/Distribution/Simple/Errors.hs +++ b/Cabal/src/Distribution/Simple/Errors.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- -- Module : Distribution.Simple.Errors @@ -20,18 +22,15 @@ import Distribution.Compiler import Distribution.InstalledPackageInfo import Distribution.ModuleName import Distribution.Package -import Distribution.PackageDescription (FlagName, UnqualComponentName) +import Distribution.PackageDescription import Distribution.Pretty ( Pretty (pretty) , prettyShow ) import Distribution.Simple.InstallDirs import Distribution.Simple.PreProcess.Types (Suffix) +import Distribution.Simple.SetupHooks.Errors import Distribution.System (OS) -import Distribution.Types.BenchmarkType -import Distribution.Types.LibraryName -import Distribution.Types.PkgconfigVersion -import Distribution.Types.TestType import Distribution.Types.VersionRange.Internal () import Distribution.Version import Text.PrettyPrint @@ -171,6 +170,7 @@ data CabalException | BadVersionDb String Version VersionRange FilePath | UnknownVersionDb String VersionRange FilePath | MissingCoveredInstalledLibrary UnitId + | SetupHooksException SetupHooksException deriving (Show, Typeable) exceptionCode :: CabalException -> Int @@ -302,6 +302,8 @@ exceptionCode e = case e of BadVersionDb{} -> 8038 UnknownVersionDb{} -> 1008 MissingCoveredInstalledLibrary{} -> 9341 + SetupHooksException err -> + setupHooksExceptionCode err versionRequirement :: VersionRange -> String versionRequirement range @@ -317,7 +319,7 @@ exceptionMessage e = case e of NoLibraryFound -> "No executables and no library found. Nothing to do." CompilerNotInstalled compilerFlavor -> "installing with " ++ prettyShow compilerFlavor ++ "is not implemented" CantFindIncludeFile file -> "can't find include file " ++ file - UnsupportedTestSuite testType -> "Unsupported test suite type: " ++ testType + UnsupportedTestSuite test_type -> "Unsupported test suite type: " ++ test_type UnsupportedBenchMark benchMarkType -> "Unsupported benchmark type: " ++ benchMarkType NoIncludeFileFound f -> "can't find include file " ++ f NoModuleFound m suffixes -> @@ -359,7 +361,7 @@ exceptionMessage e = case e of FailedToDetermineTarget -> "Failed to determine target." NoMultipleTargets -> "The 'repl' command does not support multiple targets at once." REPLNotSupported -> "A REPL is not supported with this compiler." - NoSupportBuildingTestSuite testType -> "No support for building test suite type " ++ show testType + NoSupportBuildingTestSuite test_type -> "No support for building test suite type " ++ show test_type NoSupportBuildingBenchMark benchMarkType -> "No support for building benchmark type " ++ show benchMarkType BuildingNotSupportedWithCompiler -> "Building is not supported with this compiler." ProvideHaskellSuiteTool msg -> show msg @@ -795,3 +797,5 @@ exceptionMessage e = case e of "Failed to find the installed unit '" ++ prettyShow unitId ++ "' in package database stack." + SetupHooksException err -> + setupHooksExceptionMessage err diff --git a/Cabal/src/Distribution/Simple/FileMonitor/Types.hs b/Cabal/src/Distribution/Simple/FileMonitor/Types.hs new file mode 100644 index 00000000000..17ca3198882 --- /dev/null +++ b/Cabal/src/Distribution/Simple/FileMonitor/Types.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | +-- Module: Distribution.Simple.FileMonitor.Types +-- +-- Types for monitoring files and directories. +module Distribution.Simple.FileMonitor.Types + ( -- * Globs with respect to a root + RootedGlob (..) + , FilePathRoot (..) + , Glob + + -- * File monitoring + , MonitorFilePath (..) + , MonitorKindFile (..) + , MonitorKindDir (..) + + -- ** Utility constructors of t'MonitorFilePath' + , monitorFile + , monitorFileHashed + , monitorNonExistentFile + , monitorFileExistence + , monitorDirectory + , monitorNonExistentDirectory + , monitorDirectoryExistence + , monitorFileOrDirectory + , monitorFileGlob + , monitorFileGlobExistence + , monitorFileSearchPath + , monitorFileHashedSearchPath + ) +where + +import Distribution.Compat.Prelude +import Distribution.Simple.Glob.Internal + ( Glob (..) + ) + +import qualified Distribution.Compat.CharParsing as P +import Distribution.Parsec +import Distribution.Pretty +import qualified Text.PrettyPrint as Disp + +-------------------------------------------------------------------------------- +-- Rooted globs. +-- + +-- | A file path specified by globbing, relative +-- to some root directory. +data RootedGlob + = RootedGlob + FilePathRoot + -- ^ what the glob is relative to + Glob + -- ^ the glob + deriving (Eq, Show, Generic) + +instance Binary RootedGlob +instance Structured RootedGlob + +data FilePathRoot + = FilePathRelative + | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive' + FilePathRoot FilePath + | FilePathHomeDir + deriving (Eq, Show, Generic) + +instance Binary FilePathRoot +instance Structured FilePathRoot + +------------------------------------------------------------------------------ +-- Types for specifying files to monitor +-- + +-- | A description of a file (or set of files) to monitor for changes. +-- +-- Where file paths are relative they are relative to a common directory +-- (e.g. project root), not necessarily the process current directory. +data MonitorFilePath + = MonitorFile + { monitorKindFile :: !MonitorKindFile + , monitorKindDir :: !MonitorKindDir + , monitorPath :: !FilePath + } + | MonitorFileGlob + { monitorKindFile :: !MonitorKindFile + , monitorKindDir :: !MonitorKindDir + , monitorPathGlob :: !RootedGlob + } + deriving (Eq, Show, Generic) + +data MonitorKindFile + = FileExists + | FileModTime + | FileHashed + | FileNotExists + deriving (Eq, Show, Generic) + +data MonitorKindDir + = DirExists + | DirModTime + | DirNotExists + deriving (Eq, Show, Generic) + +instance Binary MonitorFilePath +instance Binary MonitorKindFile +instance Binary MonitorKindDir + +instance Structured MonitorFilePath +instance Structured MonitorKindFile +instance Structured MonitorKindDir + +-- | Monitor a single file for changes, based on its modification time. +-- The monitored file is considered to have changed if it no longer +-- exists or if its modification time has changed. +monitorFile :: FilePath -> MonitorFilePath +monitorFile = MonitorFile FileModTime DirNotExists + +-- | Monitor a single file for changes, based on its modification time +-- and content hash. The monitored file is considered to have changed if +-- it no longer exists or if its modification time and content hash have +-- changed. +monitorFileHashed :: FilePath -> MonitorFilePath +monitorFileHashed = MonitorFile FileHashed DirNotExists + +-- | Monitor a single non-existent file for changes. The monitored file +-- is considered to have changed if it exists. +monitorNonExistentFile :: FilePath -> MonitorFilePath +monitorNonExistentFile = MonitorFile FileNotExists DirNotExists + +-- | Monitor a single file for existence only. The monitored file is +-- considered to have changed if it no longer exists. +monitorFileExistence :: FilePath -> MonitorFilePath +monitorFileExistence = MonitorFile FileExists DirNotExists + +-- | Monitor a single directory for changes, based on its modification +-- time. The monitored directory is considered to have changed if it no +-- longer exists or if its modification time has changed. +monitorDirectory :: FilePath -> MonitorFilePath +monitorDirectory = MonitorFile FileNotExists DirModTime + +-- | Monitor a single non-existent directory for changes. The monitored +-- directory is considered to have changed if it exists. +monitorNonExistentDirectory :: FilePath -> MonitorFilePath +-- Just an alias for monitorNonExistentFile, since you can't +-- tell the difference between a non-existent directory and +-- a non-existent file :) +monitorNonExistentDirectory = monitorNonExistentFile + +-- | Monitor a single directory for existence. The monitored directory is +-- considered to have changed only if it no longer exists. +monitorDirectoryExistence :: FilePath -> MonitorFilePath +monitorDirectoryExistence = MonitorFile FileNotExists DirExists + +-- | Monitor a single file or directory for changes, based on its modification +-- time. The monitored file is considered to have changed if it no longer +-- exists or if its modification time has changed. +monitorFileOrDirectory :: FilePath -> MonitorFilePath +monitorFileOrDirectory = MonitorFile FileModTime DirModTime + +-- | Monitor a set of files (or directories) identified by a file glob. +-- The monitored glob is considered to have changed if the set of files +-- matching the glob changes (i.e. creations or deletions), or for files if the +-- modification time and content hash of any matching file has changed. +monitorFileGlob :: RootedGlob -> MonitorFilePath +monitorFileGlob = MonitorFileGlob FileHashed DirExists + +-- | Monitor a set of files (or directories) identified by a file glob for +-- existence only. The monitored glob is considered to have changed if the set +-- of files matching the glob changes (i.e. creations or deletions). +monitorFileGlobExistence :: RootedGlob -> MonitorFilePath +monitorFileGlobExistence = MonitorFileGlob FileExists DirExists + +-- | Creates a list of files to monitor when you search for a file which +-- unsuccessfully looked in @notFoundAtPaths@ before finding it at +-- @foundAtPath@. +monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] +monitorFileSearchPath notFoundAtPaths foundAtPath = + monitorFile foundAtPath + : map monitorNonExistentFile notFoundAtPaths + +-- | Similar to 'monitorFileSearchPath', but also instructs us to +-- monitor the hash of the found file. +monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] +monitorFileHashedSearchPath notFoundAtPaths foundAtPath = + monitorFileHashed foundAtPath + : map monitorNonExistentFile notFoundAtPaths + +------------------------------------------------------------------------------ +-- Parsing & pretty-printing +-- + +instance Pretty RootedGlob where + pretty (RootedGlob root pathglob) = pretty root Disp.<> pretty pathglob + +instance Parsec RootedGlob where + parsec = do + root <- parsec + case root of + FilePathRelative -> RootedGlob root <$> parsec + _ -> RootedGlob root <$> parsec <|> pure (RootedGlob root GlobDirTrailing) + +instance Pretty FilePathRoot where + pretty FilePathRelative = Disp.empty + pretty (FilePathRoot root) = Disp.text root + pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' + +instance Parsec FilePathRoot where + parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative + where + root = FilePathRoot "/" <$ P.char '/' + home = FilePathHomeDir <$ P.string "~/" + drive = do + dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') + _ <- P.char ':' + _ <- P.char '/' <|> P.char '\\' + return (FilePathRoot (toUpper dr : ":\\")) diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 17ee7a76bc5..8798d7a8578 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -24,6 +24,8 @@ module Distribution.Simple.Glob , GlobResult (..) , globMatches , fileGlobMatches + , matchGlob + , matchGlobPieces , matchDirFileGlob , matchDirFileGlobWithDie , runDirFileGlob @@ -41,14 +43,30 @@ where import Distribution.Compat.Prelude import Prelude () -import Distribution.CabalSpecVersion (CabalSpecVersion) +import Distribution.CabalSpecVersion + ( CabalSpecVersion (..) + ) +import Distribution.Pretty import Distribution.Simple.Errors ( CabalException (MatchDirFileGlob, MatchDirFileGlobErrors) ) import Distribution.Simple.Glob.Internal -import Distribution.Simple.Utils (dieWithException, warn) +import Distribution.Simple.Utils + ( debug + , dieWithException + , getDirectoryContentsRecursive + , warn + ) import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity + ( Verbosity + , silent + ) + +import Control.Monad (mapM) +import Data.List (stripPrefix) +import System.Directory +import System.FilePath hiding ((<.>), ()) ------------------------------------------------------------------------------- @@ -56,6 +74,51 @@ import Distribution.Verbosity (Verbosity) -------------------------------------------------------------------------------- +-- | Match a 'Glob' against the file system, starting from a +-- given root directory. The results are all relative to the given root. +-- +-- @since 3.12.0.0 +matchGlob :: FilePath -> Glob -> IO [FilePath] +matchGlob root glob = + -- For this function, which is the general globbing one (doesn't care about + -- cabal spec, used e.g. for monitoring), we consider all matches. + mapMaybe + ( \case + GlobMatch a -> Just a + GlobWarnMultiDot a -> Just a + GlobMatchesDirectory a -> Just a + GlobMissingDirectory{} -> Nothing + ) + <$> runDirFileGlob silent Nothing root glob + +-- | Match a globbing pattern against a file path component +matchGlobPieces :: GlobPieces -> String -> Bool +matchGlobPieces = goStart + where + -- From the man page, glob(7): + -- "If a filename starts with a '.', this character must be + -- matched explicitly." + + go, goStart :: [GlobPiece] -> String -> Bool + + goStart (WildCard : _) ('.' : _) = False + goStart (Union globs : rest) cs = + any + (\glob -> goStart (glob ++ rest) cs) + globs + goStart rest cs = go rest cs + + go [] "" = True + go (Literal lit : rest) cs + | Just cs' <- stripPrefix lit cs = + go rest cs' + | otherwise = False + go [WildCard] "" = True + go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs + go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs + go [] (_ : _) = False + go (_ : _) "" = False + -- | Extract the matches from a list of 'GlobResult's. -- -- Note: throws away the 'GlobMissingDirectory' results; chances are @@ -136,3 +199,306 @@ matchDirFileGlobWithDie verbosity rip version mbWorkDir symPath = unlines warns return $ map unsafeMakeSymbolicPath matches else rip verbosity $ MatchDirFileGlobErrors errors + +------------------------------------------------------------------------------- + +-- * Parsing & printing + +-------------------------------------------------------------------------------- +-- Filepaths with globs may be parsed in the special context is globbing in +-- cabal package fields, such as `data-files`. In that case, we restrict the +-- globbing syntax to that supported by the cabal spec version in use. +-- Otherwise, we parse the globs to the extent of our globbing features +-- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`). + +-- ** Parsing globs in a cabal package + +parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob +parseFileGlob version filepath = case reverse (splitDirectories filepath) of + [] -> + Left EmptyGlob + (filename : "**" : segments) + | allowGlobStar -> do + finalSegment <- case splitExtensions filename of + ("*", ext) + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext]) + _ + | allowLiteralFilenameGlobStar -> + Right (GlobDirRecursive [Literal filename]) + | otherwise -> + Left LiteralFileNameGlobStar + + foldM addStem finalSegment segments + | otherwise -> Left VersionDoesNotSupportGlobStar + (filename : segments) -> do + pat <- case splitExtensions filename of + ("*", ext) + | not allowGlob -> Left VersionDoesNotSupportGlob + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (GlobFile [WildCard, Literal ext]) + (_, ext) + | '*' `elem` ext -> Left StarInExtension + | '*' `elem` filename -> Left StarInFileName + | otherwise -> Right (GlobFile [Literal filename]) + + foldM addStem pat segments + where + addStem pat seg + | '*' `elem` seg = Left StarInDirectory + | otherwise = Right (GlobDir [Literal seg] pat) + allowGlob = version >= CabalSpecV1_6 + allowGlobStar = version >= CabalSpecV2_4 + allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 + +enableMultidot :: CabalSpecVersion -> Bool +enableMultidot version + | version >= CabalSpecV2_4 = True + | otherwise = False + +-------------------------------------------------------------------------------- +-- Parse and printing utils +-------------------------------------------------------------------------------- + +-- ** Cabal package globbing errors + +data GlobSyntaxError + = StarInDirectory + | StarInFileName + | StarInExtension + | NoExtensionOnStar + | EmptyGlob + | LiteralFileNameGlobStar + | VersionDoesNotSupportGlobStar + | VersionDoesNotSupportGlob + deriving (Eq, Show) + +explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String +explainGlobSyntaxError filepath StarInDirectory = + "invalid file glob '" + ++ filepath + ++ "'. A wildcard '**' is only allowed as the final parent" + ++ " directory. Stars must not otherwise appear in the parent" + ++ " directories." +explainGlobSyntaxError filepath StarInExtension = + "invalid file glob '" + ++ filepath + ++ "'. Wildcards '*' are only allowed as the" + ++ " file's base name, not in the file extension." +explainGlobSyntaxError filepath StarInFileName = + "invalid file glob '" + ++ filepath + ++ "'. Wildcards '*' may only totally replace the" + ++ " file's base name, not only parts of it." +explainGlobSyntaxError filepath NoExtensionOnStar = + "invalid file glob '" + ++ filepath + ++ "'. If a wildcard '*' is used it must be with an file extension." +explainGlobSyntaxError filepath LiteralFileNameGlobStar = + "invalid file glob '" + ++ filepath + ++ "'. Prior to 'cabal-version: 3.8'" + ++ " if a wildcard '**' is used as a parent directory, the" + ++ " file's base name must be a wildcard '*'." +explainGlobSyntaxError _ EmptyGlob = + "invalid file glob. A glob cannot be the empty string." +explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = + "invalid file glob '" + ++ filepath + ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" + ++ " or greater. Alternatively, for compatibility with earlier Cabal" + ++ " versions, list the included directories explicitly." +explainGlobSyntaxError filepath VersionDoesNotSupportGlob = + "invalid file glob '" + ++ filepath + ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " + ++ "Alternatively if you require compatibility with earlier Cabal " + ++ "versions then list all the files explicitly." + +-- Note throughout that we use splitDirectories, not splitPath. On +-- Posix, this makes no difference, but, because Windows accepts both +-- slash and backslash as its path separators, if we left in the +-- separators from the glob we might not end up properly normalised. + +data GlobResult a + = -- | The glob matched the value supplied. + GlobMatch a + | -- | The glob did not match the value supplied because the + -- cabal-version is too low and the extensions on the file did + -- not precisely match the glob's extensions, but rather the + -- glob was a proper suffix of the file's extensions; i.e., if + -- not for the low cabal-version, it would have matched. + GlobWarnMultiDot a + | -- | The glob couldn't match because the directory named doesn't + -- exist. The directory will be as it appears in the glob (i.e., + -- relative to the directory passed to 'matchDirFileGlob', and, + -- for 'data-files', relative to 'data-dir'). + GlobMissingDirectory a + | -- | The glob matched a directory when we were looking for files only. + -- It didn't match a file! + -- + -- @since 3.12.0.0 + GlobMatchesDirectory a + deriving (Show, Eq, Ord, Functor) + +-- | Match files against a pre-parsed glob, starting in a directory. +-- +-- The 'Version' argument must be the spec version of the package +-- description being processed, as globs behave slightly differently +-- in different spec versions. +-- +-- The 'FilePath' argument is the directory that the glob is relative +-- to. It must be a valid directory (and hence it can't be the empty +-- string). The returned values will not include this prefix. +runDirFileGlob + :: Verbosity + -> Maybe CabalSpecVersion + -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version. + -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'! + -> FilePath + -> Glob + -> IO [GlobResult FilePath] +runDirFileGlob verbosity mspec rawRoot pat = do + -- The default data-dir is null. Our callers -should- be + -- converting that to '.' themselves, but it's a certainty that + -- some future call-site will forget and trigger a really + -- hard-to-debug failure if we don't check for that here. + when (null rawRoot) $ + warn verbosity $ + "Null dir passed to runDirFileGlob; interpreting it " + ++ "as '.'. This is probably an internal error." + let root = if null rawRoot then "." else rawRoot + debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." + -- This function might be called from the project root with dir as + -- ".". Walking the tree starting there involves going into .git/ + -- and dist-newstyle/, which is a lot of work for no reward, so + -- extract the constant prefix from the pattern and start walking + -- there, and only walk as much as we need to: recursively if **, + -- the whole directory if *, and just the specific file if it's a + -- literal. + let + (prefixSegments, variablePattern) = splitConstantPrefix pat + joinedPrefix = joinPath prefixSegments + + -- The glob matching function depends on whether we care about the cabal version or not + doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ()) + doesGlobMatch glob str = case mspec of + Just spec -> checkNameMatches spec glob str + Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing + + go (GlobFile glob) dir = do + entries <- getDirectoryContents (root dir) + catMaybes + <$> mapM + ( \s -> do + -- When running a glob from a Cabal package description (i.e. + -- when a cabal spec version is passed as an argument), we + -- disallow matching a @GlobFile@ against a directory, preferring + -- @GlobDir dir GlobDirTrailing@ to specify a directory match. + isFile <- maybe (return True) (const $ doesFileExist (root dir s)) mspec + let match = (dir s <$) <$> doesGlobMatch glob s + return $ + if isFile + then match + else case match of + Just (GlobMatch x) -> Just $ GlobMatchesDirectory x + Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x + Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x + Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess + Nothing -> Nothing + ) + entries + go (GlobDirRecursive glob) dir = do + entries <- getDirectoryContentsRecursive (root dir) + return $ + mapMaybe + ( \s -> do + globMatch <- doesGlobMatch glob (takeFileName s) + pure ((dir s) <$ globMatch) + ) + entries + go (GlobDir glob globPath) dir = do + entries <- getDirectoryContents (root dir) + subdirs <- + filterM + ( \subdir -> + doesDirectoryExist + (root dir subdir) + ) + $ filter (matchGlobPieces glob) entries + concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs + go GlobDirTrailing dir = return [GlobMatch dir] + + directoryExists <- doesDirectoryExist (root joinedPrefix) + if directoryExists + then go variablePattern joinedPrefix + else return [GlobMissingDirectory joinedPrefix] + where + -- \| Extract the (possibly null) constant prefix from the pattern. + -- This has the property that, if @(pref, final) = splitConstantPrefix pat@, + -- then @pat === foldr GlobDir final pref@. + splitConstantPrefix :: Glob -> ([FilePath], Glob) + splitConstantPrefix = unfoldr' step + where + step (GlobDir [Literal seg] pat') = Right (seg, pat') + step pat' = Left pat' + + unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) + unfoldr' f a = case f a of + Left r -> ([], r) + Right (b, a') -> case unfoldr' f a' of + (bs, r) -> (b : bs, r) + +-- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ? +isRecursiveInRoot :: Glob -> Bool +isRecursiveInRoot (GlobDirRecursive _) = True +isRecursiveInRoot _ = False + +-- | Check how the string matches the glob under this cabal version +checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ()) +checkNameMatches spec glob candidate + -- Check if glob matches in its general form + | matchGlobPieces glob candidate = + -- if multidot is supported, then this is a clean match + if enableMultidot spec + then pure (GlobMatch ()) + else -- if not, issue a warning saying multidot is needed for the match + + let (_, candidateExts) = splitExtensions $ takeFileName candidate + extractExts :: GlobPieces -> Maybe String + extractExts [] = Nothing + extractExts [Literal lit] + -- Any literal terminating a glob, and which does have an extension, + -- returns that extension. Otherwise, recurse until Nothing is returned. + | let ext = takeExtensions lit + , ext /= "" = + Just ext + extractExts (_ : x) = extractExts x + in case extractExts glob of + Just exts + | exts == candidateExts -> + return (GlobMatch ()) + | exts `isSuffixOf` candidateExts -> + return (GlobWarnMultiDot ()) + _ -> return (GlobMatch ()) + | otherwise = empty + +-- | How/does the glob match the given filepath, according to the cabal version? +-- Since this is pure, we don't make a distinction between matching on +-- directories or files (i.e. this function won't return 'GlobMatchesDirectory') +fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ()) +fileGlobMatches version g path = go g (splitDirectories path) + where + go GlobDirTrailing [] = Just (GlobMatch ()) + go (GlobFile glob) [file] = checkNameMatches version glob file + go (GlobDirRecursive glob) dirs + | [] <- reverse dirs = + Nothing -- @dir/**/x.txt@ should not match @dir/hello@ + | file : _ <- reverse dirs = + checkNameMatches version glob file + go (GlobDir glob globPath) (dir : dirs) = do + _ <- checkNameMatches version glob dir -- we only care if dir segment matches + go globPath dirs + go _ _ = Nothing diff --git a/Cabal/src/Distribution/Simple/Glob/Internal.hs b/Cabal/src/Distribution/Simple/Glob/Internal.hs index 4f0b91eca39..13661cf97d5 100644 --- a/Cabal/src/Distribution/Simple/Glob/Internal.hs +++ b/Cabal/src/Distribution/Simple/Glob/Internal.hs @@ -20,20 +20,9 @@ module Distribution.Simple.Glob.Internal where import Distribution.Compat.Prelude import Prelude () -import Control.Monad (mapM) - +import qualified Distribution.Compat.CharParsing as P import Distribution.Parsec import Distribution.Pretty - -import Distribution.CabalSpecVersion -import Distribution.Simple.Utils -import Distribution.Verbosity hiding (normal) - -import Data.List (stripPrefix) -import System.Directory -import System.FilePath - -import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp -------------------------------------------------------------------------------- @@ -70,116 +59,8 @@ data GlobPiece instance Binary GlobPiece instance Structured GlobPiece -------------------------------------------------------------------------------- - --- * Matching - --------------------------------------------------------------------------------- - --- | Match a 'Glob' against the file system, starting from a --- given root directory. The results are all relative to the given root. --- --- @since 3.12.0.0 -matchGlob :: FilePath -> Glob -> IO [FilePath] -matchGlob root glob = - -- For this function, which is the general globbing one (doesn't care about - -- cabal spec, used e.g. for monitoring), we consider all matches. - mapMaybe - ( \case - GlobMatch a -> Just a - GlobWarnMultiDot a -> Just a - GlobMatchesDirectory a -> Just a - GlobMissingDirectory{} -> Nothing - ) - <$> runDirFileGlob silent Nothing root glob - --- | Match a globbing pattern against a file path component -matchGlobPieces :: GlobPieces -> String -> Bool -matchGlobPieces = goStart - where - -- From the man page, glob(7): - -- "If a filename starts with a '.', this character must be - -- matched explicitly." - - go, goStart :: [GlobPiece] -> String -> Bool - - goStart (WildCard : _) ('.' : _) = False - goStart (Union globs : rest) cs = - any - (\glob -> goStart (glob ++ rest) cs) - globs - goStart rest cs = go rest cs - - go [] "" = True - go (Literal lit : rest) cs - | Just cs' <- stripPrefix lit cs = - go rest cs' - | otherwise = False - go [WildCard] "" = True - go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs - go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs - go [] (_ : _) = False - go (_ : _) "" = False - -------------------------------------------------------------------------------- - --- * Parsing & printing - -------------------------------------------------------------------------------- --- Filepaths with globs may be parsed in the special context is globbing in --- cabal package fields, such as `data-files`. In that case, we restrict the --- globbing syntax to that supported by the cabal spec version in use. --- Otherwise, we parse the globs to the extent of our globbing features --- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`). - --- ** Parsing globs in a cabal package - -parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob -parseFileGlob version filepath = case reverse (splitDirectories filepath) of - [] -> - Left EmptyGlob - (filename : "**" : segments) - | allowGlobStar -> do - finalSegment <- case splitExtensions filename of - ("*", ext) - | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext]) - _ - | allowLiteralFilenameGlobStar -> - Right (GlobDirRecursive [Literal filename]) - | otherwise -> - Left LiteralFileNameGlobStar - - foldM addStem finalSegment segments - | otherwise -> Left VersionDoesNotSupportGlobStar - (filename : segments) -> do - pat <- case splitExtensions filename of - ("*", ext) - | not allowGlob -> Left VersionDoesNotSupportGlob - | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right (GlobFile [WildCard, Literal ext]) - (_, ext) - | '*' `elem` ext -> Left StarInExtension - | '*' `elem` filename -> Left StarInFileName - | otherwise -> Right (GlobFile [Literal filename]) - - foldM addStem pat segments - where - addStem pat seg - | '*' `elem` seg = Left StarInDirectory - | otherwise = Right (GlobDir [Literal seg] pat) - allowGlob = version >= CabalSpecV1_6 - allowGlobStar = version >= CabalSpecV2_4 - allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 - -enableMultidot :: CabalSpecVersion -> Bool -enableMultidot version - | version >= CabalSpecV2_4 = True - | otherwise = False - --- ** Parsing globs otherwise +-- Parsing & pretty-printing instance Pretty Glob where pretty (GlobDir glob pathglob) = @@ -226,10 +107,6 @@ instance Parsec Glob where normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar --------------------------------------------------------------------------------- --- Parse and printing utils --------------------------------------------------------------------------------- - dispGlobPieces :: GlobPieces -> Disp.Doc dispGlobPieces = Disp.hcat . map dispPiece where @@ -254,244 +131,3 @@ isGlobEscapedChar '{' = True isGlobEscapedChar '}' = True isGlobEscapedChar ',' = True isGlobEscapedChar _ = False - --- ** Cabal package globbing errors - -data GlobSyntaxError - = StarInDirectory - | StarInFileName - | StarInExtension - | NoExtensionOnStar - | EmptyGlob - | LiteralFileNameGlobStar - | VersionDoesNotSupportGlobStar - | VersionDoesNotSupportGlob - deriving (Eq, Show) - -explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String -explainGlobSyntaxError filepath StarInDirectory = - "invalid file glob '" - ++ filepath - ++ "'. A wildcard '**' is only allowed as the final parent" - ++ " directory. Stars must not otherwise appear in the parent" - ++ " directories." -explainGlobSyntaxError filepath StarInExtension = - "invalid file glob '" - ++ filepath - ++ "'. Wildcards '*' are only allowed as the" - ++ " file's base name, not in the file extension." -explainGlobSyntaxError filepath StarInFileName = - "invalid file glob '" - ++ filepath - ++ "'. Wildcards '*' may only totally replace the" - ++ " file's base name, not only parts of it." -explainGlobSyntaxError filepath NoExtensionOnStar = - "invalid file glob '" - ++ filepath - ++ "'. If a wildcard '*' is used it must be with an file extension." -explainGlobSyntaxError filepath LiteralFileNameGlobStar = - "invalid file glob '" - ++ filepath - ++ "'. Prior to 'cabal-version: 3.8'" - ++ " if a wildcard '**' is used as a parent directory, the" - ++ " file's base name must be a wildcard '*'." -explainGlobSyntaxError _ EmptyGlob = - "invalid file glob. A glob cannot be the empty string." -explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = - "invalid file glob '" - ++ filepath - ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" - ++ " or greater. Alternatively, for compatibility with earlier Cabal" - ++ " versions, list the included directories explicitly." -explainGlobSyntaxError filepath VersionDoesNotSupportGlob = - "invalid file glob '" - ++ filepath - ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " - ++ "Alternatively if you require compatibility with earlier Cabal " - ++ "versions then list all the files explicitly." - --- Note throughout that we use splitDirectories, not splitPath. On --- Posix, this makes no difference, but, because Windows accepts both --- slash and backslash as its path separators, if we left in the --- separators from the glob we might not end up properly normalised. - -data GlobResult a - = -- | The glob matched the value supplied. - GlobMatch a - | -- | The glob did not match the value supplied because the - -- cabal-version is too low and the extensions on the file did - -- not precisely match the glob's extensions, but rather the - -- glob was a proper suffix of the file's extensions; i.e., if - -- not for the low cabal-version, it would have matched. - GlobWarnMultiDot a - | -- | The glob couldn't match because the directory named doesn't - -- exist. The directory will be as it appears in the glob (i.e., - -- relative to the directory passed to 'matchDirFileGlob', and, - -- for 'data-files', relative to 'data-dir'). - GlobMissingDirectory a - | -- | The glob matched a directory when we were looking for files only. - -- It didn't match a file! - -- - -- @since 3.12.0.0 - GlobMatchesDirectory a - deriving (Show, Eq, Ord, Functor) - --- | Match files against a pre-parsed glob, starting in a directory. --- --- The 'Version' argument must be the spec version of the package --- description being processed, as globs behave slightly differently --- in different spec versions. --- --- The 'FilePath' argument is the directory that the glob is relative --- to. It must be a valid directory (and hence it can't be the empty --- string). The returned values will not include this prefix. -runDirFileGlob - :: Verbosity - -> Maybe CabalSpecVersion - -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version. - -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'! - -> FilePath - -> Glob - -> IO [GlobResult FilePath] -runDirFileGlob verbosity mspec rawRoot pat = do - -- The default data-dir is null. Our callers -should- be - -- converting that to '.' themselves, but it's a certainty that - -- some future call-site will forget and trigger a really - -- hard-to-debug failure if we don't check for that here. - when (null rawRoot) $ - warn verbosity $ - "Null dir passed to runDirFileGlob; interpreting it " - ++ "as '.'. This is probably an internal error." - let root = if null rawRoot then "." else rawRoot - debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." - -- This function might be called from the project root with dir as - -- ".". Walking the tree starting there involves going into .git/ - -- and dist-newstyle/, which is a lot of work for no reward, so - -- extract the constant prefix from the pattern and start walking - -- there, and only walk as much as we need to: recursively if **, - -- the whole directory if *, and just the specific file if it's a - -- literal. - let - (prefixSegments, variablePattern) = splitConstantPrefix pat - joinedPrefix = joinPath prefixSegments - - -- The glob matching function depends on whether we care about the cabal version or not - doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ()) - doesGlobMatch glob str = case mspec of - Just spec -> checkNameMatches spec glob str - Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing - - go (GlobFile glob) dir = do - entries <- getDirectoryContents (root dir) - catMaybes - <$> mapM - ( \s -> do - -- When running a glob from a Cabal package description (i.e. - -- when a cabal spec version is passed as an argument), we - -- disallow matching a @GlobFile@ against a directory, preferring - -- @GlobDir dir GlobDirTrailing@ to specify a directory match. - isFile <- maybe (return True) (const $ doesFileExist (root dir s)) mspec - let match = (dir s <$) <$> doesGlobMatch glob s - return $ - if isFile - then match - else case match of - Just (GlobMatch x) -> Just $ GlobMatchesDirectory x - Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x - Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x - Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess - Nothing -> Nothing - ) - entries - go (GlobDirRecursive glob) dir = do - entries <- getDirectoryContentsRecursive (root dir) - return $ - mapMaybe - ( \s -> do - globMatch <- doesGlobMatch glob (takeFileName s) - pure ((dir s) <$ globMatch) - ) - entries - go (GlobDir glob globPath) dir = do - entries <- getDirectoryContents (root dir) - subdirs <- - filterM - ( \subdir -> - doesDirectoryExist - (root dir subdir) - ) - $ filter (matchGlobPieces glob) entries - concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs - go GlobDirTrailing dir = return [GlobMatch dir] - - directoryExists <- doesDirectoryExist (root joinedPrefix) - if directoryExists - then go variablePattern joinedPrefix - else return [GlobMissingDirectory joinedPrefix] - where - -- \| Extract the (possibly null) constant prefix from the pattern. - -- This has the property that, if @(pref, final) = splitConstantPrefix pat@, - -- then @pat === foldr GlobDir final pref@. - splitConstantPrefix :: Glob -> ([FilePath], Glob) - splitConstantPrefix = unfoldr' step - where - step (GlobDir [Literal seg] pat') = Right (seg, pat') - step pat' = Left pat' - - unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) - unfoldr' f a = case f a of - Left r -> ([], r) - Right (b, a') -> case unfoldr' f a' of - (bs, r) -> (b : bs, r) - --- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ? -isRecursiveInRoot :: Glob -> Bool -isRecursiveInRoot (GlobDirRecursive _) = True -isRecursiveInRoot _ = False - --- | Check how the string matches the glob under this cabal version -checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ()) -checkNameMatches spec glob candidate - -- Check if glob matches in its general form - | matchGlobPieces glob candidate = - -- if multidot is supported, then this is a clean match - if enableMultidot spec - then pure (GlobMatch ()) - else -- if not, issue a warning saying multidot is needed for the match - - let (_, candidateExts) = splitExtensions $ takeFileName candidate - extractExts :: GlobPieces -> Maybe String - extractExts [] = Nothing - extractExts [Literal lit] - -- Any literal terminating a glob, and which does have an extension, - -- returns that extension. Otherwise, recurse until Nothing is returned. - | let ext = takeExtensions lit - , ext /= "" = - Just ext - extractExts (_ : x) = extractExts x - in case extractExts glob of - Just exts - | exts == candidateExts -> - return (GlobMatch ()) - | exts `isSuffixOf` candidateExts -> - return (GlobWarnMultiDot ()) - _ -> return (GlobMatch ()) - | otherwise = empty - --- | How/does the glob match the given filepath, according to the cabal version? --- Since this is pure, we don't make a distinction between matching on --- directories or files (i.e. this function won't return 'GlobMatchesDirectory') -fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ()) -fileGlobMatches version g path = go g (splitDirectories path) - where - go GlobDirTrailing [] = Just (GlobMatch ()) - go (GlobFile glob) [file] = checkNameMatches version glob file - go (GlobDirRecursive glob) dirs - | [] <- reverse dirs = - Nothing -- @dir/**/x.txt@ should not match @dir/hello@ - | file : _ <- reverse dirs = - checkNameMatches version glob file - go (GlobDir glob globPath) (dir : dirs) = do - _ <- checkNameMatches version glob dir -- we only care if dir segment matches - go globPath dirs - go _ _ = Nothing diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs index a63b9195b67..3b801fd7b34 100644 --- a/Cabal/src/Distribution/Simple/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Haddock.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -24,8 +25,10 @@ -- source, with coloured syntax highlighting. module Distribution.Simple.Haddock ( haddock + , haddock_setupHooks , createHaddockIndex , hscolour + , hscolour_setupHooks , haddockPackagePaths , Visibility (..) ) where @@ -67,6 +70,13 @@ import Distribution.Simple.Register import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Haddock import Distribution.Simple.Setup.Hscolour +import Distribution.Simple.SetupHooks.Internal + ( BuildHooks (..) + , BuildingWhat (..) + , noBuildHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentLocalBuildInfo @@ -218,212 +228,251 @@ haddock -> [PPSuffixHandler] -> HaddockFlags -> IO () -haddock pkg_descr _ _ haddockFlags - | not (hasLibs pkg_descr) - && not (fromFlag $ haddockExecutables haddockFlags) - && not (fromFlag $ haddockTestSuites haddockFlags) - && not (fromFlag $ haddockBenchmarks haddockFlags) - && not (fromFlag $ haddockForeignLibs haddockFlags) = - warn (fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ - "No documentation was generated as this package does not contain " - ++ "a library. Perhaps you want to use the --executables, --tests," - ++ " --benchmarks or --foreign-libraries flags." -haddock pkg_descr lbi suffixes flags' = do - let verbosity = fromFlag $ haddockVerbosity flags - mbWorkDir = flagToMaybe $ haddockWorkingDir flags - comp = compiler lbi - platform = hostPlatform lbi - - quickJmpFlag = haddockQuickJump flags' - flags = case haddockTarget of - ForDevelopment -> flags' - ForHackage -> - flags' - { haddockHoogle = Flag True - , haddockHtml = Flag True - , haddockHtmlLocation = Flag (pkg_url ++ "/docs") - , haddockContents = Flag (toPathTemplate pkg_url) - , haddockLinkedSource = Flag True - , haddockQuickJump = Flag True +haddock = haddock_setupHooks noBuildHooks + +haddock_setupHooks + :: BuildHooks + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () +haddock_setupHooks + _ + pkg_descr + _ + _ + haddockFlags + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) + && not (fromFlag $ haddockTestSuites haddockFlags) + && not (fromFlag $ haddockBenchmarks haddockFlags) + && not (fromFlag $ haddockForeignLibs haddockFlags) = + warn (fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ + "No documentation was generated as this package does not contain " + ++ "a library. Perhaps you want to use the --executables, --tests," + ++ " --benchmarks or --foreign-libraries flags." +haddock_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules}) + pkg_descr + lbi + suffixes + flags' = do + let verbosity = fromFlag $ haddockVerbosity flags + mbWorkDir = flagToMaybe $ haddockWorkingDir flags + comp = compiler lbi + platform = hostPlatform lbi + + quickJmpFlag = haddockQuickJump flags' + flags = case haddockTarget of + ForDevelopment -> flags' + ForHackage -> + flags' + { haddockHoogle = Flag True + , haddockHtml = Flag True + , haddockHtmlLocation = Flag (pkg_url ++ "/docs") + , haddockContents = Flag (toPathTemplate pkg_url) + , haddockLinkedSource = Flag True + , haddockQuickJump = Flag True + } + pkg_url = "/package/$pkg-$version" + flag f = fromFlag $ f flags + + tmpFileOpts = + defaultTempFileOptions + { optKeepTempFiles = flag haddockKeepTempFiles } - pkg_url = "/package/$pkg-$version" - flag f = fromFlag $ f flags + htmlTemplate = + fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ + flags + haddockTarget = + fromFlagOrDefault ForDevelopment (haddockForHackage flags') + + libdirArgs <- getGhcLibDir verbosity lbi + -- The haddock-output-dir flag overrides any other documentation placement concerns. + -- The point is to give the user full freedom over the location if they need it. + let overrideWithOutputDir args = case haddockOutputDir flags of + NoFlag -> args + Flag dir -> args{argOutputDir = Dir dir} + let commonArgs = + overrideWithOutputDir $ + mconcat + [ libdirArgs + , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags + , fromPackageDescription haddockTarget pkg_descr + ] - tmpFileOpts = - defaultTempFileOptions - { optKeepTempFiles = flag haddockKeepTempFiles - } - htmlTemplate = - fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ - flags - haddockTarget = - fromFlagOrDefault ForDevelopment (haddockForHackage flags') - - libdirArgs <- getGhcLibDir verbosity lbi - -- The haddock-output-dir flag overrides any other documentation placement concerns. - -- The point is to give the user full freedom over the location if they need it. - let overrideWithOutputDir args = case haddockOutputDir flags of - NoFlag -> args - Flag dir -> args{argOutputDir = Dir dir} - let commonArgs = - overrideWithOutputDir $ - mconcat - [ libdirArgs - , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags - , fromPackageDescription haddockTarget pkg_descr - ] - - (haddockProg, version) <- - getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag - - -- We fall back to using HsColour only for versions of Haddock which don't - -- support '--hyperlinked-sources'. - let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] - when using_hscolour $ - hscolour' - (warn verbosity) - haddockTarget - pkg_descr - lbi - suffixes - (defaultHscolourFlags `mappend` haddockToHscolour flags) + (haddockProg, version) <- + getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag + + -- We fall back to using HsColour only for versions of Haddock which don't + -- support '--hyperlinked-sources'. + let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] + when using_hscolour $ + hscolour' + noBuildHooks + -- NB: we are not passing the user BuildHooks here, + -- because we are already running the pre/post build hooks + -- for Haddock. + (warn verbosity) + haddockTarget + pkg_descr + lbi + suffixes + (defaultHscolourFlags `mappend` haddockToHscolour flags) - targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags) + targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags) - let - targets' = - case targets of - [] -> allTargetsInBuildOrder' pkg_descr lbi - _ -> targets + let + targets' = + case targets of + [] -> allTargetsInBuildOrder' pkg_descr lbi + _ -> targets - internalPackageDB <- - createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags) + internalPackageDB <- + createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags) - (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do - let component = targetComponent target + (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do + let + component = targetComponent target clbi = targetCLBI target - preBuildComponent verbosity lbi target - - let - lbi' = - lbi - { withPackageDB = withPackageDB lbi ++ [internalPackageDB] - , installedPkgs = index - } + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildHaddock flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + preBuildComponent runPreBuildHooks verbosity lbi target + + let + lbi' = + lbi + { withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } - preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi') "tmp" $ + preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi') "tmp" $ + \tmp -> do + exeArgs <- + fromExecutable + verbosity + tmp + lbi' + clbi + htmlTemplate + version + exe + let exeArgs' = commonArgs `mappend` exeArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + exeArgs' + Nothing -> do + warn + verbosity + "Unsupported component, skipping..." + return () + -- We define 'smsg' once and then reuse it inside the case, so that + -- we don't say we are running Haddock when we actually aren't + -- (e.g., Haddock is not run on non-libraries) + smsg :: IO () + smsg = + setupMessage' + verbosity + "Running Haddock on" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + ipi <- case component of + CLib lib -> do + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi) "tmp" $ \tmp -> do - exeArgs <- - fromExecutable + smsg + libArgs <- + fromLibrary verbosity tmp lbi' clbi htmlTemplate version - exe - let exeArgs' = commonArgs `mappend` exeArgs - runHaddock + lib + let libArgs' = commonArgs `mappend` libArgs + runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg True libArgs' + inplaceDir <- absoluteWorkingDirLBI lbi + + let + ipi = + inplaceInstalledPackageInfo + inplaceDir + (flag $ setupDistPref . haddockCommonFlags) + pkg_descr + (mkAbiHash "inplace") + lib + lbi' + clbi + + debug verbosity $ + "Registering inplace:\n" + ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + + registerPackage verbosity + (compiler lbi') + (withPrograms lbi') mbWorkDir - tmpFileOpts - comp - platform - haddockProg - True - exeArgs' - Nothing -> do - warn - verbosity - "Unsupported component, skipping..." - -- We define 'smsg' once and then reuse it inside the case, so that - -- we don't say we are running Haddock when we actually aren't - -- (e.g., Haddock is not run on non-libraries) - smsg :: IO () - smsg = - setupMessage' - verbosity - "Running Haddock on" - (packageId pkg_descr) - (componentLocalName clbi) - (maybeComponentInstantiatedWith clbi) - case component of - CLib lib -> do - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi) "tmp" $ - \tmp -> do - smsg - libArgs <- - fromLibrary - verbosity - tmp - lbi' - clbi - htmlTemplate - version - lib - let libArgs' = commonArgs `mappend` libArgs - runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg True libArgs' - inplaceDir <- absoluteWorkingDirLBI lbi - let - ipi = - inplaceInstalledPackageInfo - inplaceDir - (flag $ setupDistPref . haddockCommonFlags) - pkg_descr - (mkAbiHash "inplace") - lib - lbi' - clbi - - debug verbosity $ - "Registering inplace:\n" - ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + (withPackageDB lbi') + ipi + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + + return $ PackageIndex.insert ipi index + CFLib flib -> + when + (flag haddockForeignLibs) + ( do + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi') "tmp" $ + \tmp -> do + smsg + flibArgs <- + fromForeignLib + verbosity + tmp + lbi' + clbi + htmlTemplate + version + flib + let libArgs' = commonArgs `mappend` flibArgs + runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg True libArgs' + ) + >> return index + CExe _ -> when (flag haddockExecutables) (smsg >> doExe component) >> return index + CTest _ -> when (flag haddockTestSuites) (smsg >> doExe component) >> return index + CBench _ -> when (flag haddockBenchmarks) (smsg >> doExe component) >> return index - registerPackage - verbosity - (compiler lbi') - (withPrograms lbi') - mbWorkDir - (withPackageDB lbi') - ipi - HcPkg.defaultRegisterOptions - { HcPkg.registerMultiInstance = True - } - - return $ PackageIndex.insert ipi index - CFLib flib -> - when - (flag haddockForeignLibs) - ( do - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi') "tmp" $ - \tmp -> do - smsg - flibArgs <- - fromForeignLib - verbosity - tmp - lbi' - clbi - htmlTemplate - version - flib - let libArgs' = commonArgs `mappend` flibArgs - runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg True libArgs' - ) - >> return index - CExe _ -> when (flag haddockExecutables) (smsg >> doExe component) >> return index - CTest _ -> when (flag haddockTestSuites) (smsg >> doExe component) >> return index - CBench _ -> when (flag haddockBenchmarks) (smsg >> doExe component) >> return index + return ipi - for_ (extraDocFiles pkg_descr) $ \fpath -> do - files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath - for_ files $ - copyFileToCwd verbosity mbWorkDir (unDir $ argOutputDir commonArgs) + for_ (extraDocFiles pkg_descr) $ \fpath -> do + files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath + for_ files $ + copyFileToCwd verbosity mbWorkDir (unDir $ argOutputDir commonArgs) -- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build -- index and contents for documentation of multiple packages. @@ -1131,10 +1180,21 @@ hscolour -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour = hscolour' dieNoVerbosity ForDevelopment +hscolour = hscolour_setupHooks noBuildHooks + +hscolour_setupHooks + :: BuildHooks + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour_setupHooks setupHooks = + hscolour' setupHooks dieNoVerbosity ForDevelopment hscolour' - :: (String -> IO ()) + :: BuildHooks + -> (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. -> HaddockTarget -> PackageDescription @@ -1142,93 +1202,113 @@ hscolour' -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = - either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg) - =<< lookupProgramVersion - verbosity - hscolourProgram - (orLaterVersion (mkVersion [1, 8])) - (withPrograms lbi) - where - common = hscolourCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - distPref = fromFlag $ setupDistPref common - mbWorkDir = mbWorkDirLBI lbi - i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path - u :: SymbolicPath Pkg to -> FilePath - u = interpretSymbolicPathCWD - go :: ConfiguredProgram -> IO () - go hscolourProg = do - warn verbosity $ - "the 'cabal hscolour' command is deprecated in favour of 'cabal " - ++ "haddock --hyperlink-source' and will be removed in the next major " - ++ "release." - - setupMessage verbosity "Running hscolour for" (packageId pkg_descr) - createDirectoryIfMissingVerbose verbosity True $ - i $ - hscolourPref haddockTarget distPref pkg_descr - - withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do - let tgt = TargetInfo clbi comp - preBuildComponent verbosity lbi tgt - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do +hscolour' + (BuildHooks{preBuildComponentRules = mbPbcRules}) + onNoHsColour + haddockTarget + pkg_descr + lbi + suffixes + flags = + either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg) + =<< lookupProgramVersion + verbosity + hscolourProgram + (orLaterVersion (mkVersion [1, 8])) + (withPrograms lbi) + where + common = hscolourCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + distPref = fromFlag $ setupDistPref common + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + + go :: ConfiguredProgram -> IO () + go hscolourProg = do + warn verbosity $ + "the 'cabal hscolour' command is deprecated in favour of 'cabal " + ++ "haddock --hyperlink-source' and will be removed in the next major " + ++ "release." + + setupMessage verbosity "Running hscolour for" (packageId pkg_descr) + createDirectoryIfMissingVerbose verbosity True $ + i $ + hscolourPref haddockTarget distPref pkg_descr + + withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do + let tgt = TargetInfo clbi comp + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 target = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildHscolour flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = target + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + preBuildComponent runPreBuildHooks verbosity lbi tgt + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + let outputDir = + hscolourPref haddockTarget distPref pkg_descr + makeRelativePathEx (unUnqualComponentName (exeName exe) "src") + runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi + Nothing -> do + warn verbosity "Unsupported component, skipping..." + return () + case comp of + CLib lib -> do + let outputDir = hscolourPref haddockTarget distPref pkg_descr makeRelativePathEx "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi + CFLib flib -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr - makeRelativePathEx (unUnqualComponentName (exeName exe) "src") - runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi - Nothing -> do - warn verbosity "Unsupported component, skipping..." - case comp of - CLib lib -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr makeRelativePathEx "src" - runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi - CFLib flib -> do - let outputDir = - hscolourPref haddockTarget distPref pkg_descr - makeRelativePathEx - ( unUnqualComponentName (foreignLibName flib) - "src" - ) - runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi - CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp - CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp - CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp - - stylesheet = flagToMaybe (hscolourCSS flags) - - runHsColour - :: ConfiguredProgram - -> SymbolicPath Pkg to - -> [(ModuleName.ModuleName, SymbolicPath Pkg to1)] - -> IO () - runHsColour prog outputDir moduleFiles = do - createDirectoryIfMissingVerbose verbosity True (i outputDir) - - case stylesheet of -- copy the CSS file - Nothing - | programVersion prog >= Just (mkVersion [1, 9]) -> - runProgramCwd - verbosity - mbWorkDir - prog - ["-print-css", "-o" ++ u outputDir "hscolour.css"] - | otherwise -> return () - Just s -> copyFileVerbose verbosity s (i outputDir "hscolour.css") - - for_ moduleFiles $ \(m, inFile) -> - runProgramCwd - verbosity - mbWorkDir - prog - ["-css", "-anchor", "-o" ++ outFile m, u inFile] - where - outFile m = - i outputDir - intercalate "-" (ModuleName.components m) <.> "html" + makeRelativePathEx + ( unUnqualComponentName (foreignLibName flib) + "src" + ) + runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi + CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp + CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp + CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + + stylesheet = flagToMaybe (hscolourCSS flags) + + runHsColour + :: ConfiguredProgram + -> SymbolicPath Pkg to + -> [(ModuleName.ModuleName, SymbolicPath Pkg to1)] + -> IO () + runHsColour prog outputDir moduleFiles = do + createDirectoryIfMissingVerbose verbosity True (i outputDir) + + case stylesheet of -- copy the CSS file + Nothing + | programVersion prog >= Just (mkVersion [1, 9]) -> + runProgramCwd + verbosity + mbWorkDir + prog + ["-print-css", "-o" ++ u outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (i outputDir "hscolour.css") + + for_ moduleFiles $ \(m, inFile) -> + runProgramCwd + verbosity + mbWorkDir + prog + ["-css", "-anchor", "-o" ++ outFile m, u inFile] + where + outFile m = + i outputDir + intercalate "-" (ModuleName.components m) <.> "html" haddockToHscolour :: HaddockFlags -> HscolourFlags haddockToHscolour flags = diff --git a/Cabal/src/Distribution/Simple/Install.hs b/Cabal/src/Distribution/Simple/Install.hs index eb72a73fa53..c1134e2b355 100644 --- a/Cabal/src/Distribution/Simple/Install.hs +++ b/Cabal/src/Distribution/Simple/Install.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -18,11 +20,15 @@ -- compiler-specific functions to do the rest. module Distribution.Simple.Install ( install + , install_setupHooks + , installFileGlob ) where import Distribution.Compat.Prelude import Prelude () +import Distribution.CabalSpecVersion (CabalSpecVersion) + import Distribution.Types.ExecutableScope import Distribution.Types.ForeignLib import Distribution.Types.LocalBuildInfo @@ -47,6 +53,10 @@ import Distribution.Simple.Setup.Copy import Distribution.Simple.Setup.Haddock ( HaddockTarget (ForDevelopment) ) +import Distribution.Simple.SetupHooks.Internal + ( InstallHooks (..) + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose , dieWithException @@ -95,26 +105,49 @@ install -> CopyFlags -- ^ flags sent to copy or install -> IO () -install pkg_descr lbi flags = do - checkHasLibsOrExes - targets <- readTargetInfos verbosity pkg_descr lbi (copyTargets flags) +install = install_setupHooks SetupHooks.noInstallHooks + +install_setupHooks + :: InstallHooks + -> PackageDescription + -- ^ information from the .cabal file + -> LocalBuildInfo + -- ^ information from the configure step + -> CopyFlags + -- ^ flags sent to copy or install + -> IO () +install_setupHooks + (InstallHooks{installComponentHook}) + pkg_descr + lbi + flags = do + checkHasLibsOrExes + targets <- readTargetInfos verbosity pkg_descr lbi (copyTargets flags) - copyPackage verbosity pkg_descr lbi distPref copydest + copyPackage verbosity pkg_descr lbi distPref copydest - -- It's not necessary to do these in build-order, but it's harmless - withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> - let comp = targetComponent target - clbi = targetCLBI target - in copyComponent verbosity pkg_descr lbi comp clbi copydest - where - common = copyCommonFlags flags - distPref = fromFlag $ setupDistPref common - verbosity = fromFlag $ setupVerbosity common - copydest = fromFlag (copyDest flags) + -- It's not necessary to do these in build-order, but it's harmless + withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> do + let comp = targetComponent target + clbi = targetCLBI target + copyComponent verbosity pkg_descr lbi comp clbi copydest + for_ installComponentHook $ \instAction -> + let inputs = + SetupHooks.InstallComponentInputs + { copyFlags = flags + , localBuildInfo = lbi + , targetInfo = target + } + in instAction inputs + where + common = copyCommonFlags flags + distPref = fromFlag $ setupDistPref common + verbosity = fromFlag $ setupVerbosity common + copydest = fromFlag (copyDest flags) - checkHasLibsOrExes = - unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ - dieWithException verbosity NoLibraryFound + checkHasLibsOrExes = + unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ + dieWithException verbosity NoLibraryFound -- | Copy package global files. copyPackage @@ -290,23 +323,37 @@ installDataFiles -> SymbolicPath Pkg (Dir DataDir) -> IO () installDataFiles verbosity mbWorkDir pkg_descr destDataDir = - flip traverse_ (dataFiles pkg_descr) $ \glob -> do - let srcDataDirRaw = getSymbolicPath $ dataDir pkg_descr - srcDataDir :: Maybe (SymbolicPath CWD (Dir DataDir)) - srcDataDir - | null srcDataDirRaw = - Nothing - | isAbsoluteOnAnyPlatform srcDataDirRaw = - Just $ makeSymbolicPath srcDataDirRaw - | otherwise = - Just $ fromMaybe sameDirectory mbWorkDir makeRelativePathEx srcDataDirRaw - i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path - files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir glob - for_ files $ \file' -> do - let src = i (dataDir pkg_descr file') - dst = i (destDataDir file') - createDirectoryIfMissingVerbose verbosity True (takeDirectory dst) - installOrdinaryFile verbosity src dst + traverse_ + (installFileGlob verbosity (specVersion pkg_descr) mbWorkDir (srcDataDir, destDataDir)) + (dataFiles pkg_descr) + where + srcDataDirRaw = getSymbolicPath $ dataDir pkg_descr + srcDataDir :: Maybe (SymbolicPath CWD (Dir DataDir)) + srcDataDir + | null srcDataDirRaw = + Nothing + | isAbsoluteOnAnyPlatform srcDataDirRaw = + Just $ makeSymbolicPath srcDataDirRaw + | otherwise = + Just $ fromMaybe sameDirectory mbWorkDir makeRelativePathEx srcDataDirRaw + +-- | Install the files specified by the given glob pattern. +installFileGlob + :: Verbosity + -> CabalSpecVersion + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> (Maybe (SymbolicPath CWD (Dir DataDir)), SymbolicPath Pkg (Dir DataDir)) + -- ^ @(src_dir, dest_dir)@ + -> RelativePath DataDir File + -- ^ file glob pattern + -> IO () +installFileGlob verbosity spec_version mbWorkDir (srcDir, destDir) glob = do + files <- matchDirFileGlob verbosity spec_version srcDir glob + for_ files $ \file' -> do + let src = getSymbolicPath (fromMaybe sameDirectory srcDir file') + dst = interpretSymbolicPath mbWorkDir (destDir file') + createDirectoryIfMissingVerbose verbosity True (takeDirectory dst) + installOrdinaryFile verbosity src dst -- | Install the files listed in install-includes for a library installIncludeFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs index 160b81fd4de..00e6e68cb5c 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/Cabal/src/Distribution/Simple/PreProcess.hs @@ -24,6 +24,7 @@ module Distribution.Simple.PreProcess ( preprocessComponent , preprocessExtras + , preprocessFile , knownSuffixHandlers , ppSuffixes , PPSuffixHandler @@ -297,7 +298,10 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS case psrcFiles of -- no preprocessor file exists, look for an ordinary source file -- just to make sure one actually exists at all for this module. - -- Note: by looking in the target/output build dir too, we allow + + -- Note [Dodgy build dirs for preprocessors] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- By looking in the target/output build dir too, we allow -- source files to appear magically in the target build dir without -- any corresponding "real" source file. This lets custom Setup.hs -- files generate source modules directly into the build dir without diff --git a/Cabal/src/Distribution/Simple/PreProcess/Types.hs b/Cabal/src/Distribution/Simple/PreProcess/Types.hs index 5315d3b1ac7..5b865349e78 100644 --- a/Cabal/src/Distribution/Simple/PreProcess/Types.hs +++ b/Cabal/src/Distribution/Simple/PreProcess/Types.hs @@ -19,6 +19,7 @@ module Distribution.Simple.PreProcess.Types ( Suffix (..) , PreProcessor (..) + , PreProcessCommand , builtinHaskellSuffixes , builtinHaskellBootSuffixes ) @@ -90,12 +91,22 @@ data PreProcessor = PreProcessor -- -- @since 3.8.1.0 , runPreProcessor - :: (FilePath, FilePath) -- Location of the source file relative to a base dir - -> (FilePath, FilePath) -- Output file name, relative to an output base dir - -> Verbosity -- verbosity - -> IO () -- Should exit if the preprocessor fails + :: PreProcessCommand } +-- | A command to run a given preprocessor on a single source file. +-- +-- The input and output file paths are passed in as arguments, as it is +-- the build system and not the package author which chooses the location of +-- source files. +type PreProcessCommand = + (FilePath, FilePath) + -- ^ Location of the source file relative to a base dir + -> (FilePath, FilePath) + -- ^ Output file name, relative to an output base dir + -> Verbosity + -> IO () -- Should exit if the preprocessor fails + -- | A suffix (or file extension). -- -- Mostly used to decide which preprocessor to use, e.g. files with suffix @"y"@ diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index a5e4e4ab381..1dda83a6b4e 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -26,7 +26,7 @@ -- don't have to write all the PATH logic inside Setup.lhs. module Distribution.Simple.Program.Db ( -- * The collection of configured programs we can run - ProgramDb + ProgramDb (..) , emptyProgramDb , defaultProgramDb , restoreProgramDb @@ -53,6 +53,7 @@ module Distribution.Simple.Program.Db -- ** Query and manipulate the program db , configureProgram + , configureUnconfiguredProgram , configureAllKnownPrograms , unconfigureProgram , lookupProgramVersion @@ -60,6 +61,12 @@ module Distribution.Simple.Program.Db , requireProgram , requireProgramVersion , needProgram + + -- * Internal functions + , UnconfiguredProgs + , ConfiguredProgs + , updateUnconfiguredProgs + , updateConfiguredProgs ) where import Distribution.Compat.Prelude @@ -338,10 +345,12 @@ configuredPrograms = Map.elems . configuredProgs -- --------------------------- -- Configuring known programs --- | Try to configure a specific program. If the program is already included in --- the collection of unconfigured programs then we use any user-supplied --- location and arguments. If the program gets configured successfully it gets --- added to the configured collection. +-- | Try to configure a specific program and add it to the program database. +-- +-- If the program is already included in the collection of unconfigured programs, +-- then we use any user-supplied location and arguments. +-- If the program gets configured successfully, it gets added to the configured +-- collection. -- -- Note that it is not a failure if the program cannot be configured. It's only -- a failure if the user supplied a location and the program could not be found @@ -357,6 +366,25 @@ configureProgram -> ProgramDb -> IO ProgramDb configureProgram verbosity prog progdb = do + mbConfiguredProg <- configureUnconfiguredProgram verbosity prog progdb + case mbConfiguredProg of + Nothing -> return progdb + Just configuredProg -> do + let progdb' = + updateConfiguredProgs + (Map.insert (programName prog) configuredProg) + progdb + return progdb' + +-- | Try to configure a specific program. If the program is already included in +-- the collection of unconfigured programs then we use any user-supplied +-- location and arguments. +configureUnconfiguredProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (Maybe ConfiguredProgram) +configureUnconfiguredProgram verbosity prog progdb = do let name = programName prog maybeLocation <- case userSpecifiedPath prog progdb of Nothing -> @@ -372,7 +400,7 @@ configureProgram verbosity prog progdb = do (dieWithException verbosity $ ConfigureProgram name path) (return . Just . swap . fmap UserSpecified . swap) case maybeLocation of - Nothing -> return progdb + Nothing -> return Nothing Just (location, triedLocations) -> do version <- programFindVersion prog verbosity (locationPath location) newPath <- programSearchPathAsPATHVar (progSearchPath progdb) @@ -388,7 +416,7 @@ configureProgram verbosity prog progdb = do , programMonitorFiles = triedLocations } configuredProg' <- programPostConf prog verbosity configuredProg - return (updateConfiguredProgs (Map.insert name configuredProg') progdb) + return $ Just configuredProg' -- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. configurePrograms diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs index 861cf16095c..dfde4466b30 100644 --- a/Cabal/src/Distribution/Simple/Setup.hs +++ b/Cabal/src/Distribution/Simple/Setup.hs @@ -141,8 +141,8 @@ module Distribution.Simple.Setup , buildingWhatDistPref ) where -import GHC.Generics (Generic) -import Prelude (Maybe, Show, (.)) +import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Flag import Distribution.Simple.InstallDirs @@ -172,7 +172,7 @@ import Distribution.Utils.Path import Distribution.Verbosity (Verbosity) --- | What kind of build are we doing? +-- | What kind of build phase are we doing/hooking into? -- -- Is this a normal build, or is it perhaps for running an interactive -- session or Haddock? @@ -246,3 +246,6 @@ buildingWhatDistPref = fromFlag . setupDistPref . buildingWhatCommonFlags * quickCheck to test permutations of arguments * what other options can we over-ride with a command-line flag? -} + +instance Binary BuildingWhat +instance Structured BuildingWhat diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs new file mode 100644 index 00000000000..11577f3506b --- /dev/null +++ b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- + +-- Module : Distribution.Simple.SetupHooks.Errors +-- Copyright : +-- License : +-- +-- Maintainer : +-- Portability : +-- +-- Exceptions for the Hooks build-type. + +module Distribution.Simple.SetupHooks.Errors + ( SetupHooksException (..) + , CannotApplyComponentDiffReason (..) + , IllegalComponentDiffReason (..) + , RulesException (..) + , setupHooksExceptionCode + , setupHooksExceptionMessage + , showLocs + ) where + +import Distribution.PackageDescription +import Distribution.Simple.SetupHooks.Rule +import qualified Distribution.Simple.SetupHooks.Rule as Rule +import Distribution.Types.Component + +import qualified Data.Graph as Graph +import Data.List + ( intercalate + ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Tree as Tree + +import System.FilePath (normalise, ()) + +-------------------------------------------------------------------------------- + +-- | An error involving the @SetupHooks@ module of a package with +-- Hooks build-type. +data SetupHooksException + = -- | Cannot apply a diff to a component in a per-component configure hook. + CannotApplyComponentDiff CannotApplyComponentDiffReason + | -- | An error with pre-build rules. + RulesException RulesException + deriving (Show) + +-- | AN error involving the @Rules@ in the @SetupHooks@ module of a +-- package with the Hooks build-type. +data RulesException + = -- | There are cycles in the dependency graph of fine-grained rules. + CyclicRuleDependencies + (NE.NonEmpty (RuleBinary, [Graph.Tree RuleBinary])) + | -- | When executing fine-grained rules compiled into the external hooks + -- executable, we failed to find dependencies of a rule. + CantFindSourceForRuleDependencies + RuleBinary + (NE.NonEmpty Rule.Location) + -- ^ missing dependencies + | -- | When executing fine-grained rules compiled into the external hooks + -- executable, a rule failed to generate the outputs it claimed it would. + MissingRuleOutputs + RuleBinary + (NE.NonEmpty Rule.Location) + -- ^ missing outputs + | -- | An invalid reference to a rule output, e.g. an out-of-range + -- index. + InvalidRuleOutputIndex + RuleId + -- ^ rule + RuleId + -- ^ dependency + (NE.NonEmpty Rule.Location) + -- ^ outputs of dependency + Word + -- ^ the invalid index + | -- | A duplicate 'RuleId' in the construction of pre-build rules. + DuplicateRuleId !RuleId !Rule !Rule + +deriving instance Show RulesException + +data CannotApplyComponentDiffReason + = MismatchedComponentTypes Component Component + | IllegalComponentDiff Component (NE.NonEmpty IllegalComponentDiffReason) + deriving (Show) + +data IllegalComponentDiffReason + = CannotChangeName + | CannotChangeComponentField String + | CannotChangeBuildInfoField String + deriving (Show) + +setupHooksExceptionCode :: SetupHooksException -> Int +setupHooksExceptionCode = \case + CannotApplyComponentDiff rea -> + cannotApplyComponentDiffCode rea + RulesException rea -> + rulesExceptionCode rea + +rulesExceptionCode :: RulesException -> Int +rulesExceptionCode = \case + CyclicRuleDependencies{} -> 9077 + CantFindSourceForRuleDependencies{} -> 1071 + MissingRuleOutputs{} -> 3498 + InvalidRuleOutputIndex{} -> 1173 + DuplicateRuleId{} -> 7717 + +setupHooksExceptionMessage :: SetupHooksException -> String +setupHooksExceptionMessage = \case + CannotApplyComponentDiff reason -> + cannotApplyComponentDiffMessage reason + RulesException reason -> + rulesExceptionMessage reason + +rulesExceptionMessage :: RulesException -> String +rulesExceptionMessage = \case + CyclicRuleDependencies cycles -> + unlines $ + ("Hooks: cycle" ++ plural ++ " in dependency structure of rules:") + : map showCycle (NE.toList cycles) + where + plural :: String + plural + | NE.length cycles >= 2 = + "s" + | otherwise = + "" + showCycle :: (RuleBinary, [Graph.Tree RuleBinary]) -> String + showCycle (r, rs) = + unlines . map (" " ++) . lines $ + Tree.drawTree $ + fmap showRule $ + Tree.Node r rs + CantFindSourceForRuleDependencies _r deps -> + unlines $ + ("Pre-build rules: can't find source for rule " ++ what ++ ":") + : map (\d -> " - " <> locPath d) depsL + where + depsL = NE.toList deps + what + | length depsL == 1 = + "dependency" + | otherwise = + "dependencies" + MissingRuleOutputs _r reslts -> + unlines $ + ("Pre-build rule did not generate expected result" <> plural <> ":") + : map (\res -> " - " <> locPath res) resultsL + where + resultsL = NE.toList reslts + plural + | length resultsL == 1 = + "" + | otherwise = + "s" + InvalidRuleOutputIndex rId depRuleId outputs i -> unlines [header, body] + where + header = "Invalid index '" ++ show i ++ "' in dependency of " ++ show rId ++ "." + nbOutputs = NE.length outputs + body + | (fromIntegral i :: Int) >= 0 = + unwords + [ "The dependency" + , show depRuleId + , "only has" + , show nbOutputs + , "output" ++ plural ++ "." + ] + | otherwise = + "The index is too large." + plural = if nbOutputs == 1 then "" else "s" + DuplicateRuleId rId r1 r2 -> + unlines $ + [ "Duplicate pre-build rule (" <> show rId <> ")" + , " - " <> showRule (ruleBinary r1) + , " - " <> showRule (ruleBinary r2) + ] + where + showRule :: RuleBinary -> String + showRule (Rule{staticDependencies = deps, results = reslts}) = + "Rule: " ++ showDeps deps ++ " --> " ++ showLocs (NE.toList reslts) + +locPath :: Location -> String +locPath (base, fp) = normalise $ base fp + +showLocs :: [Location] -> String +showLocs locs = "[" ++ intercalate ", " (map locPath locs) ++ "]" + +showDeps :: [Rule.Dependency] -> String +showDeps deps = "[" ++ intercalate ", " (map showDep deps) ++ "]" + +showDep :: Rule.Dependency -> String +showDep = \case + RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) -> + "(" ++ show rId ++ ")[" ++ show i ++ "]" + FileDependency loc -> locPath loc + +cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int +cannotApplyComponentDiffCode = \case + MismatchedComponentTypes{} -> 9491 + IllegalComponentDiff{} -> 7634 + +cannotApplyComponentDiffMessage :: CannotApplyComponentDiffReason -> String +cannotApplyComponentDiffMessage = \case + MismatchedComponentTypes comp diff -> + unlines + [ "Hooks: mismatched component types in per-component configure hook." + , "Trying to apply " ++ what ++ " diff to " ++ to ++ "." + ] + where + what = case diff of + CLib{} -> "a library" + CFLib{} -> "a foreign library" + CExe{} -> "an executable" + CTest{} -> "a testsuite" + CBench{} -> "a benchmark" + to = case componentName comp of + nm@(CExeName{}) -> "an " ++ showComponentName nm + nm -> "a " ++ showComponentName nm + IllegalComponentDiff comp reasons -> + unlines $ + ("Hooks: illegal component diff in per-component pre-configure hook for " ++ what ++ ":") + : map mk_rea (NE.toList reasons) + where + mk_rea err = " - " ++ illegalComponentDiffMessage err ++ "." + what = case componentName comp of + CLibName LMainLibName -> "main library" + nm -> showComponentName nm + +illegalComponentDiffMessage :: IllegalComponentDiffReason -> String +illegalComponentDiffMessage = \case + CannotChangeName -> + "cannot change the name of a component" + CannotChangeComponentField fld -> + "cannot change component field '" ++ fld ++ "'" + CannotChangeBuildInfoField fld -> + "cannot change BuildInfo field '" ++ fld ++ "'" diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs new file mode 100644 index 00000000000..25e2f39b1ad --- /dev/null +++ b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs @@ -0,0 +1,1090 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module: Distribution.Simple.SetupHooks.Internal +-- +-- Internal implementation module. +-- Users of @build-type: Hooks@ should import "Distribution.Simple.SetupHooks" +-- instead. +module Distribution.Simple.SetupHooks.Internal + ( -- * The setup hooks datatype + SetupHooks (..) + , noSetupHooks + + -- * Configure hooks + , ConfigureHooks (..) + , noConfigureHooks + + -- ** Per-package configure hooks + , PreConfPackageInputs (..) + , PreConfPackageOutputs (..) + , noPreConfPackageOutputs + , PreConfPackageHook + , PostConfPackageInputs (..) + , PostConfPackageHook + + -- ** Per-component configure hooks + , PreConfComponentInputs (..) + , PreConfComponentOutputs (..) + , noPreConfComponentOutputs + , PreConfComponentHook + , ComponentDiff (..) + , emptyComponentDiff + , buildInfoComponentDiff + , LibraryDiff + , ForeignLibDiff + , ExecutableDiff + , TestSuiteDiff + , BenchmarkDiff + , BuildInfoDiff + + -- * Build hooks + , BuildHooks (..) + , noBuildHooks + , BuildingWhat (..) + , buildingWhatVerbosity + , buildingWhatWorkingDir + , buildingWhatDistPref + + -- ** Pre-build rules + , PreBuildComponentInputs (..) + , PreBuildComponentRules + + -- ** Post-build hook + , PostBuildComponentInputs (..) + , PostBuildComponentHook + + -- * Install hooks + , InstallHooks (..) + , noInstallHooks + , InstallComponentInputs (..) + , InstallComponentHook + + -- * Internals + + -- ** Per-component hook utilities + , applyComponentDiffs + , forComponents_ + + -- ** Executing build rules + , executeRules + + -- ** HookedBuildInfo compatibility code + , hookedBuildInfoComponents + , hookedBuildInfoComponentDiff_maybe + ) +where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Lens ((.~)) +import Distribution.ModuleName +import Distribution.PackageDescription +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler (Compiler (..)) +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.Db +import Distribution.Simple.Setup + ( BuildingWhat (..) + , buildingWhatDistPref + , buildingWhatVerbosity + , buildingWhatWorkingDir + ) +import Distribution.Simple.Setup.Build (BuildFlags (..)) +import Distribution.Simple.Setup.Config (ConfigFlags (..)) +import Distribution.Simple.Setup.Copy (CopyFlags (..)) +import Distribution.Simple.SetupHooks.Errors +import Distribution.Simple.SetupHooks.Rule +import qualified Distribution.Simple.SetupHooks.Rule as Rule +import Distribution.Simple.Utils +import Distribution.System (Platform (..)) +import Distribution.Utils.Path (getSymbolicPath) + +import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo) +import Distribution.Types.LocalBuildConfig as LBC +import Distribution.Types.TargetInfo +import Distribution.Verbosity + +import qualified Data.ByteString.Lazy as LBS +import Data.Coerce (coerce) +import qualified Data.Graph as Graph +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import qualified Data.Set as Set + +import System.Directory (doesFileExist) +import System.FilePath (normalise, (<.>), ()) + +-------------------------------------------------------------------------------- +-- SetupHooks + +-- | Hooks into the @cabal@ build phases. +-- +-- Usage: +-- +-- - In your @.cabal@ file, declare @build-type: Hooks@ +-- (with a @cabal-version@ greater than or equal to @3.14@), +-- - In your @.cabal@ file, include a @custom-setup@ stanza +-- which declares the dependencies of your @SetupHooks@ module; +-- this will usually contain a dependency on the @Cabal-hooks@ package. +-- - Provide a @SetupHooks.hs@ module next to your @.cabal@ file; +-- it must export @setupHooks :: SetupHooks@. +data SetupHooks = SetupHooks + { configureHooks :: ConfigureHooks + -- ^ Hooks into the configure phase. + , buildHooks :: BuildHooks + -- ^ Hooks into the build phase. + -- + -- These hooks are relevant to any build-like phase, + -- such as repl or haddock. + , installHooks :: InstallHooks + -- ^ Hooks into the copy/install phase. + } + +-- | 'SetupHooks' can be combined monoidally. This is useful to combine +-- setup hooks defined by another package with your own package-specific +-- hooks. +-- +-- __Warning__: this 'Semigroup' instance is not commutative. +instance Semigroup SetupHooks where + SetupHooks + { configureHooks = conf1 + , buildHooks = build1 + , installHooks = inst1 + } + <> SetupHooks + { configureHooks = conf2 + , buildHooks = build2 + , installHooks = inst2 + } = + SetupHooks + { configureHooks = conf1 <> conf2 + , buildHooks = build1 <> build2 + , installHooks = inst1 <> inst2 + } + +instance Monoid SetupHooks where + mempty = noSetupHooks + +-- | Empty hooks. +noSetupHooks :: SetupHooks +noSetupHooks = + SetupHooks + { configureHooks = noConfigureHooks + , buildHooks = noBuildHooks + , installHooks = noInstallHooks + } + +-------------------------------------------------------------------------------- +-- Configure hooks. + +type PreConfPackageHook = PreConfPackageInputs -> IO PreConfPackageOutputs + +-- | Inputs to the package-wide pre-configure step. +data PreConfPackageInputs = PreConfPackageInputs + { configFlags :: ConfigFlags + , localBuildConfig :: LocalBuildConfig + -- ^ Warning: the 'ProgramDb' in the 'withPrograms' field + -- will not contain any unconfigured programs. + , compiler :: Compiler + , platform :: Platform + } + deriving (Generic, Show) + +-- | Outputs of the package-wide pre-configure step. +-- +-- Prefer using 'noPreConfPackageOutputs' and overriding the fields +-- you care about, to avoid depending on implementation details +-- of this datatype. +data PreConfPackageOutputs = PreConfPackageOutputs + { buildOptions :: BuildOptions + , extraConfiguredProgs :: ConfiguredProgs + } + deriving (Generic, Show) + +-- | Use this smart constructor to declare an empty set of changes +-- by the package-wide pre-configure hook, and override the fields you +-- care about. +-- +-- Use this rather than v'PreConfPackageOutputs' to avoid relying on +-- internal implementation details of the latter. +noPreConfPackageOutputs :: PreConfPackageInputs -> PreConfPackageOutputs +noPreConfPackageOutputs (PreConfPackageInputs{localBuildConfig = lbc}) = + PreConfPackageOutputs + { buildOptions = LBC.withBuildOptions lbc + , extraConfiguredProgs = Map.empty + } + +-- | Package-wide post-configure step. +-- +-- Perform side effects. Last opportunity for any package-wide logic; +-- any subsequent hooks work per-component. +type PostConfPackageHook = PostConfPackageInputs -> IO () + +-- | Inputs to the package-wide post-configure step. +data PostConfPackageInputs = PostConfPackageInputs + { localBuildConfig :: LocalBuildConfig + , packageBuildDescr :: PackageBuildDescr + } + deriving (Generic, Show) + +-- | Per-component pre-configure step. +-- +-- For each component of the package, this hook can perform side effects, +-- and return a diff to the passed in component, e.g. to declare additional +-- autogenerated modules. +type PreConfComponentHook = PreConfComponentInputs -> IO PreConfComponentOutputs + +-- | Inputs to the per-component pre-configure step. +data PreConfComponentInputs = PreConfComponentInputs + { localBuildConfig :: LocalBuildConfig + , packageBuildDescr :: PackageBuildDescr + , component :: Component + } + deriving (Generic, Show) + +-- | Outputs of the per-component pre-configure step. +-- +-- Prefer using 'noPreComponentOutputs' and overriding the fields +-- you care about, to avoid depending on implementation details +-- of this datatype. +data PreConfComponentOutputs = PreConfComponentOutputs + { componentDiff :: ComponentDiff + } + deriving (Generic, Show) + +-- | Use this smart constructor to declare an empty set of changes +-- by a per-component pre-configure hook, and override the fields you +-- care about. +-- +-- Use this rather than v'PreConfComponentOutputs' to avoid relying on +-- internal implementation details of the latter. +noPreConfComponentOutputs :: PreConfComponentInputs -> PreConfComponentOutputs +noPreConfComponentOutputs (PreConfComponentInputs{component = comp}) = + PreConfComponentOutputs + { componentDiff = emptyComponentDiff (componentName comp) + } + +-- | Configure-time hooks. +-- +-- Order of execution: +-- +-- - 'preConfPackageHook', +-- - configure the package, +-- - 'postConfPackageHook', +-- - 'preConfComponentHook', +-- - configure the components. +data ConfigureHooks = ConfigureHooks + { preConfPackageHook :: Maybe PreConfPackageHook + -- ^ Package-wide pre-configure hook. See 'PreConfPackageHook'. + , postConfPackageHook :: Maybe PostConfPackageHook + -- ^ Package-wide post-configure hook. See 'PostConfPackageHook'. + , preConfComponentHook :: Maybe PreConfComponentHook + -- ^ Per-component pre-configure hook. See 'PreConfComponentHook'. + } + +-- Note: these configure hooks don't track any kind of dependency information, +-- so we won't know when the configuration is out of date and should be re-done. +-- This seems okay: it should only matter while developing the package, in which +-- case it seems acceptable to rely on the user re-configuring. + +instance Semigroup ConfigureHooks where + ConfigureHooks + { preConfPackageHook = prePkg1 + , postConfPackageHook = postPkg1 + , preConfComponentHook = preComp1 + } + <> ConfigureHooks + { preConfPackageHook = prePkg2 + , postConfPackageHook = postPkg2 + , preConfComponentHook = preComp2 + } = + ConfigureHooks + { preConfPackageHook = + coerce + ((<>) @(Maybe PreConfPkgSemigroup)) + prePkg1 + prePkg2 + , postConfPackageHook = + postPkg1 <> postPkg2 + , preConfComponentHook = + coerce + ((<>) @(Maybe PreConfComponentSemigroup)) + preComp1 + preComp2 + } + +instance Monoid ConfigureHooks where + mempty = noConfigureHooks + +-- | Empty configure phase hooks. +noConfigureHooks :: ConfigureHooks +noConfigureHooks = + ConfigureHooks + { preConfPackageHook = Nothing + , postConfPackageHook = Nothing + , preConfComponentHook = Nothing + } + +-- | A newtype to hang off the @Semigroup PreConfPackageHook@ instance. +newtype PreConfPkgSemigroup = PreConfPkgSemigroup PreConfPackageHook + +instance Semigroup PreConfPkgSemigroup where + PreConfPkgSemigroup f1 <> PreConfPkgSemigroup f2 = + PreConfPkgSemigroup $ + \inputs@( PreConfPackageInputs + { configFlags = cfg + , compiler = comp + , platform = plat + , localBuildConfig = lbc0 + } + ) -> + do + PreConfPackageOutputs + { buildOptions = opts1 + , extraConfiguredProgs = progs1 + } <- + f1 inputs + PreConfPackageOutputs + { buildOptions = opts2 + , extraConfiguredProgs = progs2 + } <- + f2 $ + PreConfPackageInputs + { configFlags = cfg + , compiler = comp + , platform = plat + , localBuildConfig = + lbc0 + { LBC.withPrograms = + updateConfiguredProgs (`Map.union` progs1) $ + LBC.withPrograms lbc0 + , LBC.withBuildOptions = opts1 + } + } + return $ + PreConfPackageOutputs + { buildOptions = opts2 + , extraConfiguredProgs = progs1 <> progs2 + } + +-- | A newtype to hang off the @Semigroup PreConfComponentHook@ instance. +newtype PreConfComponentSemigroup = PreConfComponentSemigroup PreConfComponentHook + +instance Semigroup PreConfComponentSemigroup where + PreConfComponentSemigroup f1 <> PreConfComponentSemigroup f2 = + PreConfComponentSemigroup $ \inputs -> + do + PreConfComponentOutputs + { componentDiff = diff1 + } <- + f1 inputs + PreConfComponentOutputs + { componentDiff = diff2 + } <- + f2 inputs + return $ + PreConfComponentOutputs + { componentDiff = diff1 <> diff2 + } + +-------------------------------------------------------------------------------- +-- Build setup hooks. + +data PreBuildComponentInputs = PreBuildComponentInputs + { buildingWhat :: BuildingWhat + -- ^ what kind of build phase are we hooking into? + , localBuildInfo :: LocalBuildInfo + -- ^ information about the package + , targetInfo :: TargetInfo + -- ^ information about an individual component + } + deriving (Generic, Show) + +type PreBuildComponentRules = Rules PreBuildComponentInputs + +data PostBuildComponentInputs = PostBuildComponentInputs + { buildFlags :: BuildFlags + , localBuildInfo :: LocalBuildInfo + , targetInfo :: TargetInfo + } + deriving (Generic, Show) + +type PostBuildComponentHook = PostBuildComponentInputs -> IO () + +-- | Build-time hooks. +data BuildHooks = BuildHooks + { preBuildComponentRules :: Maybe PreBuildComponentRules + -- ^ Per-component fine-grained pre-build rules. + , postBuildComponentHook :: Maybe PostBuildComponentHook + -- ^ Per-component post-build hook. + } + +-- Note that the pre-build hook consists of a function which takes a component +-- as an argument (as part of the targetInfo field) and returns a collection of +-- pre-build rules. +-- +-- One might wonder why it isn't instead a collection of pre-build rules, one +-- for each component. The reason is that Backpack creates components on-the-fly +-- through instantiation, which means e.g. that a single component name can +-- resolve to multiple components. This means we really need to pass in the +-- components to the function, as we don't know the full details (e.g. their +-- unit ids) ahead of time. + +instance Semigroup BuildHooks where + BuildHooks + { preBuildComponentRules = rs1 + , postBuildComponentHook = post1 + } + <> BuildHooks + { preBuildComponentRules = rs2 + , postBuildComponentHook = post2 + } = + BuildHooks + { preBuildComponentRules = rs1 <> rs2 + , postBuildComponentHook = post1 <> post2 + } + +instance Monoid BuildHooks where + mempty = noBuildHooks + +-- | Empty build hooks. +noBuildHooks :: BuildHooks +noBuildHooks = + BuildHooks + { preBuildComponentRules = Nothing + , postBuildComponentHook = Nothing + } + +-------------------------------------------------------------------------------- +-- Install setup hooks. + +data InstallComponentInputs = InstallComponentInputs + { copyFlags :: CopyFlags + , localBuildInfo :: LocalBuildInfo + , targetInfo :: TargetInfo + } + deriving (Generic, Show) + +-- | A per-component install hook, +-- which can only perform side effects (e.g. copying files). +type InstallComponentHook = InstallComponentInputs -> IO () + +-- | Copy/install hooks. +data InstallHooks = InstallHooks + { installComponentHook :: Maybe InstallComponentHook + -- ^ Per-component install hook. + } + +instance Semigroup InstallHooks where + InstallHooks + { installComponentHook = inst1 + } + <> InstallHooks + { installComponentHook = inst2 + } = + InstallHooks + { installComponentHook = inst1 <> inst2 + } + +instance Monoid InstallHooks where + mempty = noInstallHooks + +-- | Empty copy/install hooks. +noInstallHooks :: InstallHooks +noInstallHooks = + InstallHooks + { installComponentHook = Nothing + } + +-------------------------------------------------------------------------------- +-- Per-component configure hook implementation details. + +type LibraryDiff = Library +type ForeignLibDiff = ForeignLib +type ExecutableDiff = Executable +type TestSuiteDiff = TestSuite +type BenchmarkDiff = Benchmark +type BuildInfoDiff = BuildInfo + +-- | A diff to a Cabal 'Component', that gets combined monoidally into +-- an existing 'Component'. +newtype ComponentDiff = ComponentDiff {componentDiff :: Component} + deriving (Semigroup, Show) + +emptyComponentDiff :: ComponentName -> ComponentDiff +emptyComponentDiff name = ComponentDiff $ + case name of + CLibName{} -> CLib emptyLibrary + CFLibName{} -> CFLib emptyForeignLib + CExeName{} -> CExe emptyExecutable + CTestName{} -> CTest emptyTestSuite + CBenchName{} -> CBench emptyBenchmark + +buildInfoComponentDiff :: ComponentName -> BuildInfo -> ComponentDiff +buildInfoComponentDiff name bi = ComponentDiff $ + BI.buildInfo .~ bi $ + case name of + CLibName{} -> CLib emptyLibrary + CFLibName{} -> CFLib emptyForeignLib + CExeName{} -> CExe emptyExecutable + CTestName{} -> CTest emptyTestSuite + CBenchName{} -> CBench emptyBenchmark + +applyLibraryDiff :: Verbosity -> Library -> LibraryDiff -> IO Library +applyLibraryDiff verbosity lib diff = + case illegalLibraryDiffReasons lib diff of + [] -> return $ lib <> diff + (r : rs) -> + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff $ + IllegalComponentDiff (CLib lib) (r NE.:| rs) + +illegalLibraryDiffReasons :: Library -> LibraryDiff -> [IllegalComponentDiffReason] +illegalLibraryDiffReasons + lib + Library + { libName = nm + , libExposed = e + , libVisibility = vis + , libBuildInfo = bi + } = + [ CannotChangeName + | not $ nm == libName emptyLibrary || nm == libName lib + ] + ++ [ CannotChangeComponentField "libExposed" + | not $ e == libExposed emptyLibrary || e == libExposed lib + ] + ++ [ CannotChangeComponentField "libVisibility" + | not $ vis == libVisibility emptyLibrary || vis == libVisibility lib + ] + ++ illegalBuildInfoDiffReasons (libBuildInfo lib) bi + +applyForeignLibDiff :: Verbosity -> ForeignLib -> ForeignLibDiff -> IO ForeignLib +applyForeignLibDiff verbosity flib diff = + case illegalForeignLibDiffReasons flib diff of + [] -> return $ flib <> diff + (r : rs) -> + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff $ + IllegalComponentDiff (CFLib flib) (r NE.:| rs) + +illegalForeignLibDiffReasons :: ForeignLib -> ForeignLibDiff -> [IllegalComponentDiffReason] +illegalForeignLibDiffReasons + flib + ForeignLib + { foreignLibName = nm + , foreignLibType = ty + , foreignLibOptions = opts + , foreignLibVersionInfo = vi + , foreignLibVersionLinux = linux + , foreignLibModDefFile = defs + , foreignLibBuildInfo = bi + } = + [ CannotChangeName + | not $ nm == foreignLibName emptyForeignLib || nm == foreignLibName flib + ] + ++ [ CannotChangeComponentField "foreignLibType" + | not $ ty == foreignLibType emptyForeignLib || ty == foreignLibType flib + ] + ++ [ CannotChangeComponentField "foreignLibOptions" + | not $ opts == foreignLibOptions emptyForeignLib || opts == foreignLibOptions flib + ] + ++ [ CannotChangeComponentField "foreignLibVersionInfo" + | not $ vi == foreignLibVersionInfo emptyForeignLib || vi == foreignLibVersionInfo flib + ] + ++ [ CannotChangeComponentField "foreignLibVersionLinux" + | not $ linux == foreignLibVersionLinux emptyForeignLib || linux == foreignLibVersionLinux flib + ] + ++ [ CannotChangeComponentField "foreignLibModDefFile" + | not $ defs == foreignLibModDefFile emptyForeignLib || defs == foreignLibModDefFile flib + ] + ++ illegalBuildInfoDiffReasons (foreignLibBuildInfo flib) bi + +applyExecutableDiff :: Verbosity -> Executable -> ExecutableDiff -> IO Executable +applyExecutableDiff verbosity exe diff = + case illegalExecutableDiffReasons exe diff of + [] -> return $ exe <> diff + (r : rs) -> + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff $ + IllegalComponentDiff (CExe exe) (r NE.:| rs) + +illegalExecutableDiffReasons :: Executable -> ExecutableDiff -> [IllegalComponentDiffReason] +illegalExecutableDiffReasons + exe + Executable + { exeName = nm + , modulePath = path + , exeScope = scope + , buildInfo = bi + } = + [ CannotChangeName + | not $ nm == exeName emptyExecutable || nm == exeName exe + ] + ++ [ CannotChangeComponentField "modulePath" + | not $ path == modulePath emptyExecutable || path == modulePath exe + ] + ++ [ CannotChangeComponentField "exeScope" + | not $ scope == exeScope emptyExecutable || scope == exeScope exe + ] + ++ illegalBuildInfoDiffReasons (buildInfo exe) bi + +applyTestSuiteDiff :: Verbosity -> TestSuite -> TestSuiteDiff -> IO TestSuite +applyTestSuiteDiff verbosity test diff = + case illegalTestSuiteDiffReasons test diff of + [] -> return $ test <> diff + (r : rs) -> + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff $ + IllegalComponentDiff (CTest test) (r NE.:| rs) + +illegalTestSuiteDiffReasons :: TestSuite -> TestSuiteDiff -> [IllegalComponentDiffReason] +illegalTestSuiteDiffReasons + test + TestSuite + { testName = nm + , testInterface = iface + , testCodeGenerators = gens + , testBuildInfo = bi + } = + [ CannotChangeName + | not $ nm == testName emptyTestSuite || nm == testName test + ] + ++ [ CannotChangeComponentField "testInterface" + | not $ iface == testInterface emptyTestSuite || iface == testInterface test + ] + ++ [ CannotChangeComponentField "testCodeGenerators" + | not $ gens == testCodeGenerators emptyTestSuite || gens == testCodeGenerators test + ] + ++ illegalBuildInfoDiffReasons (testBuildInfo test) bi + +applyBenchmarkDiff :: Verbosity -> Benchmark -> BenchmarkDiff -> IO Benchmark +applyBenchmarkDiff verbosity bench diff = + case illegalBenchmarkDiffReasons bench diff of + [] -> return $ bench <> diff + (r : rs) -> + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff $ + IllegalComponentDiff (CBench bench) (r NE.:| rs) + +illegalBenchmarkDiffReasons :: Benchmark -> BenchmarkDiff -> [IllegalComponentDiffReason] +illegalBenchmarkDiffReasons + bench + Benchmark + { benchmarkName = nm + , benchmarkInterface = iface + , benchmarkBuildInfo = bi + } = + [ CannotChangeName + | not $ nm == benchmarkName emptyBenchmark || nm == benchmarkName bench + ] + ++ [ CannotChangeComponentField "benchmarkInterface" + | not $ iface == benchmarkInterface emptyBenchmark || iface == benchmarkInterface bench + ] + ++ illegalBuildInfoDiffReasons (benchmarkBuildInfo bench) bi + +illegalBuildInfoDiffReasons :: BuildInfo -> BuildInfoDiff -> [IllegalComponentDiffReason] +illegalBuildInfoDiffReasons + bi + BuildInfo + { buildable = can_build + , buildTools = build_tools + , buildToolDepends = build_tools_depends + , pkgconfigDepends = pkgconfig_depends + , frameworks = fworks + , targetBuildDepends = target_build_depends + } = + map CannotChangeBuildInfoField $ + [ "buildable" + | not $ can_build == buildable bi || can_build == buildable emptyBuildInfo + ] + ++ [ "buildTools" + | not $ build_tools == buildTools bi || build_tools == buildTools emptyBuildInfo + ] + ++ [ "buildToolsDepends" + | not $ build_tools_depends == buildToolDepends bi || build_tools_depends == buildToolDepends emptyBuildInfo + ] + ++ [ "pkgconfigDepends" + | not $ pkgconfig_depends == pkgconfigDepends bi || pkgconfig_depends == pkgconfigDepends emptyBuildInfo + ] + ++ [ "frameworks" + | not $ fworks == frameworks bi || fworks == frameworks emptyBuildInfo + ] + ++ [ "targetBuildDepends" + | not $ target_build_depends == targetBuildDepends bi || target_build_depends == targetBuildDepends emptyBuildInfo + ] + +-- | Traverse the components of a 'PackageDescription'. +-- +-- The function must preserve the component type, i.e. map a 'CLib' to a 'CLib', +-- a 'CExe' to a 'CExe', etc. +traverseComponents + :: Applicative m + => (Component -> m Component) + -> PackageDescription + -> m PackageDescription +traverseComponents f pd = + upd_pd + <$> traverse f_lib (library pd) + <*> traverse f_lib (subLibraries pd) + <*> traverse f_flib (foreignLibs pd) + <*> traverse f_exe (executables pd) + <*> traverse f_test (testSuites pd) + <*> traverse f_bench (benchmarks pd) + where + f_lib lib = \case { CLib lib' -> lib'; c -> mismatch (CLib lib) c } <$> f (CLib lib) + f_flib flib = \case { CFLib flib' -> flib'; c -> mismatch (CFLib flib) c } <$> f (CFLib flib) + f_exe exe = \case { CExe exe' -> exe'; c -> mismatch (CExe exe) c } <$> f (CExe exe) + f_test test = \case { CTest test' -> test'; c -> mismatch (CTest test) c } <$> f (CTest test) + f_bench bench = \case { CBench bench' -> bench'; c -> mismatch (CBench bench) c } <$> f (CBench bench) + + upd_pd lib sublibs flibs exes tests benchs = + pd + { library = lib + , subLibraries = sublibs + , foreignLibs = flibs + , executables = exes + , testSuites = tests + , benchmarks = benchs + } + + -- This is a panic, because we maintain this invariant elsewhere: + -- see 'componentDiffError' in 'applyComponentDiff', which catches an + -- invalid per-component configure hook. + mismatch c1 c2 = + error $ + "Mismatched component types: " + ++ showComponentName (componentName c1) + ++ " " + ++ showComponentName (componentName c2) + ++ "." +{-# INLINEABLE traverseComponents #-} + +applyComponentDiffs + :: Verbosity + -> (Component -> IO (Maybe ComponentDiff)) + -> PackageDescription + -> IO PackageDescription +applyComponentDiffs verbosity f = traverseComponents apply_diff + where + apply_diff :: Component -> IO Component + apply_diff c = do + mbDiff <- f c + case mbDiff of + Just diff -> applyComponentDiff verbosity c diff + Nothing -> return c + +forComponents_ :: PackageDescription -> (Component -> IO ()) -> IO () +forComponents_ pd f = getConst $ traverseComponents (Const . f) pd + +applyComponentDiff + :: Verbosity + -> Component + -> ComponentDiff + -> IO Component +applyComponentDiff verbosity comp (ComponentDiff diff) + | CLib lib <- comp + , CLib lib_diff <- diff = + CLib <$> applyLibraryDiff verbosity lib lib_diff + | CFLib flib <- comp + , CFLib flib_diff <- diff = + CFLib <$> applyForeignLibDiff verbosity flib flib_diff + | CExe exe <- comp + , CExe exe_diff <- diff = + CExe <$> applyExecutableDiff verbosity exe exe_diff + | CTest test <- comp + , CTest test_diff <- diff = + CTest <$> applyTestSuiteDiff verbosity test test_diff + | CBench bench <- comp + , CBench bench_diff <- diff = + CBench <$> applyBenchmarkDiff verbosity bench bench_diff + | otherwise = + componentDiffError $ MismatchedComponentTypes comp diff + where + -- The per-component configure hook specified a diff of the wrong type, + -- e.g. tried to apply an executable diff to a library. + componentDiffError err = + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff err + +-------------------------------------------------------------------------------- +-- Running pre-build rules + +-- | Run all pre-build rules. +-- +-- This function should only be called internally within @Cabal@, as it is used +-- to implement the (legacy) Setup.hs interface. The build tool +-- (e.g. @cabal-install@ or @hls@) should instead go through the separate +-- hooks executable, which allows us to only rerun the out-of-date rules +-- (instead of running all of these rules at once). +executeRules + :: Verbosity + -> LocalBuildInfo + -> TargetInfo + -> Map RuleId Rule + -> IO () +executeRules = + executeRulesUserOrSystem + SUser + (\_rId cmd -> sequenceA $ runRuleDynDepsCmd cmd) + (\_rId cmd -> runRuleExecCmd cmd) + +-- | Like 'executeRules', except it can be used when communicating with +-- an external hooks executable. +executeRulesUserOrSystem + :: forall userOrSystem + . SScope userOrSystem + -> (RuleId -> RuleDynDepsCmd userOrSystem -> IO (Maybe ([Rule.Dependency], LBS.ByteString))) + -> (RuleId -> RuleExecCmd userOrSystem -> IO ()) + -> Verbosity + -> LocalBuildInfo + -> TargetInfo + -> Map RuleId (RuleData userOrSystem) + -> IO () +executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo allRules = do + -- Compute all extra dynamic dependency edges. + dynDepsEdges <- + flip Map.traverseMaybeWithKey allRules $ + \rId (Rule{ruleCommands = cmds}) -> + runDepsCmdData rId (ruleDepsCmd cmds) + + -- Create a build graph of all the rules, with static and dynamic dependencies + -- as edges. + let + (ruleGraph, ruleFromVertex, vertexFromRuleId) = + Graph.graphFromEdges + [ (rule, rId, nub $ mapMaybe directRuleDependencyMaybe allDeps) + | (rId, rule) <- Map.toList allRules + , let dynDeps = fromMaybe [] (fst <$> Map.lookup rId dynDepsEdges) + allDeps = staticDependencies rule ++ dynDeps + ] + + -- Topologically sort the graph of rules. + sccs = Graph.scc ruleGraph + cycles = mapMaybe $ \(Graph.Node v0 subforest) -> + case subforest of + [] + | r@(_, rId, deps) <- ruleFromVertex v0 -> + if rId `elem` deps + then Just (r, []) + else Nothing + v : vs -> + Just + ( ruleFromVertex v0 + , map (fmap ruleFromVertex) (v : vs) + ) + + -- Compute demanded rules. + -- + -- SetupHooks TODO: maybe requiring all generated modules to appear + -- in autogen-modules is excessive; we can look through all modules instead. + autogenModPaths = + map (\m -> toFilePath m <.> "hs") $ + autogenModules $ + componentBuildInfo $ + targetComponent tgtInfo + leafRule_maybe (rId, r) = + if any ((r `ruleOutputsLocation`) . (compAutogenDir,)) autogenModPaths + then vertexFromRuleId rId + else Nothing + leafRules = mapMaybe leafRule_maybe $ Map.toList allRules + demandedRuleVerts = Set.fromList $ concatMap (Graph.reachable ruleGraph) leafRules + nonDemandedRuleVerts = Set.fromList (Graph.vertices ruleGraph) Set.\\ demandedRuleVerts + + case cycles sccs of + -- If there are cycles in the dependency structure, don't execute + -- any rules at all; just throw an error right off the bat. + r : rs -> + let getRule ((ru, _, _), js) = (toRuleBinary ru, fmap (fmap (\(rv, _, _) -> toRuleBinary rv)) js) + in errorOut $ + CyclicRuleDependencies $ + fmap getRule (r NE.:| rs) + -- Otherwise, run all the demanded rules in dependency order (in one go). + -- (Fine-grained running of rules should happen in cabal-install or HLS, + -- not in the Cabal library.) + [] -> do + -- Emit a warning if there are non-demanded rules. + unless (null nonDemandedRuleVerts) $ + warn verbosity $ + unlines $ + "The following rules are not demanded and will not be run:" + : [ " - " ++ show rId ++ ", generating " ++ showLocs (NE.toList $ results r) + | v <- Set.toList nonDemandedRuleVerts + , let (r, rId, _) = ruleFromVertex v + ] + ++ [ "Possible reasons for this error:" + , " - Some autogenerated modules were not declared" + , " (in the package description or in the pre-configure hooks)" + , " - The output location for an autogenerated module is incorrect," + , " (e.g. it is not in the appropriate 'autogenComponentModules' directory)" + ] + + -- Run all the demanded rules, in dependency order. + for_ sccs $ \(Graph.Node ruleVertex _) -> + -- Don't run a rule unless it is demanded. + unless (ruleVertex `Set.member` nonDemandedRuleVerts) $ do + let ( r@Rule + { ruleCommands = cmds + , staticDependencies = staticDeps + , results = reslts + } + , rId + , _staticRuleDepIds + ) = + ruleFromVertex ruleVertex + mbDyn = Map.lookup rId dynDepsEdges + allDeps = staticDeps ++ fromMaybe [] (fst <$> mbDyn) + -- Check that the dependencies the rule expects are indeed present. + resolvedDeps <- traverse (resolveDependency verbosity rId allRules) allDeps + missingRuleDeps <- filterM missingDep resolvedDeps + case NE.nonEmpty missingRuleDeps of + Just missingDeps -> + errorOut $ CantFindSourceForRuleDependencies (toRuleBinary r) missingDeps + -- Dependencies OK: run the associated action. + Nothing -> do + let execCmd = ruleExecCmd scope cmds (snd <$> mbDyn) + runCmdData rId execCmd + -- Throw an error if running the action did not result in + -- the generation of outputs that we expected it to. + missingRuleResults <- filterM missingDep $ NE.toList reslts + for_ (NE.nonEmpty missingRuleResults) $ \missingResults -> + errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults + return () + where + toRuleBinary :: RuleData userOrSystem -> RuleBinary + toRuleBinary = case scope of + SUser -> ruleBinary + SSystem -> id + clbi = targetCLBI tgtInfo + compAutogenDir = getSymbolicPath $ autogenComponentModulesDir lbi clbi + errorOut e = + dieWithException verbosity $ + SetupHooksException $ + RulesException e + +directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId +directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep +directRuleDependencyMaybe (FileDependency{}) = Nothing + +resolveDependency :: Verbosity -> RuleId -> Map RuleId (RuleData scope) -> Rule.Dependency -> IO Location +resolveDependency verbosity rId allRules = \case + FileDependency l -> return l + RuleDependency (RuleOutput{outputOfRule = depId, outputIndex = i}) -> + case Map.lookup depId allRules of + Nothing -> + error $ + unlines $ + [ "Internal error: missing rule dependency." + , "Rule: " ++ show rId + , "Dependency: " ++ show depId + ] + Just (Rule{results = os}) -> + let j :: Int + j = fromIntegral i + in case listToMaybe $ drop j $ NE.toList os of + Just o + | j >= 0 -> + return o + _ -> + dieWithException verbosity $ + SetupHooksException $ + RulesException $ + InvalidRuleOutputIndex rId depId os i + +-- | Does the rule output the given location? +ruleOutputsLocation :: RuleData scope -> Location -> Bool +ruleOutputsLocation (Rule{results = rs}) fp = + any (\out -> normaliseLocation out == normaliseLocation fp) rs + +normaliseLocation :: Location -> Location +normaliseLocation (base, rel) = (normalise base, normalise rel) + +-- | Is the file we depend on missing? +missingDep :: Location -> IO Bool +missingDep (base, fp) = not <$> doesFileExist (base fp) + +-------------------------------------------------------------------------------- +-- Compatibility with HookedBuildInfo. +-- +-- NB: assumes that the components in HookedBuildInfo are: +-- - an (optional) main library, +-- - executables. +-- +-- No support for named sublibraries, foreign libraries, tests or benchmarks, +-- because the HookedBuildInfo datatype doesn't specify what type of component +-- each component name is (so we assume they are executables). + +hookedBuildInfoComponents :: HookedBuildInfo -> Set ComponentName +hookedBuildInfoComponents (mb_mainlib, exes) = + Set.fromList $ + (case mb_mainlib of Nothing -> id; Just{} -> (CLibName LMainLibName :)) + [CExeName exe_nm | (exe_nm, _) <- exes] + +hookedBuildInfoComponentDiff_maybe :: HookedBuildInfo -> ComponentName -> Maybe (IO ComponentDiff) +hookedBuildInfoComponentDiff_maybe (mb_mainlib, exes) comp_nm = + case comp_nm of + CLibName lib_nm -> + case lib_nm of + LMainLibName -> return . ComponentDiff . CLib . buildInfoLibraryDiff <$> mb_mainlib + LSubLibName{} -> Nothing + CExeName exe_nm -> + let mb_exe = lookup exe_nm exes + in return . ComponentDiff . CExe . buildInfoExecutableDiff <$> mb_exe + CFLibName{} -> Nothing + CTestName{} -> Nothing + CBenchName{} -> Nothing + +buildInfoLibraryDiff :: BuildInfo -> LibraryDiff +buildInfoLibraryDiff bi = emptyLibrary{libBuildInfo = bi} + +buildInfoExecutableDiff :: BuildInfo -> ExecutableDiff +buildInfoExecutableDiff bi = emptyExecutable{buildInfo = bi} + +-------------------------------------------------------------------------------- +-- Instances for serialisation + +deriving newtype instance Binary ComponentDiff +deriving newtype instance Structured ComponentDiff + +instance Binary PreConfPackageInputs +instance Structured PreConfPackageInputs +instance Binary PreConfPackageOutputs +instance Structured PreConfPackageOutputs + +instance Binary PostConfPackageInputs +instance Structured PostConfPackageInputs + +instance Binary PreConfComponentInputs +instance Structured PreConfComponentInputs +instance Binary PreConfComponentOutputs +instance Structured PreConfComponentOutputs + +instance Binary PreBuildComponentInputs +instance Structured PreBuildComponentInputs + +instance Binary PostBuildComponentInputs +instance Structured PostBuildComponentInputs + +instance Binary InstallComponentInputs +instance Structured InstallComponentInputs + +-------------------------------------------------------------------------------- diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs new file mode 100644 index 00000000000..afbabb859f6 --- /dev/null +++ b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs @@ -0,0 +1,1069 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Distribution.Simple.SetupHooks.Rule +-- +-- Internal module that defines fine-grained rules for setup hooks. +-- Users should import 'Distribution.Simple.SetupHooks' instead. +module Distribution.Simple.SetupHooks.Rule + ( -- * Rules + + -- ** Rule + Rule + , RuleData (..) + , RuleId (..) + , staticRule + , dynamicRule + + -- ** Commands + , RuleCommands (..) + , Command + , CommandData (..) + , runCommand + , mkCommand + , Dict (..) + + -- *** Helpers for executing commands + , RuleCmds + , RuleDynDepsCmd + , RuleExecCmd + , DynDepsCmd (..) + , DepsRes (..) + , ruleDepsCmd + , runRuleDynDepsCmd + , ruleExecCmd + , runRuleExecCmd + + -- ** Collections of rules + , Rules (..) + , Dependency (..) + , RuleOutput (..) + , rules + , noRules + + -- ** Rule inputs/outputs + , Location + + -- ** File/directory monitoring + , MonitorFilePath (..) + , MonitorKindFile (..) + , MonitorKindDir (..) + + -- *** Monadic API for generation of 'ActionId' + , RulesM + , RulesT (..) + , RulesEnv (..) + , computeRules + + -- * Internals + , Scope (..) + , SScope (..) + , Static (..) + , RuleBinary + , ruleBinary + ) +where + +import qualified Distribution.Compat.Binary as Binary +import Distribution.Compat.Prelude + +import Distribution.ModuleName + ( ModuleName + ) +import Distribution.Simple.FileMonitor.Types +import Distribution.Types.UnitId +import Distribution.Utils.ShortText + ( ShortText + ) +import Distribution.Verbosity + ( Verbosity + ) + +import Control.Monad.Fix + ( MonadFix + ) +import Control.Monad.Trans + ( MonadIO + , MonadTrans (..) + ) +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.State as State +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.Writer.CPS as Writer +#else +import qualified Control.Monad.Trans.Writer.Strict as Writer +#endif +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map + ( empty + ) + +import qualified Data.Kind as Hs +import Data.Type.Bool + ( If + ) +import Data.Type.Equality + ( (:~~:) (HRefl) + , type (==) + ) +import GHC.Show (showCommaSpace) +import GHC.StaticPtr +import System.IO.Unsafe + ( unsafePerformIO + ) +import qualified Type.Reflection as Typeable + ( SomeTypeRep (..) + , TypeRep + , eqTypeRep + , typeRep + , typeRepKind + , withTypeable + , pattern App + ) + +-------------------------------------------------------------------------------- + +{- Note [Fine-grained hooks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To best understand how the framework of fine-grained build rules +fits into Cabal and the greater Haskell ecosystem, it is helpful to think +that we want build tools (such as cabal-install or HLS) to be able to call +individual build rules on-demand, so that e.g. when a user modifies a .xyz file +the associated preprocessor is re-run. + +To do this, we need to perform two different kinds of invocations: + + Query: query the package for the rules that it provides, with their + dependency information. This allows one to determine when each + rule should be rerun. + + (For example, if one rule preprocesses *.xyz into *.hs, we need to + re-run the rule whenever *.xyz is modified.) + + Run: run the relevant action, once one has determined that the rule + has gone stale. + +To do this, any Cabal package with Hooks build-type provides a SetupHooks +module which supports these queries; for example it can be compiled into +a separate executable which can be invoked in the manner described above. +-} + +--------- +-- Rules + +-- | A unique identifier for a t'Rule'. +data RuleId = RuleId + { ruleNameSpace :: !RulesNameSpace + , ruleName :: !ShortText + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Binary, Structured) + +data RulesNameSpace = RulesNameSpace + { rulesUnitId :: !UnitId + , rulesModuleName :: !ModuleName + , rulesSrcLoc :: !(Int, Int) + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Binary, Structured) + +-- | Internal function: create a 'RulesNameSpace' from a 'StaticPtrInfo'. +staticPtrNameSpace :: StaticPtrInfo -> RulesNameSpace +staticPtrNameSpace + StaticPtrInfo + { spInfoUnitId = unitId + , spInfoModuleName = modName + , spInfoSrcLoc = srcLoc + } = + RulesNameSpace + { rulesUnitId = mkUnitId unitId + , rulesModuleName = fromString modName + , rulesSrcLoc = srcLoc + } + +-- | 'Rule's are defined with rich types by the package. +-- +-- The build system only has a limited view of these; most data consists of +-- opaque 'ByteString's. +-- +-- The 'Scope' data-type describes which side of this divide we are on. +data Scope + = -- | User space (with rich types). + User + | -- | Build-system space (manipulation of raw data). + System + +data SScope (scope :: Scope) where + SUser :: SScope User + SSystem :: SScope System + +type Rule = RuleData User +type RuleBinary = RuleData System + +-- | A rule consists of: +-- +-- - an action to run to execute the rule, +-- - a description of the rule inputs and outputs. +-- +-- Use 'staticRule' or 'dynamicRule' to construct a rule, overriding specific +-- fields, rather than directly using the 'Rule' constructor. +data RuleData (scope :: Scope) + = -- | Please use the 'staticRule' or 'dynamicRule' smart constructors + -- instead of this constructor, in order to avoid relying on internal + -- implementation details. + Rule + { ruleCommands :: !(RuleCmds scope) + -- ^ To run this rule, which t'Command's should we execute? + , staticDependencies :: ![Dependency] + -- ^ Static dependencies of this rule. + , results :: !(NE.NonEmpty Location) + -- ^ Results of this rule. + } + deriving stock (Generic) + +deriving stock instance Show (RuleData User) +deriving stock instance Eq (RuleData User) +deriving stock instance Eq (RuleData System) +deriving anyclass instance Binary (RuleData User) +deriving anyclass instance Binary (RuleData System) + +-- | Trimmed down 'Show' instance, mostly for error messages. +instance Show RuleBinary where + show (Rule{staticDependencies = deps, results = reslts, ruleCommands = cmds}) = + what ++ ": " ++ showDeps deps ++ " --> " ++ showLocs (NE.toList reslts) + where + what = case cmds of + StaticRuleCommand{} -> "Rule" + DynamicRuleCommands{} -> "Rule (dyn-deps)" + showDeps :: [Dependency] -> String + showDeps ds = "[" ++ intercalate ", " (map showDep ds) ++ "]" + showDep :: Dependency -> String + showDep = \case + RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) -> + "(" ++ show rId ++ ")[" ++ show i ++ "]" + FileDependency loc -> show loc + showLocs :: [Location] -> String + showLocs locs = "[" ++ intercalate ", " (map show locs) ++ "]" + +-- | A rule with static dependencies. +-- +-- Prefer using this smart constructor instead of v'Rule' whenever possible. +staticRule + :: forall arg + . Typeable arg + => Command arg (IO ()) + -> [Dependency] + -> NE.NonEmpty Location + -> Rule +staticRule cmd dep res = + Rule + { ruleCommands = + StaticRuleCommand + { staticRuleCommand = cmd + , staticRuleArgRep = Typeable.typeRep @arg + } + , staticDependencies = dep + , results = res + } + +-- | A rule with dynamic dependencies. +-- +-- Prefer using this smart constructor instead of v'Rule' whenever possible. +dynamicRule + :: forall depsArg depsRes arg + . (Typeable depsArg, Typeable depsRes, Typeable arg) + => StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes)) + -> Command depsArg (IO ([Dependency], depsRes)) + -> Command arg (depsRes -> IO ()) + -> [Dependency] + -> NE.NonEmpty Location + -> Rule +dynamicRule dict depsCmd action dep res = + Rule + { ruleCommands = + DynamicRuleCommands + { dynamicRuleInstances = UserStatic dict + , dynamicDeps = DynDepsCmd{dynDepsCmd = depsCmd} + , dynamicRuleCommand = action + , dynamicRuleTypeRep = Typeable.typeRep @(depsArg, depsRes, arg) + } + , staticDependencies = dep + , results = res + } + +----------------------- +-- Rule inputs/outputs + +-- | A (fully resolved) location of a dependency or result of a rule, +-- consisting of a base directory and of a file path relative to that base +-- directory path. +-- +-- In practice, this will be something like @( dir, toFilePath modName )@, +-- where: +-- +-- - for a file dependency, @dir@ is one of the Cabal search directories, +-- - for an output, @dir@ is a directory such as @autogenComponentModulesDir@ +-- or @componentBuildDir@. +type Location = (FilePath, FilePath) + +-- The reason for splitting it up this way is that some pre-processors don't +-- simply generate one output @.hs@ file from one input file, but have +-- dependencies on other generated files (notably @c2hs@, where building one +-- @.hs@ file may require reading other @.chi@ files, and then compiling the +-- @.hs@ file may require reading a generated @.h@ file). +-- In these cases, the generated files need to embed relative path names to each +-- other (eg the generated @.hs@ file mentions the @.h@ file in the FFI imports). +-- This path must be relative to the base directory where the generated files +-- are located; it cannot be relative to the top level of the build tree because +-- the compilers do not look for @.h@ files relative to there, ie we do not use +-- @-I .@, instead we use @-I dist/build@ (or whatever dist dir has been set +-- by the user). + +-- | A dependency of a rule. +data Dependency + = -- | A dependency on an output of another rule. + RuleDependency !RuleOutput + | -- | A direct dependency on a file at a particular location on disk. + -- + -- This should not be used for files that are generated by other rules; + -- use 'RuleDependency' instead. + FileDependency !Location + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Binary, Structured) + +-- | A reference to an output of another rule. +data RuleOutput = RuleOutput + { outputOfRule :: !RuleId + -- ^ which rule's outputs are we referring to? + , outputIndex :: !Word + -- ^ which particular output of that rule? + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Binary, Structured) + +--------- +-- Rules + +-- | Monad for constructing rules. +type RulesM a = RulesT IO a + +-- | The environment within the monadic API. +data RulesEnv = RulesEnv + { rulesEnvVerbosity :: !Verbosity + , rulesEnvNameSpace :: !RulesNameSpace + } + +-- | Monad transformer for defining rules. Usually wraps the 'IO' monad, +-- allowing @IO@ actions to be performed using @liftIO@. +newtype RulesT m a = RulesT + { runRulesT + :: Reader.ReaderT + RulesEnv + ( State.StateT + (Map RuleId Rule) + (Writer.WriterT [MonitorFilePath] m) + ) + a + } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadFix) + +instance MonadTrans RulesT where + lift = RulesT . lift . lift . lift + +-- | A collection of t'Rule's. +-- +-- Use the 'rules' smart constructor instead of directly using the v'Rules' +-- constructor. +-- +-- - Rules are registered using 'registerRule', +-- - Monitored files or directories are declared using 'addRuleMonitors'; +-- a change in these will trigger the recomputation of all rules. +-- +-- The @env@ type parameter represents an extra argument, which usually +-- consists of information known to Cabal such as 'LocalBuildInfo' and +-- 'ComponentLocalBuildInfo'. +newtype Rules env = Rules {runRules :: env -> RulesM ()} + +-- | __Warning__: this 'Semigroup' instance is not commutative. +instance Semigroup (Rules env) where + (Rules rs1) <> (Rules rs2) = + Rules $ \inputs -> do + y1 <- rs1 inputs + y2 <- rs2 inputs + return $ y1 <> y2 + +instance Monoid (Rules env) where + mempty = Rules $ const noRules + +-- | An empty collection of rules. +noRules :: RulesM () +noRules = return () + +-- | Construct a collection of rules with a given label. +-- +-- A label for the rules can be constructed using the @static@ keyword, +-- using the @StaticPointers@ extension. +-- NB: separate calls to 'rules' should have different labels. +-- +-- Example usage: +-- +-- > myRules :: Rules env +-- > myRules = rules (static ()) $ \ env -> do { .. } -- use the monadic API here +rules + :: StaticPtr label + -- ^ unique label for this collection of rules + -> (env -> RulesM ()) + -- ^ the computation of rules + -> Rules env +rules label = rulesInNameSpace (staticPtrNameSpace $ staticPtrInfo label) + +-- | Internal function to create a collection of rules. +-- +-- API users should go through the 'rules' function instead. +rulesInNameSpace + :: RulesNameSpace + -- ^ rule namespace + -> (env -> RulesM ()) + -- ^ the computation of rules + -> Rules env +rulesInNameSpace nameSpace f = + Rules $ \env -> RulesT $ do + Reader.withReaderT (\rulesEnv -> rulesEnv{rulesEnvNameSpace = nameSpace}) $ + runRulesT $ + f env + +-- | Internal function: run the monadic 'Rules' computations in order +-- to obtain all the 'Rule's with their 'RuleId's. +computeRules + :: Verbosity + -> env + -> Rules env + -> IO (Map RuleId Rule, [MonitorFilePath]) +computeRules verbosity inputs (Rules rs) = do + -- Bogus namespace to start with. This will be the first thing + -- to be set when users use the 'rules' smart constructor. + let noNameSpace = + RulesNameSpace + { rulesUnitId = mkUnitId "" + , rulesModuleName = fromString "" + , rulesSrcLoc = (0, 0) + } + env0 = + RulesEnv + { rulesEnvVerbosity = verbosity + , rulesEnvNameSpace = noNameSpace + } + Writer.runWriterT $ + (`State.execStateT` Map.empty) $ + (`Reader.runReaderT` env0) $ + runRulesT $ + rs inputs + +------------ +-- Commands + +-- | A static pointer (in user scope) or its key (in system scope). +data family Static (scope :: Scope) :: Hs.Type -> Hs.Type + +newtype instance Static User fnTy = UserStatic {userStaticPtr :: StaticPtr fnTy} +newtype instance Static System fnTy = SystemStatic {userStaticKey :: StaticKey} + deriving newtype (Eq, Ord, Show, Binary) + +systemStatic :: Static User fnTy -> Static System fnTy +systemStatic (UserStatic ptr) = SystemStatic (staticKey ptr) + +instance Show (Static User fnTy) where + showsPrec p ptr = showsPrec p (systemStatic ptr) +instance Eq (Static User fnTy) where + (==) = (==) `on` systemStatic +instance Ord (Static User fnTy) where + compare = compare `on` systemStatic +instance Binary (Static User fnTy) where + put = put . systemStatic + get = do + ptrKey <- get @StaticKey + case unsafePerformIO $ unsafeLookupStaticPtr ptrKey of + Just ptr -> return $ UserStatic ptr + Nothing -> + fail $ + unlines + [ "Failed to look up static pointer key for action." + , "NB: Binary instances for 'User' types cannot be used in external executables." + ] + +-- | A command consists of a statically-known action together with a +-- (possibly dynamic) argument to that action. +-- +-- For example, the action can consist of running an executable +-- (such as @happy@ or @c2hs@), while the argument consists of the variable +-- component of the command, e.g. the specific file to run @happy@ on. +type Command = CommandData User + +-- | Internal datatype used for commands, both for the Hooks API ('Command') +-- and for the build system. +data CommandData (scope :: Scope) (arg :: Hs.Type) (res :: Hs.Type) = Command + { actionPtr :: !(Static scope (arg -> res)) + -- ^ The (statically-known) action to execute. + , actionArg :: !(ScopedArgument scope arg) + -- ^ The (possibly dynamic) argument to pass to the action. + , cmdInstances :: !(Static scope (Dict (Binary arg, Show arg))) + -- ^ Static evidence that the argument can be serialised and deserialised. + } + +-- | Construct a command. +-- +-- Prefer using this smart constructor instead of v'Command' whenever possible. +mkCommand + :: forall arg res + . StaticPtr (Dict (Binary arg, Show arg)) + -> StaticPtr (arg -> res) + -> arg + -> Command arg res +mkCommand dict actionPtr arg = + Command + { actionPtr = UserStatic actionPtr + , actionArg = ScopedArgument arg + , cmdInstances = UserStatic dict + } + +-- | Run a 'Command'. +runCommand :: Command args res -> res +runCommand (Command{actionPtr = UserStatic ptr, actionArg = ScopedArgument arg}) = + deRefStaticPtr ptr arg + +-- | Commands to execute a rule: +-- +-- - for a rule with static dependencies, a single command, +-- - for a rule with dynamic dependencies, a command for computing dynamic +-- dependencies, and a command for executing the rule. +data + RuleCommands + (scope :: Scope) + (deps :: Scope -> Hs.Type -> Hs.Type -> Hs.Type) + (ruleCmd :: Scope -> Hs.Type -> Hs.Type -> Hs.Type) + where + -- | A rule with statically-known dependencies. + StaticRuleCommand + :: forall arg deps ruleCmd scope + . If + (scope == System) + (arg ~ LBS.ByteString) + (() :: Hs.Constraint) + => { staticRuleCommand :: !(ruleCmd scope arg (IO ())) + -- ^ The command to execute the rule. + , staticRuleArgRep :: !(If (scope == System) Typeable.SomeTypeRep (Typeable.TypeRep arg)) + -- ^ A 'TypeRep' for 'arg'. + } + -> RuleCommands scope deps ruleCmd + DynamicRuleCommands + :: forall depsArg depsRes arg deps ruleCmd scope + . If + (scope == System) + (depsArg ~ LBS.ByteString, depsRes ~ LBS.ByteString, arg ~ LBS.ByteString) + (() :: Hs.Constraint) + => { dynamicRuleInstances :: !(Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes))) + -- ^ A rule with dynamic dependencies, which consists of two parts: + -- + -- - a dynamic dependency computation, that returns additional edges to + -- be added to the build graph together with an additional piece of data, + -- - the command to execute the rule itself, which receives the additional + -- piece of data returned by the dependency computation. + , -- \^ Static evidence used for serialisation, in order to pass the result + -- of the dependency computation to the main rule action. + dynamicDeps :: !(deps scope depsArg depsRes) + -- ^ A dynamic dependency computation. The resulting dependencies + -- will be injected into the build graph, and the result of the computation + -- will be passed on to the command that executes the rule. + , dynamicRuleCommand :: !(ruleCmd scope arg (depsRes -> IO ())) + -- ^ The command to execute the rule. It will receive the result + -- of the dynamic dependency computation. + , dynamicRuleTypeRep + :: !( If + (scope == System) + Typeable.SomeTypeRep + (Typeable.TypeRep (depsArg, depsRes, arg)) + ) + -- ^ A 'TypeRep' for the triple @(depsArg,depsRes,arg)@. + } + -> RuleCommands scope deps ruleCmd + +{- Note [Hooks Binary instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Hooks API is strongly typed: users can declare rule commands with varying +types, e.g. + + staticRule + :: forall arg + . Typeable arg + => Command arg (IO ()) + -> [Dependency] + -> NE.NonEmpty Location + -> Rule + +allows a user to declare a 'Command' that receives an argument of type 'arg' +of their choosing. + +This all makes sense within the Hooks API, but when communicating with an +external build system (such as cabal-install or HLS), these arguments are +treated as opaque blobs of data (in particular if the Hooks are compiled into +a separate executable, then the static pointers that contain the relevant +instances for these user-chosen types can only be dereferenced from within that +executable, and not on the side of the build system). + +This means that, to enable Hooks to be communicated between the package and the +build system, we need: + + 1. Two representations of rules: one for the package author using the Hooks API, + and one for the build system. + 2. Compatibility in the 'Binary' instances for these two types. One needs to be + able to serialise a 'User'-side 'Rule', and de-serialise it on the build system + into a 'System'-side 'Rule' which contains some opaque bits of data, and + vice-versa. + +(1) is achieved using the 'Scope' parameter to the 'RuleData' datatype. +@Rule = RuleData User@ is the API-side representation, whereas +@RuleBinary = RuleData System@ is the build-system-side representation. + +For (2), note that when we serialise a value of known type and known size, e.g. +an 'Int64', we are nevertheless required to also serialise its size. This is because, +on the build-system side, we don't have access to any of the types, and thus don't know +how much to read in order to reconstruct the associated opaque 'ByteString'. +To ensure we always serialise/deserialise including the length of the data, +the 'ScopedArgument' newtype is used, with a custom 'Binary' instance that always +incldues the length. We use this newtype: + + - in the definition of 'CommandData', for arguments to rules, + - in the definition of 'DepsRes', for the result of dynamic dependency computations. +-} + +newtype ScopedArgument (scope :: Scope) arg = ScopedArgument {getArg :: arg} + deriving newtype (Eq, Ord, Show) + +-- | Serialise/deserialise, always including the length of the payload. +instance Binary arg => Binary (ScopedArgument User arg) where + put (ScopedArgument arg) = put @LBS.ByteString (Binary.encode arg) + get = do + dat <- get @LBS.ByteString + case Binary.decodeOrFail dat of + Left (_, _, err) -> fail err + Right (_, _, res) -> return $ ScopedArgument res + +-- | Serialise and deserialise a raw ByteString, leaving it untouched. +instance arg ~ LBS.ByteString => Binary (ScopedArgument System arg) where + put (ScopedArgument arg) = put arg + get = ScopedArgument <$> get + +-- | A placeholder for a command that has been omitted, e.g. when we don't +-- care about serialising/deserialising one particular command in a datatype. +data NoCmd (scope :: Scope) arg res = CmdOmitted + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass (Binary) + +-- | A dynamic dependency command. +newtype DynDepsCmd scope depsArg depsRes = DynDepsCmd + { dynDepsCmd + :: CommandData scope depsArg (IO ([Dependency], depsRes)) + } + +deriving newtype instance Show (DynDepsCmd User depsArg depsRes) +deriving newtype instance Eq (DynDepsCmd User depsArg depsRes) +deriving newtype instance Binary (DynDepsCmd User depsArg depsRes) +deriving newtype instance + (arg ~ LBS.ByteString, depsRes ~ LBS.ByteString) + => Eq (DynDepsCmd System arg depsRes) +deriving newtype instance + (arg ~ LBS.ByteString, depsRes ~ LBS.ByteString) + => Binary (DynDepsCmd System arg depsRes) + +-- | The result of a dynamic dependency computation. +newtype DepsRes (scope :: Scope) depsArg depsRes = DepsRes + { depsRes + :: ScopedArgument scope depsRes -- See Note [Hooks Binary instances] + } + deriving newtype (Show, Eq, Ord) + +deriving newtype instance + Binary (ScopedArgument scope depsRes) + => Binary (DepsRes scope depsArg depsRes) + +-- | Both the rule command and the (optional) dynamic dependency command. +type RuleCmds scope = RuleCommands scope DynDepsCmd CommandData + +-- | Only the (optional) dynamic dependency command. +type RuleDynDepsCmd scope = RuleCommands scope DynDepsCmd NoCmd + +-- | The rule command together with the result of the (optional) dynamic +-- dependency computation. +type RuleExecCmd scope = RuleCommands scope DepsRes CommandData + +-- | Project out the (optional) dependency computation command, so that +-- it can be serialised without serialising anything else. +ruleDepsCmd :: RuleCmds scope -> RuleDynDepsCmd scope +ruleDepsCmd = \case + StaticRuleCommand + { staticRuleCommand = _ :: CommandData scope args (IO ()) + , staticRuleArgRep = tr + } -> + StaticRuleCommand + { staticRuleCommand = CmdOmitted :: NoCmd scope args (IO ()) + , staticRuleArgRep = tr + } + DynamicRuleCommands + { dynamicRuleCommand = _ :: CommandData scope args (depsRes -> IO ()) + , dynamicRuleInstances = instsPtr + , dynamicDeps = deps + , dynamicRuleTypeRep = tr + } -> + DynamicRuleCommands + { dynamicRuleInstances = instsPtr + , dynamicDeps = deps + , dynamicRuleCommand = CmdOmitted :: NoCmd scope args (depsRes -> IO ()) + , dynamicRuleTypeRep = tr + } + +-- | Obtain the (optional) 'IO' action that computes dynamic dependencies. +runRuleDynDepsCmd :: RuleDynDepsCmd User -> Maybe (IO ([Dependency], LBS.ByteString)) +runRuleDynDepsCmd = \case + StaticRuleCommand{} -> Nothing + DynamicRuleCommands + { dynamicRuleInstances = UserStatic instsPtr + , dynamicDeps = DynDepsCmd{dynDepsCmd = depsCmd} + } + | Dict <- deRefStaticPtr instsPtr -> + Just $ do + (deps, depsRes) <- runCommand depsCmd + -- See Note [Hooks Binary instances] + return $ (deps, Binary.encode $ ScopedArgument @User depsRes) + +-- | Project out the command for running the rule, passing in the result of +-- the dependency computation if there was one. +ruleExecCmd :: SScope scope -> RuleCmds scope -> Maybe LBS.ByteString -> RuleExecCmd scope +ruleExecCmd + _ + StaticRuleCommand{staticRuleCommand = cmd, staticRuleArgRep = tr} + _ = + StaticRuleCommand{staticRuleCommand = cmd, staticRuleArgRep = tr} +ruleExecCmd + scope + DynamicRuleCommands + { dynamicRuleInstances = instsPtr + , dynamicRuleCommand = cmd :: CommandData scope arg (depsRes -> IO ()) + , dynamicDeps = _ :: DynDepsCmd scope depsArg depsRes + , dynamicRuleTypeRep = tr + } + mbDepsResBinary = + case mbDepsResBinary of + Nothing -> + error $ + unlines + [ "Missing ByteString argument in 'ruleExecCmd'." + , "Run 'runRuleDynDepsCmd' on the rule to obtain this data." + ] + Just depsResBinary -> + case scope of + SUser + | Dict <- deRefStaticPtr (userStaticPtr instsPtr) -> + DynamicRuleCommands + { dynamicRuleInstances = instsPtr + , dynamicRuleCommand = cmd + , dynamicDeps = Binary.decode depsResBinary :: DepsRes User depsArg depsRes + , dynamicRuleTypeRep = tr + } + SSystem -> + DynamicRuleCommands + { dynamicRuleInstances = instsPtr + , dynamicRuleCommand = cmd + , dynamicDeps = DepsRes $ ScopedArgument depsResBinary + , dynamicRuleTypeRep = tr + } + +-- | Obtain the 'IO' action that executes a rule. +runRuleExecCmd :: RuleExecCmd User -> IO () +runRuleExecCmd = \case + StaticRuleCommand{staticRuleCommand = cmd} -> runCommand cmd + DynamicRuleCommands + { dynamicDeps = DepsRes (ScopedArgument{getArg = res}) + , dynamicRuleCommand = cmd + } -> + runCommand cmd res + +-------------------------------------------------------------------------------- +-- Instances + +-- | A wrapper used to pass evidence of a constraint as an explicit value. +data Dict c where + Dict :: c => Dict c + +instance Show (CommandData User arg res) where + showsPrec prec (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts}) + | Dict <- deRefStaticPtr (userStaticPtr insts) = + showParen (prec >= 11) $ + showString "Command {" + . showString "actionPtrKey = " + . shows cmdPtr + . showCommaSpace + . showString "actionArg = " + . shows arg + . showString "}" + +instance Eq (CommandData User arg res) where + Command{actionPtr = cmdPtr1, actionArg = arg1, cmdInstances = insts1} + == Command{actionPtr = cmdPtr2, actionArg = arg2, cmdInstances = insts2} + | cmdPtr1 == cmdPtr2 + , insts1 == insts2 + , Dict <- deRefStaticPtr (userStaticPtr insts1) = + Binary.encode arg1 == Binary.encode arg2 + | otherwise = + False +instance arg ~ LBS.ByteString => Eq (CommandData System arg res) where + Command a1 b1 c1 == Command a2 b2 c2 = + a1 == a2 && b1 == b2 && c1 == c2 + +instance Binary (CommandData User arg res) where + put (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts}) + | Dict <- deRefStaticPtr (userStaticPtr insts) = + do + put cmdPtr + put insts + put arg + get = do + cmdPtr <- get + instsPtr <- get + case deRefStaticPtr @(Dict (Binary arg, Show arg)) $ userStaticPtr instsPtr of + Dict -> do + arg <- get + return $ + Command + { actionPtr = cmdPtr + , actionArg = arg + , cmdInstances = instsPtr + } +instance arg ~ LBS.ByteString => Binary (CommandData System arg res) where + put (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts}) = + do + put cmdPtr + put insts + put arg + get = do + cmdKey <- get + instsKey <- get + arg <- get + return $ Command{actionPtr = cmdKey, actionArg = arg, cmdInstances = instsKey} + +instance + ( forall arg res. Show (ruleCmd User arg res) + , forall depsArg depsRes. Show depsRes => Show (deps User depsArg depsRes) + ) + => Show (RuleCommands User deps ruleCmd) + where + showsPrec prec (StaticRuleCommand{staticRuleCommand = cmd}) = + showParen (prec >= 11) $ + showString "StaticRuleCommand {" + . showString "staticRuleCommand = " + . shows cmd + . showString "}" + showsPrec + prec + ( DynamicRuleCommands + { dynamicDeps = deps + , dynamicRuleCommand = cmd + , dynamicRuleInstances = UserStatic instsPtr + } + ) + | Dict <- deRefStaticPtr instsPtr = + showParen (prec >= 11) $ + showString "DynamicRuleCommands {" + . showString "dynamicDeps = " + . shows deps + . showCommaSpace + . showString "dynamicRuleCommand = " + . shows cmd + . showString "}" + +instance + ( forall arg res. Eq (ruleCmd User arg res) + , forall depsArg depsRes. Eq depsRes => Eq (deps User depsArg depsRes) + ) + => Eq (RuleCommands User deps ruleCmd) + where + StaticRuleCommand{staticRuleCommand = ruleCmd1 :: ruleCmd User arg1 (IO ()), staticRuleArgRep = tr1} + == StaticRuleCommand{staticRuleCommand = ruleCmd2 :: ruleCmd User arg2 (IO ()), staticRuleArgRep = tr2} + | Just HRefl <- Typeable.eqTypeRep tr1 tr2 = + ruleCmd1 == ruleCmd2 + DynamicRuleCommands + { dynamicDeps = depsCmd1 :: deps User depsArg1 depsRes1 + , dynamicRuleCommand = ruleCmd1 :: ruleCmd User arg1 (depsRes1 -> IO ()) + , dynamicRuleInstances = UserStatic instsPtr1 + , dynamicRuleTypeRep = tr1 + } + == DynamicRuleCommands + { dynamicDeps = depsCmd2 :: deps User depsArg2 depsRes2 + , dynamicRuleCommand = ruleCmd2 :: ruleCmd User arg2 (depsRes2 -> IO ()) + , dynamicRuleInstances = UserStatic instsPtr2 + , dynamicRuleTypeRep = tr2 + } + | Just HRefl <- Typeable.eqTypeRep tr1 tr2 + , Dict <- deRefStaticPtr instsPtr1 = + depsCmd1 == depsCmd2 + && ruleCmd1 == ruleCmd2 + && staticKey instsPtr1 == staticKey instsPtr2 + _ == _ = False + +instance + ( forall res. Eq (ruleCmd System LBS.ByteString res) + , Eq (deps System LBS.ByteString LBS.ByteString) + ) + => Eq (RuleCommands System deps ruleCmd) + where + StaticRuleCommand c1 d1 == StaticRuleCommand c2 d2 = c1 == c2 && d1 == d2 + DynamicRuleCommands a1 b1 c1 d1 == DynamicRuleCommands a2 b2 c2 d2 = + a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 + _ == _ = False + +instance + ( forall arg res. Binary (ruleCmd User arg res) + , forall depsArg depsRes. Binary depsRes => Binary (deps User depsArg depsRes) + ) + => Binary (RuleCommands User deps ruleCmd) + where + put = \case + StaticRuleCommand + { staticRuleCommand = ruleCmd :: ruleCmd User arg (IO ()) + , staticRuleArgRep = tr + } -> do + put @Word 0 + put (Typeable.SomeTypeRep tr) + put ruleCmd + DynamicRuleCommands + { dynamicDeps = deps :: deps User depsArg depsRes + , dynamicRuleCommand = ruleCmd :: ruleCmd User arg (depsRes -> IO ()) + , dynamicRuleInstances = instsPtr + , dynamicRuleTypeRep = tr + } | Dict <- deRefStaticPtr (userStaticPtr instsPtr) -> + do + put @Word 1 + put (Typeable.SomeTypeRep tr) + put instsPtr + put ruleCmd + put deps + get = do + tag <- get @Word + case tag of + 0 -> do + Typeable.SomeTypeRep (trArg :: Typeable.TypeRep arg) <- get + if + | Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trArg) (Typeable.typeRep @Hs.Type) -> + do + ruleCmd <- get @(ruleCmd User arg (IO ())) + return $ + Typeable.withTypeable trArg $ + StaticRuleCommand + { staticRuleCommand = ruleCmd + , staticRuleArgRep = trArg + } + | otherwise -> + error "internal error when decoding static rule command" + _ -> do + Typeable.SomeTypeRep (tr :: Typeable.TypeRep ty) <- get + case tr of + Typeable.App + ( Typeable.App + (Typeable.App (tup3Tr :: Typeable.TypeRep tup3) (trDepsArg :: Typeable.TypeRep depsArg)) + (trDepsRes :: Typeable.TypeRep depsRes) + ) + (trArg :: Typeable.TypeRep arg) + | Just HRefl <- Typeable.eqTypeRep tup3Tr (Typeable.typeRep @(,,)) -> do + instsPtr <- get + case deRefStaticPtr $ userStaticPtr instsPtr of + (Dict :: Dict (Binary depsRes, Show depsRes, Eq depsRes)) -> + do + ruleCmd <- get @(ruleCmd User arg (depsRes -> IO ())) + deps <- get @(deps User depsArg depsRes) + return $ + Typeable.withTypeable trDepsArg $ + Typeable.withTypeable trDepsRes $ + Typeable.withTypeable trArg $ + DynamicRuleCommands + { dynamicDeps = deps + , dynamicRuleCommand = ruleCmd + , dynamicRuleInstances = instsPtr + , dynamicRuleTypeRep = tr + } + _ -> error "internal error when decoding dynamic rule commands" + +instance + ( forall res. Binary (ruleCmd System LBS.ByteString res) + , Binary (deps System LBS.ByteString LBS.ByteString) + ) + => Binary (RuleCommands System deps ruleCmd) + where + put = \case + StaticRuleCommand{staticRuleCommand = ruleCmd, staticRuleArgRep = sTr} -> do + put @Word 0 + put sTr + put ruleCmd + DynamicRuleCommands + { dynamicDeps = deps + , dynamicRuleCommand = ruleCmd + , dynamicRuleInstances = instsKey + , dynamicRuleTypeRep = sTr + } -> + do + put @Word 1 + put sTr + put instsKey + put ruleCmd + put deps + get = do + tag <- get @Word + case tag of + 0 -> do + sTr <- get @Typeable.SomeTypeRep + ruleCmd <- get + return $ + StaticRuleCommand + { staticRuleCommand = ruleCmd + , staticRuleArgRep = sTr + } + _ -> do + sTr <- get @Typeable.SomeTypeRep + instsKey <- get + ruleCmd <- get + deps <- get + return $ + DynamicRuleCommands + { dynamicDeps = deps + , dynamicRuleCommand = ruleCmd + , dynamicRuleInstances = instsKey + , dynamicRuleTypeRep = sTr + } + +-------------------------------------------------------------------------------- +-- Showing rules + +ruleBinary :: Rule -> RuleBinary +ruleBinary = Binary.decode . Binary.encode diff --git a/Cabal/src/Distribution/Simple/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs index 443fc87ae58..eb9096271ef 100644 --- a/Cabal/src/Distribution/Simple/SrcDist.hs +++ b/Cabal/src/Distribution/Simple/SrcDist.hs @@ -276,6 +276,8 @@ listPackageSources' verbosity rip mbWorkDir pkg_descr pps = traverse (fmap (makeSymbolicPath . snd) . findIncludeFile verbosity cwd relincdirs) incls , -- Setup script, if it exists. fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupFile cwd + , -- SetupHooks script, if it exists. + fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupHooksFile cwd , -- The .cabal file itself. fmap (\d -> [d]) (coerceSymbolicPath . relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir) ] @@ -325,6 +327,21 @@ findSetupFile targetDir = do setupHs = "Setup.hs" setupLhs = "Setup.lhs" +-- | Find the setup hooks script file, if it exists. +findSetupHooksFile :: FilePath -> IO (Maybe FilePath) +findSetupHooksFile targetDir = do + hsExists <- doesFileExist (targetDir setupHs) + lhsExists <- doesFileExist (targetDir setupLhs) + if hsExists + then return (Just setupHs) + else + if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = "SetupHooks.hs" + setupLhs = "SetupHooks.lhs" + -- | Create a default setup script in the target directory, if it doesn't exist. maybeCreateDefaultSetupScript :: FilePath -> IO () maybeCreateDefaultSetupScript targetDir = do diff --git a/Cabal/src/Distribution/Simple/Test.hs b/Cabal/src/Distribution/Simple/Test.hs index 3d364ae44b2..4b4ddb7e342 100644 --- a/Cabal/src/Distribution/Simple/Test.hs +++ b/Cabal/src/Distribution/Simple/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} diff --git a/Cabal/src/Distribution/Simple/UserHooks.hs b/Cabal/src/Distribution/Simple/UserHooks.hs index b27cd0b875f..75ab4a6bedf 100644 --- a/Cabal/src/Distribution/Simple/UserHooks.hs +++ b/Cabal/src/Distribution/Simple/UserHooks.hs @@ -32,7 +32,7 @@ module Distribution.Simple.UserHooks , emptyUserHooks ) where -import Distribution.Compat.Prelude +import Distribution.Compat.Prelude hiding (getContents, putStr) import Prelude () import Distribution.PackageDescription diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 8c30cc18abb..6d440b78062 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -114,6 +114,7 @@ module Distribution.Simple.Utils , findFileEx , findFileCwd , findFirstFile + , Suffix (..) , findFileWithExtension , findFileCwdWithExtension , findFileWithExtension' diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 37e0cbdf1ee..66a0a103c23 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -630,7 +630,7 @@ addDefaultSetupDependencies defaultSetupDeps params = } } where - isCustom = PD.buildType pkgdesc == PD.Custom + isCustom = PD.buildType pkgdesc == PD.Custom || PD.buildType pkgdesc == PD.Hooks gpkgdesc = srcpkgDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc @@ -729,7 +729,7 @@ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = gpkgdesc = srcpkgDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc bt = PD.buildType pkgdesc - affected = bt == PD.Custom && hasBuildableFalse gpkgdesc + affected = (bt == PD.Custom || bt == PD.Hooks) && hasBuildableFalse gpkgdesc -- Does this package contain any components with non-empty 'build-depends' -- and a 'buildable' field that could potentially be set to 'False'? False diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs index 084545d5e7e..59742cc1b80 100644 --- a/cabal-install/src/Distribution/Client/FileMonitor.hs +++ b/cabal-install/src/Distribution/Client/FileMonitor.hs @@ -11,22 +11,7 @@ -- input values they depend on have changed. module Distribution.Client.FileMonitor ( -- * Declaring files to monitor - MonitorFilePath (..) - , MonitorKindFile (..) - , MonitorKindDir (..) - , RootedGlob (..) - , monitorFile - , monitorFileHashed - , monitorNonExistentFile - , monitorFileExistence - , monitorDirectory - , monitorNonExistentDirectory - , monitorDirectoryExistence - , monitorFileOrDirectory - , monitorFileGlob - , monitorFileGlobExistence - , monitorFileSearchPath - , monitorFileHashedSearchPath + module Distribution.Simple.FileMonitor.Types -- * Creating and checking sets of monitored files , FileMonitor (..) @@ -68,130 +53,14 @@ import Control.Monad.Trans (MonadIO, liftIO) import Distribution.Client.Glob import Distribution.Client.Utils (MergeResult (..), mergeBy) import Distribution.Compat.Time +import Distribution.Simple.FileMonitor.Types import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) import Distribution.Utils.Structured (Tag (..), structuredEncode) + import System.Directory import System.FilePath import System.IO ------------------------------------------------------------------------------- --- Types for specifying files to monitor --- - --- | A description of a file (or set of files) to monitor for changes. --- --- Where file paths are relative they are relative to a common directory --- (e.g. project root), not necessarily the process current directory. -data MonitorFilePath - = MonitorFile - { monitorKindFile :: !MonitorKindFile - , monitorKindDir :: !MonitorKindDir - , monitorPath :: !FilePath - } - | MonitorFileGlob - { monitorKindFile :: !MonitorKindFile - , monitorKindDir :: !MonitorKindDir - , monitorPathGlob :: !RootedGlob - } - deriving (Eq, Show, Generic) - -data MonitorKindFile - = FileExists - | FileModTime - | FileHashed - | FileNotExists - deriving (Eq, Show, Generic) - -data MonitorKindDir - = DirExists - | DirModTime - | DirNotExists - deriving (Eq, Show, Generic) - -instance Binary MonitorFilePath -instance Binary MonitorKindFile -instance Binary MonitorKindDir - -instance Structured MonitorFilePath -instance Structured MonitorKindFile -instance Structured MonitorKindDir - --- | Monitor a single file for changes, based on its modification time. --- The monitored file is considered to have changed if it no longer --- exists or if its modification time has changed. -monitorFile :: FilePath -> MonitorFilePath -monitorFile = MonitorFile FileModTime DirNotExists - --- | Monitor a single file for changes, based on its modification time --- and content hash. The monitored file is considered to have changed if --- it no longer exists or if its modification time and content hash have --- changed. -monitorFileHashed :: FilePath -> MonitorFilePath -monitorFileHashed = MonitorFile FileHashed DirNotExists - --- | Monitor a single non-existent file for changes. The monitored file --- is considered to have changed if it exists. -monitorNonExistentFile :: FilePath -> MonitorFilePath -monitorNonExistentFile = MonitorFile FileNotExists DirNotExists - --- | Monitor a single file for existence only. The monitored file is --- considered to have changed if it no longer exists. -monitorFileExistence :: FilePath -> MonitorFilePath -monitorFileExistence = MonitorFile FileExists DirNotExists - --- | Monitor a single directory for changes, based on its modification --- time. The monitored directory is considered to have changed if it no --- longer exists or if its modification time has changed. -monitorDirectory :: FilePath -> MonitorFilePath -monitorDirectory = MonitorFile FileNotExists DirModTime - --- | Monitor a single non-existent directory for changes. The monitored --- directory is considered to have changed if it exists. -monitorNonExistentDirectory :: FilePath -> MonitorFilePath --- Just an alias for monitorNonExistentFile, since you can't --- tell the difference between a non-existent directory and --- a non-existent file :) -monitorNonExistentDirectory = monitorNonExistentFile - --- | Monitor a single directory for existence. The monitored directory is --- considered to have changed only if it no longer exists. -monitorDirectoryExistence :: FilePath -> MonitorFilePath -monitorDirectoryExistence = MonitorFile FileNotExists DirExists - --- | Monitor a single file or directory for changes, based on its modification --- time. The monitored file is considered to have changed if it no longer --- exists or if its modification time has changed. -monitorFileOrDirectory :: FilePath -> MonitorFilePath -monitorFileOrDirectory = MonitorFile FileModTime DirModTime - --- | Monitor a set of files (or directories) identified by a file glob. --- The monitored glob is considered to have changed if the set of files --- matching the glob changes (i.e. creations or deletions), or for files if the --- modification time and content hash of any matching file has changed. -monitorFileGlob :: RootedGlob -> MonitorFilePath -monitorFileGlob = MonitorFileGlob FileHashed DirExists - --- | Monitor a set of files (or directories) identified by a file glob for --- existence only. The monitored glob is considered to have changed if the set --- of files matching the glob changes (i.e. creations or deletions). -monitorFileGlobExistence :: RootedGlob -> MonitorFilePath -monitorFileGlobExistence = MonitorFileGlob FileExists DirExists - --- | Creates a list of files to monitor when you search for a file which --- unsuccessfully looked in @notFoundAtPaths@ before finding it at --- @foundAtPath@. -monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] -monitorFileSearchPath notFoundAtPaths foundAtPath = - monitorFile foundAtPath - : map monitorNonExistentFile notFoundAtPaths - --- | Similar to 'monitorFileSearchPath', but also instructs us to --- monitor the hash of the found file. -monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] -monitorFileHashedSearchPath notFoundAtPaths foundAtPath = - monitorFileHashed foundAtPath - : map monitorNonExistentFile notFoundAtPaths - ------------------------------------------------------------------------------ -- Implementation types, files status -- diff --git a/cabal-install/src/Distribution/Client/Glob.hs b/cabal-install/src/Distribution/Client/Glob.hs index 90054a8f64f..6aa2da0c29f 100644 --- a/cabal-install/src/Distribution/Client/Glob.hs +++ b/cabal-install/src/Distribution/Client/Glob.hs @@ -12,48 +12,25 @@ module Distribution.Client.Glob , Glob (..) , GlobPiece (..) , GlobPieces - , matchGlob - , matchGlobPieces , matchFileGlob ) where import Distribution.Client.Compat.Prelude import Prelude () +import Distribution.Simple.FileMonitor.Types import Distribution.Simple.Glob import Distribution.Simple.Glob.Internal + ( Glob (..) + , GlobPiece (..) + , GlobPieces + ) import System.Directory import System.FilePath -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- | A file path specified by globbing, relative --- to some root directory. -data RootedGlob - = RootedGlob - FilePathRoot - -- ^ what the glob is relative to - Glob - -- ^ the glob - deriving (Eq, Show, Generic) - -instance Binary RootedGlob -instance Structured RootedGlob - -data FilePathRoot - = FilePathRelative - | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive' - FilePathRoot FilePath - | FilePathHomeDir - deriving (Eq, Show, Generic) - -instance Binary FilePathRoot -instance Structured FilePathRoot - -- | Check if a 'RootedGlob' doesn't actually make use of any globbing and -- is in fact equivalent to a non-glob 'FilePath'. -- @@ -105,33 +82,3 @@ matchFileGlob relroot (RootedGlob globroot glob) = do case globroot of FilePathRelative -> return matches _ -> return (map (root ) matches) - ------------------------------------------------------------------------------- --- Parsing & pretty-printing --- - -instance Pretty RootedGlob where - pretty (RootedGlob root pathglob) = pretty root Disp.<> pretty pathglob - -instance Parsec RootedGlob where - parsec = do - root <- parsec - case root of - FilePathRelative -> RootedGlob root <$> parsec - _ -> RootedGlob root <$> parsec <|> pure (RootedGlob root GlobDirTrailing) - -instance Pretty FilePathRoot where - pretty FilePathRelative = Disp.empty - pretty (FilePathRoot root) = Disp.text root - pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' - -instance Parsec FilePathRoot where - parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative - where - root = FilePathRoot "/" <$ P.char '/' - home = FilePathHomeDir <$ P.string "~/" - drive = do - dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') - _ <- P.char ':' - _ <- P.char '/' <|> P.char '\\' - return (FilePathRoot (toUpper dr : ":\\")) diff --git a/cabal-install/src/Distribution/Client/Init/Defaults.hs b/cabal-install/src/Distribution/Client/Init/Defaults.hs index 9be998feda7..a915a5159d3 100644 --- a/cabal-install/src/Distribution/Client/Init/Defaults.hs +++ b/cabal-install/src/Distribution/Client/Init/Defaults.hs @@ -135,6 +135,7 @@ defaultCabalVersions = , CabalSpecV2_4 , CabalSpecV3_0 , CabalSpecV3_4 + , CabalSpecV3_14 ] defaultInitFlags :: InitFlags diff --git a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs index 1e08e843d6f..48209d37067 100644 --- a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs +++ b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs @@ -313,6 +313,7 @@ cabalVersionPrompt flags = getCabalVersion flags $ do parseCabalVersion "3.0" = CabalSpecV3_0 parseCabalVersion "3.4" = CabalSpecV3_4 parseCabalVersion "3.12" = CabalSpecV3_12 + parseCabalVersion "3.14" = CabalSpecV3_14 parseCabalVersion _ = defaultCabalVersion -- 2.4 displayCabalVersion :: CabalSpecVersion -> String displayCabalVersion v = case v of @@ -321,6 +322,7 @@ cabalVersionPrompt flags = getCabalVersion flags $ do CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)" CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)" CabalSpecV3_4 -> "3.4 (+ sublibraries in 'mixins', optional 'default-language')" + CabalSpecV3_14 -> "3.14 (+ build-type: Hooks)" _ -> showCabalSpecVersion v packageNamePrompt :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 2de2e48f3e4..de14fc129c9 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -1474,6 +1474,7 @@ actAsSetupAction actAsSetupFlags args _globalFlags = Simple.autoconfUserHooks args Make -> Make.defaultMainArgs args + Hooks -> error "actAsSetupAction Hooks" Custom -> error "actAsSetupAction Custom" manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index cdde7d48062..38a59b9818c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1631,6 +1631,7 @@ elaborateInstallPlan 4 (vcat (map (text . componentNameStanza) cns)) where + bt = PD.buildType (elabPkgDescription elab0) -- You are eligible to per-component build if this list is empty why_not_per_component g = cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag @@ -1646,11 +1647,12 @@ elaborateInstallPlan -- type, and teach all of the code paths how to handle it. -- Once you've implemented this, swap it for the code below. cuz_buildtype = - case PD.buildType (elabPkgDescription elab0) of + case bt of PD.Configure -> [CuzBuildType CuzConfigureBuildType] PD.Custom -> [CuzBuildType CuzCustomBuildType] + PD.Hooks -> [CuzBuildType CuzHooksBuildType] PD.Make -> [CuzBuildType CuzMakeBuildType] - _ -> [] + PD.Simple -> [] -- cabal-format versions prior to 1.8 have different build-depends semantics -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 -- see, https://github.com/haskell/cabal/issues/4121 @@ -1694,7 +1696,7 @@ elaborateInstallPlan -- have to add dependencies on this from all other components setupComponent :: Maybe ElaboratedConfiguredPackage setupComponent - | PD.buildType (elabPkgDescription elab0) == PD.Custom = + | bt `elem` [PD.Custom, PD.Hooks] = Just elab0 { elabModuleShape = emptyModuleShape @@ -3678,7 +3680,14 @@ setupHsScriptOptions cacheLock = SetupScriptOptions { useCabalVersion = thisVersion elabSetupScriptCliVersion - , useCabalSpecVersion = Just elabSetupScriptCliVersion + , useCabalSpecVersion = + if PD.buildType elabPkgDescription == PD.Hooks + then -- NB: we don't want to commit to a Cabal version here: + -- - all that should matter for Hooks build-type is the + -- version of Cabal-hooks, not of Cabal, + -- - if we commit to a Cabal version, the logic in + Nothing + else Just elabSetupScriptCliVersion , useCompiler = Just pkgConfigCompiler , usePlatform = Just pkgConfigPlatform , usePackageDB = elabSetupPackageDBStack diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs index 86bc044342e..212a5d93f81 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs @@ -59,17 +59,17 @@ import qualified Distribution.Compat.Graph as Graph -- @since 3.12.0.0 packageSetupScriptStyle :: PackageDescription -> SetupScriptStyle packageSetupScriptStyle pkg - | buildType pkg == Custom + | customOrHooks , Just setupbi <- setupBuildInfo pkg -- does have a custom-setup stanza , not (defaultSetupDepends setupbi) -- but not one we added ourselves = SetupCustomExplicitDeps - | buildType pkg == Custom + | customOrHooks , Just setupbi <- setupBuildInfo pkg -- does have a custom-setup stanza , defaultSetupDepends setupbi -- that we had to add ourselves = SetupCustomImplicitDeps - | buildType pkg == Custom + | customOrHooks , Nothing <- setupBuildInfo pkg -- we get this case pre-solver = SetupCustomImplicitDeps @@ -79,6 +79,8 @@ packageSetupScriptStyle pkg SetupNonCustomExternalLib | otherwise = SetupNonCustomInternalLib + where + customOrHooks = buildType pkg `elem` [Custom, Hooks] -- | Part of our Setup.hs handling policy is implemented by getting the solver -- to work out setup dependencies for packages. The solver already handles diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index f344db1e389..5b4896b0568 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -762,6 +762,7 @@ data NotPerComponentReason data NotPerComponentBuildType = CuzConfigureBuildType | CuzCustomBuildType + | CuzHooksBuildType | CuzMakeBuildType deriving (Eq, Show, Generic) @@ -779,6 +780,7 @@ whyNotPerComponent = \case "build-type is " ++ case bt of CuzConfigureBuildType -> "Configure" CuzCustomBuildType -> "Custom" + CuzHooksBuildType -> "Hooks" CuzMakeBuildType -> "Make" CuzCabalSpecVersion -> "cabal-version is less than 1.8" CuzNoBuildableComponents -> "there are no buildable components" diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index f5432dad1c2..0fc5e89f1bc 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -156,6 +156,7 @@ import Distribution.Simple.Utils , copyFileVerbose , createDirectoryIfMissingVerbose , debug + , die' , dieWithException , info , infoNoWrap @@ -405,6 +406,7 @@ getSetupMethod -> IO (Version, SetupMethod, SetupScriptOptions) getSetupMethod verbosity options pkg buildType' | buildType' == Custom + || buildType' == Hooks || maybe False (cabalVersion /=) (useCabalSpecVersion options) || not (cabalVersion `withinRange` useCabalVersion options) = getExternalSetupMethod verbosity options pkg buildType' @@ -556,6 +558,7 @@ buildTypeAction Configure = Simple.defaultMainWithHooksArgs Simple.autoconfUserHooks buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Hooks = error "buildTypeAction Hooks" buildTypeAction Custom = error "buildTypeAction Custom" invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () @@ -712,6 +715,7 @@ getExternalSetupMethod verbosity options pkg bt = do setupDir = useDistPref options Cabal.Path. makeRelativePathEx "setup" setupVersionFile = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> "version") setupHs = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> "hs") + setupHooks = setupDir Cabal.Path. makeRelativePathEx ("SetupHooks" <.> "hs") setupProgFile = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> exeExtension buildPlatform) platform = fromMaybe buildPlatform (usePlatform options) @@ -838,6 +842,17 @@ getExternalSetupMethod verbosity options pkg bt = do where customSetupHs = workingDir options "Setup.hs" customSetupLhs = workingDir options "Setup.lhs" + updateSetupScript cabalLibVersion Hooks = do + + let customSetupHooks = workingDir options "SetupHooks.hs" + useHs <- doesFileExist customSetupHooks + unless (useHs) $ + die' + verbosity + "Using 'build-type: Hooks' but there is no SetupHooks.hs file." + copyFileVerbose verbosity customSetupHooks (i setupHooks) + rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) +-- rewriteFileLBS verbosity hooksHs hooksScript updateSetupScript cabalLibVersion _ = rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) @@ -848,6 +863,7 @@ getExternalSetupMethod verbosity options pkg bt = do | cabalLibVersion >= mkVersion [1, 3, 10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n" | otherwise -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n" Make -> "import Distribution.Make; main = defaultMain\n" + Hooks -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n" Custom -> error "buildTypeScript Custom" installedCabalVersion @@ -1049,26 +1065,18 @@ getExternalSetupMethod verbosity options pkg bt = do (\ipkgid -> [(ipkgid, cabalPkgid)]) maybeCabalLibInstalledPkgId - -- With 'useDependenciesExclusive' we enforce the deps specified, - -- so only the given ones can be used. Otherwise we allow the use - -- of packages in the ambient environment, and add on a dep on the - -- Cabal library (unless 'useDependencies' already contains one). - -- - -- With 'useVersionMacros' we use a version CPP macros .h file. - -- - -- Both of these options should be enabled for packages that have - -- opted-in and declared a custom-settup stanza. - -- + -- With 'useDependenciesExclusive' and Custom build type, + -- we enforce the deps specified, so only the given ones can be used. + -- Otherwise we add on a dep on the Cabal library + -- (unless 'useDependencies' already contains one). selectedDeps - | useDependenciesExclusive options' = - useDependencies options' + | (useDependenciesExclusive options' && (bt /= Hooks)) + -- NB: to compile build-type: Hooks packages, we need Cabal + -- in order to compile @main = defaultMainWithSetupHooks setupHooks@. + || any (isCabalPkgId . snd) (useDependencies options') + = useDependencies options' | otherwise = - useDependencies options' - ++ if any - (isCabalPkgId . snd) - (useDependencies options') - then [] - else cabalDep + useDependencies options' ++ cabalDep addRenaming (ipid, _) = -- Assert 'DefUnitId' invariant ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) @@ -1089,11 +1097,13 @@ getExternalSetupMethod verbosity options pkg bt = do , ghcOptSourcePathClear = Flag True , ghcOptSourcePath = case bt of Custom -> toNubListR [sameDirectory] + Hooks -> toNubListR [sameDirectory] _ -> mempty , ghcOptPackageDBs = usePackageDB options'' , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') , ghcOptCabal = Flag (useDependenciesExclusive options') , ghcOptPackages = toNubListR $ map addRenaming selectedDeps + -- With 'useVersionMacros', use a version CPP macros .h file. , ghcOptCppIncludes = toNubListR [ cppMacrosFile diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/SetupHooks.hs new file mode 100644 index 00000000000..d81c48d93e4 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/SetupHooks.hs @@ -0,0 +1,18 @@ +module SetupHooks where + +import Distribution.Simple.SetupHooks + +import Control.Monad ( void ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { configureHooks = + noConfigureHooks + { preConfComponentHook = Just pccHook } + } + +pccHook :: PreConfComponentHook +pccHook _ = return $ + PreConfComponentOutputs $ ComponentDiff $ CExe emptyExecutable + -- Bad: component is a library, but we returned an executable! diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup-hooks-bad-diff1-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup-hooks-bad-diff1-test.cabal new file mode 100644 index 00000000000..37e0db3efda --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup-hooks-bad-diff1-test.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.14 +name: setup-hooks-bad-diff1-test +version: 0.1.0.0 +synopsis: Test 1 for a bad component diff +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.out new file mode 100644 index 00000000000..2fdce2d44c0 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring setup-hooks-bad-diff1-test-0.1.0.0... +Error: [Cabal-9491] +Hooks: mismatched component types in per-component configure hook. +Trying to apply an executable diff to a library. diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.test.hs new file mode 100644 index 00000000000..0096ff04cef --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = setupTest $ do + fails $ setup "configure" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/SetupHooks.hs new file mode 100644 index 00000000000..1c79900b639 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/SetupHooks.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SetupHooks where + +import Distribution.Simple.SetupHooks + +import Control.Monad ( void ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { configureHooks = + noConfigureHooks + { preConfComponentHook = Just pccHook } + } + +pccHook :: PreConfComponentHook +pccHook _ = return $ + -- Make invalid changes to a library + PreConfComponentOutputs $ ComponentDiff $ CLib $ + emptyLibrary + { libName = LSubLibName "hocus-pocus" + , libExposed = False + , libBuildInfo = + emptyBuildInfo + { buildable = False } + } diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup-hooks-bad-diff2-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup-hooks-bad-diff2-test.cabal new file mode 100644 index 00000000000..8f3bd230ab1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup-hooks-bad-diff2-test.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.14 +name: setup-hooks-bad-diff2-test +version: 0.1.0.0 +synopsis: Test 2 for a bad component diff +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.out new file mode 100644 index 00000000000..0c9286b42dc --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring setup-hooks-bad-diff2-test-0.1.0.0... +Error: [Cabal-7634] +Hooks: illegal component diff in per-component pre-configure hook for main library: + - cannot change the name of a component. + - cannot change component field 'libExposed'. + - cannot change BuildInfo field 'buildable'. diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.test.hs new file mode 100644 index 00000000000..0096ff04cef --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = setupTest $ do + fails $ setup "configure" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A1.myChs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A1.myChs new file mode 100644 index 00000000000..5a5ad78c46c --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A1.myChs @@ -0,0 +1,5 @@ +imports: + +import X +foo1 :: Double +foo1 = x diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A2.myChs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A2.myChs new file mode 100644 index 00000000000..8e504be4e14 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A2.myChs @@ -0,0 +1,4 @@ +imports: + +foo2 :: Double +foo2 = 3.000003 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/B.myChs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/B.myChs new file mode 100644 index 00000000000..b6fa9fbb8ec --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/B.myChs @@ -0,0 +1,4 @@ +imports: A1 A2 + +bar :: Double +bar = foo1 + foo2 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/C.myChs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/C.myChs new file mode 100644 index 00000000000..44365beb319 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/C.myChs @@ -0,0 +1,4 @@ +imports: B + +quux :: Double +quux = bar + 11 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/D.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/D.hs new file mode 100644 index 00000000000..77fedb97265 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/D.hs @@ -0,0 +1,6 @@ +module D where + +import C + +xyzzy :: Double +xyzzy = 10 * quux diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs new file mode 100644 index 00000000000..67ac7b8ee1d --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Compat.Binary +import Distribution.ModuleName +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks +import Distribution.Simple.Utils + +import Data.Foldable ( for_ ) +import Data.List ( isPrefixOf ) +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) +import Data.String +import Data.Traversable ( for ) +import GHC.Generics + +import qualified Data.Map as Map +import System.FilePath + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) preBuildRules + } + } + +preBuildRules :: PreBuildComponentInputs -> RulesM () +preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = mdo + let verbosity = buildingWhatVerbosity what + clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + buildDir = i (componentBuildDir lbi clbi) + + computeC2HsDepsAction (C2HsDepsInput {..}) = do + importLine : _srcLines <- lines <$> readFile (inDir toFilePath modNm <.> "myChs") + let imports :: [ModuleName] + imports + | "imports:" `isPrefixOf` importLine + = map fromString $ words $ drop 8 importLine + | otherwise + = error "Malformed MyChs file: first line should start with 'imports:'" + warn verbosity $ "Computed C2Hs dependencies of " ++ modName modNm ++ ".myChs: " + ++ modNames imports + return $ + ( [ RuleDependency $ RuleOutput rId 1 + | imp <- imports + , let rId = ruleIds Map.! imp ] + , imports ) + + runC2HsAction (C2HsInput {..}) importModNms = do + let modPath = toFilePath modNm + warn verbosity $ "Running C2Hs on " ++ modName modNm ++ ".myChs.\n C2Hs dependencies: " ++ modNames importModNms + _importLine : srcLines <- lines <$> readFile (inDir modPath <.> "myChs") + + rewriteFileEx verbosity (hsDir modPath <.> "hs") $ + unlines $ ("module " ++ modName modNm ++ " where\n") : + (map ( ( "import " ++ ) . modName ) importModNms ++ srcLines) + rewriteFileEx verbosity (chiDir modPath <.> "myChi") "" + + mkRule modNm = + dynamicRule (static Dict) + (mkCommand (static Dict) (static computeC2HsDepsAction) $ C2HsDepsInput { ruleIds = modToRuleId, ..}) + (mkCommand (static Dict) (static runC2HsAction) $ C2HsInput {hsDir = autogenDir, chiDir = buildDir, ..}) + [ FileDependency (inDir, modPath <.> "myChs") ] + ( ( autogenDir, modPath <.> "hs" ) NE.:| [ ( buildDir, modPath <.> "myChi" ) ] ) + where + modPath = toFilePath modNm + inDir = "." + + -- NB: in practice, we would get the module names by looking at the .cabal + -- file and performing a search for `.chs` files on disk, but for this test + -- we bake this in for simplicity. + let mods = Map.fromList [ ((ix, fromString modNm), ()) + | (ix, modNm) <- [ (0, "C"), (1, "A1"), (2, "B"), (3, "A2") ] ] + -- NB: the extra indices are to ensure the traversal happens in a particular order, + -- which ensures we correctly re-order rules to execute them in dependency order. + modToRuleId <- fmap (Map.mapKeys snd) $ flip Map.traverseWithKey mods $ \ (i, modNm) () -> + registerRule ("C2Hs " <> fromString (show i ++ " " ++ modName modNm)) $ mkRule modNm + return () + +-- | Input to C2Hs dependency computation +data C2HsDepsInput + = C2HsDepsInput + { verbosity :: Verbosity + , inDir :: FilePath + , modNm :: ModuleName + , ruleIds :: Map.Map ModuleName RuleId + } + deriving stock ( Show, Generic ) + deriving anyclass Binary + +-- | Input to C2Hs command +data C2HsInput + = C2HsInput + { verbosity :: Verbosity + , modNm :: ModuleName + , inDir :: FilePath + , hsDir :: FilePath + , chiDir :: FilePath + } + deriving stock ( Show, Generic ) + deriving anyclass Binary + +modName :: ModuleName -> String +modName = intercalate "." . components + +modNames :: [ModuleName] -> String +modNames mns = "[" ++ intercalate ", " (map modName mns) ++ "]" diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/X.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/X.hs new file mode 100644 index 00000000000..823630037be --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/X.hs @@ -0,0 +1,4 @@ +module X where + +x :: Double +x = 123456789 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup-hooks-c2hs-rules-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup-hooks-c2hs-rules-test.cabal new file mode 100644 index 00000000000..e0627cb71b4 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup-hooks-c2hs-rules-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-c2hs-rules-test +version: 0.1.0.0 +synopsis: Test implementing a C2Hs-like preprocessor +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal, Cabal-hooks, base, filepath, containers + +library + exposed-modules: A1, A2, B, C, D, X + autogen-modules: A1, A2, B, C, D, X + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.out new file mode 100644 index 00000000000..11c1647571b --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.out @@ -0,0 +1,17 @@ +# Setup configure +Configuring setup-hooks-c2hs-rules-test-0.1.0.0... +# Setup build +Warning: Computed C2Hs dependencies of C.myChs: [B] +Warning: Computed C2Hs dependencies of A1.myChs: [] +Warning: Computed C2Hs dependencies of B.myChs: [A1, A2] +Warning: Computed C2Hs dependencies of A2.myChs: [] +Warning: Running C2Hs on A2.myChs. + C2Hs dependencies: [] +Warning: Running C2Hs on A1.myChs. + C2Hs dependencies: [] +Warning: Running C2Hs on B.myChs. + C2Hs dependencies: [A1, A2] +Warning: Running C2Hs on C.myChs. + C2Hs dependencies: [B] +Preprocessing library for setup-hooks-c2hs-rules-test-0.1.0.0... +Building library for setup-hooks-c2hs-rules-test-0.1.0.0... diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.test.hs new file mode 100644 index 00000000000..2df426a5dbf --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/SetupHooks.hs new file mode 100644 index 00000000000..65067ebff97 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/SetupHooks.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) cyclicPreBuildRules + } + } + +cyclicPreBuildRules :: PreBuildComponentInputs -> RulesM () +cyclicPreBuildRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = mdo + let clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + action = mkCommand (static Dict) (static (\ () -> error "This should not run")) () + r1 <- registerRule "r1" $ + staticRule action + [ RuleDependency $ RuleOutput r2 0 ] + ( ( autogenDir, "G1.hs" ) NE.:| [] ) + r2 <- registerRule "r2" $ + staticRule action + [ RuleDependency $ RuleOutput r1 0 ] + ( ( autogenDir, "G2.hs" ) NE.:| [] ) + r3 <- registerRule "r3" $ + staticRule action + [ RuleDependency $ RuleOutput r3 0 ] + ( ( autogenDir, "G3.hs" ) NE.:| [] ) + return () diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup-hooks-cyclic-rules-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup-hooks-cyclic-rules-test.cabal new file mode 100644 index 00000000000..c0d3e0b9481 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup-hooks-cyclic-rules-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-cyclic-rules-test +version: 0.1.0.0 +synopsis: Test for cyclic rules +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + exposed-modules: G1, G2 + autogen-modules: G1, G2 + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.out new file mode 100644 index 00000000000..5076d3b207b --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.out @@ -0,0 +1,11 @@ +# Setup configure +Configuring setup-hooks-cyclic-rules-test-0.1.0.0... +# Setup build +Error: [Cabal-9077] +Hooks: cycles in dependency structure of rules: + Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r3"})[0]] --> [setup.dist/work/dist/build/autogen/G3.hs] + + Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r2"})[0]] --> [setup.dist/work/dist/build/autogen/G1.hs] + | + `- Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r1"})[0]] --> [setup.dist/work/dist/build/autogen/G2.hs] + diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.test.hs new file mode 100644 index 00000000000..370c60bd0f1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + fails $ setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/SetupHooks.hs new file mode 100644 index 00000000000..b7ac707e627 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/SetupHooks.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.SetupHooks + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) dupRuleIdRules + } + } + +dupRuleIdRules :: PreBuildComponentInputs -> RulesM () +dupRuleIdRules _ = do + let cmd = mkCommand (static Dict) (static (\ _ -> error "This should not run")) () + registerRule_ "myRule" $ staticRule cmd [] ( ( "src", "A.hs" ) NE.:| [] ) + registerRule_ "myRule" $ staticRule cmd [] ( ( "src", "B.hs" ) NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup-hooks-duplicate-rule-id-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup-hooks-duplicate-rule-id-test.cabal new file mode 100644 index 00000000000..ff982ea9abf --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup-hooks-duplicate-rule-id-test.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.14 +name: setup-hooks-duplicate-rule-id-test +version: 0.1.0.0 +synopsis: Test duplicate rule ids +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.out new file mode 100644 index 00000000000..2a5f2e99d6f --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring setup-hooks-duplicate-rule-id-test-0.1.0.0... +# Setup build +Error: [Cabal-7717] +Duplicate pre-build rule (RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (17,59)}, ruleName = "myRule"}) + - Rule: [] --> [src/A.hs] + - Rule: [] --> [src/B.hs] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.test.hs new file mode 100644 index 00000000000..370c60bd0f1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + fails $ setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs new file mode 100644 index 00000000000..0949aff5b89 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks +import Distribution.Simple.Utils ( rewriteFileEx ) + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) +import System.FilePath + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) invalidRuleOutputIndexRules + } + } + +invalidRuleOutputIndexRules :: PreBuildComponentInputs -> RulesM () +invalidRuleOutputIndexRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = do + let clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + verbosity = buildingWhatVerbosity what + action = mkCommand (static Dict) $ static (\ ((dir, modNm), verb) -> do + let loc = dir modNm <.> "hs" + rewriteFileEx verb loc $ + "module " ++ modNm ++ " where {}" + ) + + r1 <- registerRule "r1" $ + staticRule + (action ((autogenDir, "A"), verbosity)) + [] ( ( autogenDir, "A.hs" ) NE.:| [] ) + registerRule_ "r2" $ + staticRule (action ((autogenDir, "B"), verbosity)) + [ RuleDependency $ RuleOutput r1 7 ] + ( ( autogenDir, "B.hs" ) NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup-hooks-invalid-rule-output-index-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup-hooks-invalid-rule-output-index-test.cabal new file mode 100644 index 00000000000..8bb8a6ed2c6 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup-hooks-invalid-rule-output-index-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-invalid-rule-output-index-test +version: 0.1.0.0 +synopsis: Test for an invalid rule output index +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + build-depends: base + default-language: Haskell2010 + autogen-modules: A, B + exposed-modules: A, B diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.out new file mode 100644 index 00000000000..82f5148e9b9 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.out @@ -0,0 +1,6 @@ +# Setup configure +Configuring setup-hooks-invalid-rule-output-index-test-0.1.0.0... +# Setup build +Error: [Cabal-1173] +Invalid index '7' in dependency of RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (20,59)}, ruleName = "r2"}. +The dependency RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (20,59)}, ruleName = "r1"} only has 1 output. diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.test.hs new file mode 100644 index 00000000000..370c60bd0f1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + fails $ setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/SetupHooks.hs new file mode 100644 index 00000000000..47ff3296163 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/SetupHooks.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) missingDepRules + } + } + +missingDepRules :: PreBuildComponentInputs -> RulesM () +missingDepRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = do + let clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + action = mkCommand (static Dict) (static (\ _ -> error "This should not run")) () + registerRule_ "r" $ + staticRule action + [ FileDependency ( ".", "Missing.hs" ) ] + ( ( autogenDir, "G.hs" ) NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup-hooks-missing-rule-dep-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup-hooks-missing-rule-dep-test.cabal new file mode 100644 index 00000000000..a0c841913b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup-hooks-missing-rule-dep-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-missing-rule-dep-test +version: 0.1.0.0 +synopsis: Test for missing dependency in rules +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + exposed-modules: G + autogen-modules: G + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.out new file mode 100644 index 00000000000..bfbd911994d --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.out @@ -0,0 +1,6 @@ +# Setup configure +Configuring setup-hooks-missing-rule-dep-test-0.1.0.0... +# Setup build +Error: [Cabal-1071] +Pre-build rules: can't find source for rule dependency: + - Missing.hs diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.test.hs new file mode 100644 index 00000000000..370c60bd0f1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + fails $ setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/SetupHooks.hs new file mode 100644 index 00000000000..6b5ce60dd81 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/SetupHooks.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) missingResRules + } + } + +missingResRules :: PreBuildComponentInputs -> RulesM () +missingResRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = do + let clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + action = mkCommand (static Dict) (static (\ _ -> return ())) () + registerRule_ "r" $ + staticRule action + [ ] + ( ( autogenDir, "G.hs" ) NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup-hooks-missing-rule-res-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup-hooks-missing-rule-res-test.cabal new file mode 100644 index 00000000000..b4783b483df --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup-hooks-missing-rule-res-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-missing-rule-res-test +version: 0.1.0.0 +synopsis: Test for missing result in rules +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + exposed-modules: G + autogen-modules: G + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.out new file mode 100644 index 00000000000..5659bca63e1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.out @@ -0,0 +1,6 @@ +# Setup configure +Configuring setup-hooks-missing-rule-res-test-0.1.0.0... +# Setup build +Error: [Cabal-3498] +Pre-build rule did not generate expected result: + - setup.dist/work/dist/build/autogen/G.hs diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.test.hs new file mode 100644 index 00000000000..370c60bd0f1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + fails $ setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/A.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/A.hs new file mode 100644 index 00000000000..2f20e91a6c1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/A.hs @@ -0,0 +1 @@ +module A where {} diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs new file mode 100644 index 00000000000..a301e71cff0 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks +import Distribution.Simple.Utils ( rewriteFileEx, warn ) + +import Data.Foldable ( for_ ) +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) +import Data.Traversable ( for ) + +import System.FilePath + ( (<.>), () ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) preBuildRules + } + } + +-- Register three rules: +-- +-- r1: B --> C +-- r2: A --> B +-- r3: C --> D +-- +-- and check that we run them in dependency order, i.e. r2, r1, r3. +preBuildRules :: PreBuildComponentInputs -> RulesM () +preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = mdo + let verbosity = buildingWhatVerbosity what + clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + + mkAction = + mkCommand (static Dict) $ static (\ (dir, verb, (inMod, outMod)) -> do + warn verb $ "Running rule: " ++ inMod ++ " --> " ++ outMod + let loc = dir outMod <.> "hs" + rewriteFileEx verb loc $ + "module " ++ outMod ++ " where { import " ++ inMod ++ " }" + ) + + actionArg inMod outMod = (autogenDir, verbosity, (inMod, outMod)) + + mkRule action input outMod = + staticRule action + [ input ] + ( ( autogenDir, outMod <.> "hs" ) NE.:| [] ) + + r1 <- registerRule "r1" $ mkRule (mkAction (actionArg "B" "C")) (RuleDependency $ RuleOutput r2 0) "C" -- B --> C + r2 <- registerRule "r2" $ mkRule (mkAction (actionArg "A" "B")) (FileDependency (".", "A.hs")) "B" -- A --> B + r3 <- registerRule "r3" $ mkRule (mkAction (actionArg "C" "D")) (RuleDependency $ RuleOutput r1 0) "D" -- C --> D + return () diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup-hooks-rule-ordering-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup-hooks-rule-ordering-test.cabal new file mode 100644 index 00000000000..f3885717b5d --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup-hooks-rule-ordering-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-rule-ordering-test +version: 0.1.0.0 +synopsis: Test that we execute pre-build rules in the correct order +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal, Cabal-hooks, base, filepath + +library + exposed-modules: A, B, C, D + autogen-modules: B, C, D + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.out new file mode 100644 index 00000000000..ccc3b1e7489 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.out @@ -0,0 +1,8 @@ +# Setup configure +Configuring setup-hooks-rule-ordering-test-0.1.0.0... +# Setup build +Warning: Running rule: A --> B +Warning: Running rule: B --> C +Warning: Running rule: C --> D +Preprocessing library for setup-hooks-rule-ordering-test-0.1.0.0... +Building library for setup-hooks-rule-ordering-test-0.1.0.0... diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.test.hs new file mode 100644 index 00000000000..2df426a5dbf --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/SetupHooks.hs new file mode 100644 index 00000000000..e1d2141aa61 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/SetupHooks.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) unusedPreBuildRules + } + } + +unusedPreBuildRules :: PreBuildComponentInputs -> RulesM () +unusedPreBuildRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = do + let clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + action = mkCommand (static Dict) (static (\ _ -> error "This should not run")) () + registerRule_ "r1" $ + staticRule action [] + ( ( autogenDir, "X.hs" ) NE.:| [ ( autogenDir, "Y.hs" ) ] ) + registerRule_ "r2" $ + staticRule action [] + ( ( autogenDir, "Z.what" ) NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup-hooks-unused-rules-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup-hooks-unused-rules-test.cabal new file mode 100644 index 00000000000..380a6273b45 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup-hooks-unused-rules-test.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.14 +name: setup-hooks-unused-rules-test +version: 0.1.0.0 +synopsis: Test for unused pre-build rules +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out new file mode 100644 index 00000000000..b5b0f048ce6 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out @@ -0,0 +1,13 @@ +# Setup configure +Configuring setup-hooks-unused-rules-test-0.1.0.0... +# Setup build +Warning: The following rules are not demanded and will not be run: + - RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r1"}, generating [setup.dist/work/dist/build/autogen/X.hs, setup.dist/work/dist/build/autogen/Y.hs] + - RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r2"}, generating [setup.dist/work/dist/build/autogen/Z.what] +Possible reasons for this error: + - Some autogenerated modules were not declared + (in the package description or in the pre-configure hooks) + - The output location for an autogenerated module is incorrect, + (e.g. it is not in the appropriate 'autogenComponentModules' directory) +Preprocessing library for setup-hooks-unused-rules-test-0.1.0.0... +Building library for setup-hooks-unused-rules-test-0.1.0.0... diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.test.hs new file mode 100644 index 00000000000..2df426a5dbf --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + setup "build" [] diff --git a/cabal-testsuite/cabal-testsuite.cabal b/cabal-testsuite/cabal-testsuite.cabal index 4fdd0e51e7c..56b62690268 100644 --- a/cabal-testsuite/cabal-testsuite.cabal +++ b/cabal-testsuite/cabal-testsuite.cabal @@ -126,9 +126,11 @@ executable test-runtime-deps build-depends: , Cabal , Cabal-syntax + , Cabal-hooks , base , bytestring , cabal-testsuite + , containers , directory , exceptions , filepath diff --git a/cabal-testsuite/src/Test/Cabal/Server.hs b/cabal-testsuite/src/Test/Cabal/Server.hs index d6906a6d416..76387a2bae1 100644 --- a/cabal-testsuite/src/Test/Cabal/Server.hs +++ b/cabal-testsuite/src/Test/Cabal/Server.hs @@ -42,6 +42,9 @@ import qualified GHC.IO.Exception as GHC import Distribution.Verbosity import System.Process.Internals + ( ProcessHandle__( OpenHandle ) + , withProcessHandle + ) #if mingw32_HOST_OS import qualified System.Win32.Process as Win32 #endif diff --git a/changelog.d/pr-9551 b/changelog.d/pr-9551 new file mode 100644 index 00000000000..5116234a653 --- /dev/null +++ b/changelog.d/pr-9551 @@ -0,0 +1,19 @@ +synopsis: Introduce SetupHooks +packages: Cabal +prs: #9551 +description: { + Introduction of a new build type: Hooks. + This build type, intended as replacement to the Custom build type, integrates + better with the rest of the ecosystem (`cabal-install`, Haskell Language Server). + + The motivation and full design of this new build-type are specified in the + Haskell Foundation Tech Proposal + [Replacing the Cabal Custom build-type](https://github.com/haskellfoundation/tech-proposals/pull/60). + + Package authors willing to use this feature should declare `build-type: Hooks` + in their `.cabal` file, declare a custom-setup stanza with a dependency on the + `Cabal-hooks` package, and define a module `SetupHooks` that exports a value + `setupHooks :: SetupHooks`, using the API exported by `Distribution.Simple.SetupHooks` + from the `Cabal-hooks` package. Refer to the Haddock documentation of + `Distribution.Simple.SetupHooks` for example usage. +} diff --git a/doc/buildinfo-fields-reference.rst b/doc/buildinfo-fields-reference.rst index dd8c505a85e..c1ccf418f81 100644 --- a/doc/buildinfo-fields-reference.rst +++ b/doc/buildinfo-fields-reference.rst @@ -535,7 +535,7 @@ build-type * Documentation of :pkg-field:`build-type` .. math:: - \left\{ \begin{gathered}\mathop{\mathord{``}\mathtt{Simple}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Configure}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Custom}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Make}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Default}\mathord{"}}\end{gathered} \right\} + \left\{ \begin{gathered}\mathop{\mathord{``}\mathtt{Simple}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Configure}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Custom}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Hooks}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Make}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Default}\mathord{"}}\end{gathered} \right\} cabal-version * Optional field diff --git a/doc/cabal-package-description-file.rst b/doc/cabal-package-description-file.rst index 652746b216a..9ec167364e0 100644 --- a/doc/cabal-package-description-file.rst +++ b/doc/cabal-package-description-file.rst @@ -441,6 +441,14 @@ describe the package as a whole: import Distribution.Simple main = defaultMain + For build type ``Hooks``, the contents of ``Setup.hs`` must be: + + .. code-block:: haskell + + import Distribution.Simple + import SetupHooks (setupHooks) + main = defaultMainWithSetupHooks setupHooks + For build type ``Configure`` (see the section on `system-dependent parameters`_ below), the contents of ``Setup.hs`` must be: @@ -461,7 +469,8 @@ describe the package as a whole: For build type ``Custom``, the file ``Setup.hs`` can be customized, and will be used both by ``cabal`` and other tools. - For most packages, the build type ``Simple`` is sufficient. + For most packages, the build type ``Simple`` is sufficient. For more exotic + needs, the ``Hooks`` build type is recommended; see :ref:`setup-hooks`. .. pkg-field:: license: SPDX expression @@ -1869,7 +1878,8 @@ system-dependent values for these fields. | ``hspec-discover`` | ``hspec-discover:hspec-discover`` | since Cabal 2.0 | +--------------------------+-----------------------------------+-----------------+ - This built-in set can be programmatically extended via ``Custom`` setup scripts; this, however, is of limited use since the Cabal solver cannot access information injected by ``Custom`` setup scripts. + This built-in set can be programmatically extended via use of the + :ref:`Hooks build type` . .. pkg-field:: buildable: boolean @@ -2783,9 +2793,64 @@ The exact fields are as follows: root directory of the repository. +.. _setup-hooks: + +Hooks +----- +The ``Hooks`` build type allows customising the configuration and the building +of a package using a collection of **hooks** into the build system. + +Introduced in Cabal 3.14, this build type provides an alternative +to :ref:`Custom setups ` which integrates better with the rest of the +Haskell ecosystem. + +To use this build type in your package, you need to: + + * Declare a ``cabal-version`` of at least 3.14 in your ``.cabal`` file. + * Declare ``build-type: Hooks`` in your ``.cabal`` file. + * Include a ``custom-setup`` stanza in your ``.cabal`` file, which declares + the version of the Hooks API your package is using. + * Define a ``SetupHooks.hs`` module next to your ``.cabal`` file. It must + export a value ``setupHooks :: SetupHooks``. + +More specifically, your ``.cabal`` file should resemble the following: + + .. code-block:: cabal + + cabal-version: 3.14 + build-type: Hooks + + custom-setup: + setup-depends: + base >= 4.18 && < 5, + Cabal-hooks >= 0.1 && < 0.2 + +while a basic ``SetupHooks.hs`` file might look like the following: + + .. code-block:: haskell + + module SetupHooks where + import Distribution.Simple.SetupHooks ( SetupHooks, noSetupHooks ) + + setupHooks :: SetupHooks + setupHooks = + noSetupHooks + { configureHooks = myConfigureHooks + , buildHooks = myBuildHooks } + + -- ... + +Refer to the `Hackage documentation for the Distribution.Simple.SetupHooks module `__ +for an overview of the ``Hooks`` API. Further motivation and a technical overview +of the design is available in `Haskell Tech Proposal #60 `__ . + +.. _custom-setup: + Custom setup scripts -------------------- +Deprecated since Cabal 3.14: prefer using the :ref:`Hooks build type` instead. + Since Cabal 1.24, custom ``Setup.hs`` are required to accurately track their dependencies by declaring them in the ``.cabal`` file rather than rely on dependencies being implicitly in scope. Please refer to @@ -2801,11 +2866,12 @@ Declaring a ``custom-setup`` stanza also enables the generation of ``MIN_VERSION_package_(A,B,C)`` CPP macros for the Setup component. .. pkg-section:: custom-setup - :synopsis: Custom Setup.hs build information. + :synopsis: Build information for ``Custom`` and ``Hooks`` build types :since: 1.24 - The optional :pkg-section:`custom-setup` stanza contains information needed - for the compilation of custom ``Setup.hs`` scripts, + The :pkg-section:`custom-setup` stanza contains information needed + for the compilation of custom ``Setup.hs`` scripts as well as for + ``SetupHooks.hs`` hooks modules. :: diff --git a/project-cabal/pkgs/cabal.config b/project-cabal/pkgs/cabal.config index 2500cad5ecf..3c1d897705d 100644 --- a/project-cabal/pkgs/cabal.config +++ b/project-cabal/pkgs/cabal.config @@ -2,3 +2,4 @@ packages: Cabal , Cabal-described , Cabal-syntax + , Cabal-hooks diff --git a/validate.sh b/validate.sh index 9edc87eeaf3..be167d40d43 100755 --- a/validate.sh +++ b/validate.sh @@ -280,7 +280,7 @@ if [ -z "$STEPS" ]; then STEPS="$STEPS time-summary" fi -TARGETS="Cabal cabal-testsuite Cabal-tests Cabal-QuickCheck Cabal-tree-diff Cabal-described" +TARGETS="Cabal Cabal-hooks cabal-testsuite Cabal-tests Cabal-QuickCheck Cabal-tree-diff Cabal-described" if ! $LIBONLY; then TARGETS="$TARGETS cabal-install cabal-install-solver cabal-benchmarks"; fi if $BENCHMARKS; then TARGETS="$TARGETS solver-benchmarks"; fi