diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs
index 8c1c501cf95a426cf7828fcc86daea26d7d63511..717fd6a5c7a0ca482600a066062aebf32f13c6cb 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 0000000000000000000000000000000000000000..e9768013129e50ea18cba9323c07434a6b4e4a05
--- /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 <cabal-devel@haskell.org>
+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 0000000000000000000000000000000000000000..c134f098c03e2c6d54baa9d41037881663e24f20
--- /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 0000000000000000000000000000000000000000..ea633b2936abe54f2b8e0fdb7161a4798eee2563
--- /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 0000000000000000000000000000000000000000..9304784efe6fb0d19777e160e796df6f9a5ac446
--- /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
index 3434ab275370220dcdf065d4602d344e6a628428..48929bd4ce54d0461f8683ca9a6c3decee7339fa 100644
--- a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs
+++ b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs
@@ -17,7 +17,8 @@ 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 to hook into the cabal build process.
+This is a record that declares actions that should be hooked into the
+cabal build process.
See 'SetupHooks' for more details.
-}
@@ -69,7 +70,7 @@ module Distribution.Simple.SetupHooks
, Rules
, rules
, noRules
- , Rule(..) -- See Note [Not hiding SetupHooks constructors]
+ , Rule
, Dependency (..)
, RuleOutput (..)
, RuleId
@@ -84,7 +85,7 @@ module Distribution.Simple.SetupHooks
-- *** Actions
, RuleCommands(..)
- , Command(..) -- See Note [Not hiding SetupHooks constructors]
+ , Command
, mkCommand
, Dict(..)
@@ -97,9 +98,7 @@ module Distribution.Simple.SetupHooks
-- **** File/directory monitoring
, addRuleMonitors
- , MonitorFilePath(..)
- , MonitorKindFile(..)
- , MonitorKindDir(..)
+ , module Distribution.Simple.FileMonitor.Types
-- * Install hooks
, InstallHooks(..), noInstallHooks
@@ -120,17 +119,27 @@ module Distribution.Simple.SetupHooks
-- | 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.
- , installFileGlob, addKnownPrograms
+
+ -- *** 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
- -- SetupHooks TODO: 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.
+ -- 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(..)
@@ -146,9 +155,6 @@ module Distribution.Simple.SetupHooks
, emptyLibrary, emptyForeignLib, emptyExecutable
, emptyTestSuite, emptyBenchmark
- -- ** Programs
- , Program, ConfiguredProgram, ProgramDb, ProgArg
-
)
where
import Distribution.PackageDescription
@@ -166,6 +172,7 @@ 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
@@ -173,9 +180,16 @@ import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PreProcess.Types
( Suffix(..) )
import Distribution.Simple.Program.Db
- ( ProgramDb, addKnownPrograms )
+ ( ProgramDb, addKnownPrograms
+ , configureUnconfiguredProgram
+ )
+import Distribution.Simple.Program.Find
+ ( simpleProgram )
import Distribution.Simple.Program.Types
- ( Program, ConfiguredProgram, ProgArg )
+ ( Program(..), ConfiguredProgram(..)
+ , ProgArg
+ , ProgramLocation(..)
+ )
import Distribution.Simple.Setup
( BuildFlags(..)
, ConfigFlags(..)
@@ -250,7 +264,9 @@ Usage example:
> custom-setup
> setup-depends:
> base >= 4.18 && < 5,
-> Cabal-hooks >= 0.1 && < 0.3
+> 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
@@ -304,26 +320,31 @@ For example, to generate modules inside a given component, you should:
-}
{- $preBuildRules
-Pre-build hooks are specified in the form of a collection of pre-build 'Rules'.
+Pre-build hooks are specified as a collection of pre-build 'Rules'.
+Each t'Rule' consists of:
-Pre-build rules are specified as a collection of rules. Each t'Rule' declares
-its dependencies, its outputs, and refers to a command to run in order to
-execute the rule in the form of a t'RuleCommands'.
+ - 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:
- - file dependencies are not specified directly by 'FilePath' but rather use
- the 'Location' type,
- - rules can directly depend on other rules, which requires the ability to
- refer to a rule by 'RuleId',
- - 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
+ - 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.
-
-To construct a t'Rule', you should use one of the 'staticRule' or 'dynamicRule'
-smart constructors, to avoid relying on internal implementation details of
-the t'Rule' datatype.
-}
{- $rulesDemand
@@ -331,7 +352,7 @@ 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,
- - 'MonitoredFileOrDir': additional files or directories to monitor.
+ - 'MonitorFilePath': additional files and directories to monitor.
Rules are considered __out-of-date__ precisely when any of the following
conditions apply:
@@ -371,17 +392,15 @@ Defining pre-build rules can be done in the following style:
> {-# LANGUAGE BlockArguments, StaticPointers #-}
> myPreBuildRules :: PreBuildComponentRules
-> myPreBuildRules = rules $ static myRulesFromEnv
-> where
-> myRulesFromEnv preBuildEnvironment = do
-> let cmd1 = mkCommand (static Dict) $ static \ arg -> do { .. }
-> cmd2 = mkCommand (static Dict) $ static \ arg -> do { .. }
-> myData <- liftIO someIOAction
-> addRuleMonitors [ MonitorDir "someSearchDir" DirContents ]
-> registerRule_ $ staticRule (cmd1 arg1) deps1 outs1
-> registerRule_ $ staticRule (cmd1 arg2) deps2 outs2
-> registerRule_ $ staticRule (cmd1 arg3) deps3 outs3
-> registerRule_ $ staticRule (cmd2 arg4) deps4 outs4
+> 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,
@@ -413,12 +432,12 @@ registerRule
:: ShortText -- ^ user-given rule name;
-- these should be unique on a per-package level
-> Rule -- ^ the rule to register
- -> RulesT IO RuleId
+ -> RulesM RuleId
registerRule nm !newRule = RulesT $ do
- RulesEnv { rulesEnvUnitId = unitId
+ RulesEnv { rulesEnvNameSpace = ns
, rulesEnvVerbosity = verbosity } <- Reader.ask
oldRules <- lift $ State.get
- let rId = RuleId { ruleUnitId = unitId, ruleName = nm }
+ let rId = RuleId { ruleNameSpace = ns, ruleName = nm }
(mbDup, newRules) = Map.insertLookupWithKey (\ _ new _old -> new) rId newRule oldRules
for_ mbDup $ \ oldRule ->
liftIO $ dieWithException verbosity
@@ -456,5 +475,5 @@ findFileInDirs file dirs =
| path <- nub dirs
]
- -- SetupHooks TODO: add API functions that do searching and declare
- -- the appropriate monitoring at the same time.
+ -- 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 eb029b5ffc9a8996208ac56f973b8d85452e8244..3d1f9418e4a25a8b74e4b0d981c63af2659b5370 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 cd299b87675488ef18793981d85f92207482bf5d..ae4c0cfec6b509150ae439a15ccb6c0daecaf931 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 ba6cb0284a3ee79b2fcf3ba0c2f7d861c3eaab2d..88280ca56f9ee62256862d3104b2eee98ffad245 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 e80770843f3514a054c90cbd4c4e2d0491ad5050..b94279eaf2e67fbbe0a8a929361d53a61153e02f 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 2bc8e206666914b55ca91f79ea15ad0097879b5a..9b36dd9d7ce7ddd9dc2c4a4d1fb1b1fabb9e2f34 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 2e9a6b765a60abdc17ba368202a9cb97dcc94d9a..6b35ac92e128fa5e9fc9faafaf4d200b9bcda0cc 100644
--- a/Cabal/Cabal.cabal
+++ b/Cabal/Cabal.cabal
@@ -149,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 f444a4c23fe8e6fbb54a1a3aa85dc64945ac6f52..ef97b0d23be9f2678ca4d14b890e8bf44caea1ae 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 657e37cbbc108edc45bf5bcbc6522cc088ba7196..85eabcbe93cd99f14a9585d496b826ffe1a1f6d0 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 da4788adce0f020221290232b648fbc848d97efc..3d22f2dc42d943d3ee8f134743abc49047b73f16 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 e4e40b5fb5f51c02f7850bfff20c31196c86d498..a198f3d2f4f584e54b145787c16177a64a67cabf 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 0a788af830c5f707ef999eb674353b6e263b806b..3dfe0b7e0bede0951917245727b651b70ae364a9 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 1ca8c97c6c6832df46bf21c7b1f23cb82e59f1bb..45029565e9966f61d257ea6b5202d948a2bf3baf 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/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs
index 50a88d6745a84521b7215f33eaf6efa7a155b7b4..8798d7a8578548d6227ad0295a5bf910d844ee07 100644
--- a/Cabal/src/Distribution/Simple/Glob.hs
+++ b/Cabal/src/Distribution/Simple/Glob.hs
@@ -66,7 +66,7 @@ import Distribution.Verbosity
import Control.Monad (mapM)
import Data.List (stripPrefix)
import System.Directory
-import System.FilePath
+import System.FilePath hiding ((<.>), (</>))
-------------------------------------------------------------------------------
diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs
index a63b9195b67b4e5fb237e20f4104e0aa4c2d19ce..3b801fd7b34f05773a906b53b498705121682a9a 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 d09c970ae32f032c14edc5a0ad150bc178929fdb..c1134e2b35508ff8640d069e7d4c50bd48dd60b7 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,6 +20,7 @@
-- compiler-specific functions to do the rest.
module Distribution.Simple.Install
( install
+ , install_setupHooks
, installFileGlob
) where
@@ -50,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
@@ -98,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
diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs
index 160b81fd4de682588ed7df313fb8544a7b41025d..00e6e68cb5c014fed618cb2d3c15001d3bf432f2 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 5315d3b1ac7d029a5fabfd33a7f8d6ad8aaaf5ed..5b865349e789b15c3a1ab2f19ce4084ce86db43f 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 a5e4e4ab381554f441516ff540227e0385b83010..1dda83a6b4e380673b07d9b857ba67c48a3c37f9 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 861cf16095cbdfff9b46bd1ce422335d6cde4a7c..dfde4466b30669362aa3b372536997cf948eb8fa 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 0000000000000000000000000000000000000000..11577f3506ba7e8d0ea821c806beef6d4bd4afbc
--- /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 0000000000000000000000000000000000000000..25e2f39b1ad5d65c608d2259784ce95fc84765a1
--- /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
index 7e750245085f7dad333b38f180dd0bbd73d4ccff..afbabb859f60f7541270d24c745905daaa13631e 100644
--- a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs
+++ b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs
@@ -1,8 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
@@ -10,11 +13,14 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
@@ -26,14 +32,16 @@ module Distribution.Simple.SetupHooks.Rule
( -- * Rules
-- ** Rule
- Rule (..)
+ Rule
+ , RuleData (..)
, RuleId (..)
, staticRule
, dynamicRule
-- ** Commands
, RuleCommands (..)
- , Command (..)
+ , Command
+ , CommandData (..)
, runCommand
, mkCommand
, Dict (..)
@@ -69,12 +77,22 @@ module Distribution.Simple.SetupHooks.Rule
, 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
@@ -105,12 +123,12 @@ import qualified Data.Map.Strict as Map
)
import qualified Data.Kind as Hs
-import Data.Type.Equality
- ( (:~:) (Refl)
- , (:~~:) (HRefl)
+import Data.Type.Bool
+ ( If
)
-import Data.Typeable
- ( eqT
+import Data.Type.Equality
+ ( (:~~:) (HRefl)
+ , type (==)
)
import GHC.Show (showCommaSpace)
import GHC.StaticPtr
@@ -124,6 +142,7 @@ import qualified Type.Reflection as Typeable
, typeRep
, typeRepKind
, withTypeable
+ , pattern App
)
--------------------------------------------------------------------------------
@@ -158,12 +177,53 @@ a separate executable which can be invoked in the manner described above.
-- | A unique identifier for a t'Rule'.
data RuleId = RuleId
- { ruleUnitId :: !UnitId
+ { 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,
@@ -171,33 +231,61 @@ data RuleId = RuleId
--
-- Use 'staticRule' or 'dynamicRule' to construct a rule, overriding specific
-- fields, rather than directly using the 'Rule' constructor.
-data Rule
+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
+ { 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 (Show, Eq, Generic)
- deriving anyclass (Binary)
+ 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
- :: Typeable arg
+ :: forall arg
+ . Typeable arg
=> Command arg (IO ())
-> [Dependency]
-> NE.NonEmpty Location
-> Rule
staticRule cmd dep res =
Rule
- { ruleCommands = StaticRuleCommand{staticRuleCommand = cmd}
+ { ruleCommands =
+ StaticRuleCommand
+ { staticRuleCommand = cmd
+ , staticRuleArgRep = Typeable.typeRep @arg
+ }
, staticDependencies = dep
, results = res
}
@@ -206,7 +294,8 @@ staticRule cmd dep res =
--
-- Prefer using this smart constructor instead of v'Rule' whenever possible.
dynamicRule
- :: (Typeable depsArg, Typeable depsRes, Typeable arg)
+ :: 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 ())
@@ -217,9 +306,10 @@ dynamicRule dict depsCmd action dep res =
Rule
{ ruleCommands =
DynamicRuleCommands
- { dynamicRuleInstances = dict
+ { dynamicRuleInstances = UserStatic dict
, dynamicDeps = DynDepsCmd{dynDepsCmd = depsCmd}
, dynamicRuleCommand = action
+ , dynamicRuleTypeRep = Typeable.typeRep @(depsArg, depsRes, arg)
}
, staticDependencies = dep
, results = res
@@ -284,7 +374,7 @@ type RulesM a = RulesT IO a
-- | The environment within the monadic API.
data RulesEnv = RulesEnv
{ rulesEnvVerbosity :: !Verbosity
- , rulesEnvUnitId :: !UnitId
+ , rulesEnvNameSpace :: !RulesNameSpace
}
-- | Monad transformer for defining rules. Usually wraps the 'IO' monad,
@@ -333,25 +423,38 @@ instance Monoid (Rules env) where
noRules :: RulesM ()
noRules = return ()
--- | Construct a collection of rules.
+-- | 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.
--
--- Usage:
+-- Example usage:
--
-- > myRules :: Rules env
--- > myRules = rules $ static f
--- > where
--- > f :: env -> RulesM ()
--- > f env = do { ... } -- use the monadic API here
+-- > myRules = rules (static ()) $ \ env -> do { .. } -- use the monadic API here
rules
- :: StaticPtr (env -> RulesM ())
- -- ^ a static computation of rules
+ :: StaticPtr label
+ -- ^ unique label for this collection of rules
+ -> (env -> RulesM ())
+ -- ^ the computation of rules
-> Rules env
-rules f = Rules $ \env -> RulesT $ do
- Reader.withReaderT (\rulesEnv -> rulesEnv{rulesEnvUnitId = unitId}) $
- runRulesT $
- deRefStaticPtr f env
- where
- unitId = mkUnitId $ spInfoUnitId $ staticPtrInfo f
+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.
@@ -361,13 +464,18 @@ computeRules
-> Rules env
-> IO (Map RuleId Rule, [MonitorFilePath])
computeRules verbosity inputs (Rules rs) = do
- -- Bogus UnitId to start with. This will be the first thing
+ -- Bogus namespace to start with. This will be the first thing
-- to be set when users use the 'rules' smart constructor.
- let noUnitId = mkUnitId ""
+ let noNameSpace =
+ RulesNameSpace
+ { rulesUnitId = mkUnitId ""
+ , rulesModuleName = fromString ""
+ , rulesSrcLoc = (0, 0)
+ }
env0 =
RulesEnv
{ rulesEnvVerbosity = verbosity
- , rulesEnvUnitId = noUnitId
+ , rulesEnvNameSpace = noNameSpace
}
Writer.runWriterT $
(`State.execStateT` Map.empty) $
@@ -378,18 +486,51 @@ computeRules verbosity inputs (Rules rs) = do
------------
-- 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.
-data Command arg res = Command
- { actionPtr :: !(StaticPtr (arg -> res))
+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 :: !arg
+ , actionArg :: !(ScopedArgument scope arg)
-- ^ The (possibly dynamic) argument to pass to the action.
- , cmdInstances :: !(StaticPtr (Dict (Binary arg, Show arg)))
+ , cmdInstances :: !(Static scope (Dict (Binary arg, Show arg)))
-- ^ Static evidence that the argument can be serialised and deserialised.
}
@@ -404,14 +545,14 @@ mkCommand
-> Command arg res
mkCommand dict actionPtr arg =
Command
- { actionPtr = actionPtr
- , actionArg = arg
- , cmdInstances = dict
+ { actionPtr = UserStatic actionPtr
+ , actionArg = ScopedArgument arg
+ , cmdInstances = UserStatic dict
}
-- | Run a 'Command'.
runCommand :: Command args res -> res
-runCommand (Command{actionPtr = ptr, actionArg = arg}) =
+runCommand (Command{actionPtr = UserStatic ptr, actionArg = ScopedArgument arg}) =
deRefStaticPtr ptr arg
-- | Commands to execute a rule:
@@ -421,21 +562,30 @@ runCommand (Command{actionPtr = ptr, actionArg = arg}) =
-- dependencies, and a command for executing the rule.
data
RuleCommands
- (deps :: Hs.Type -> Hs.Type -> Hs.Type)
- (ruleCmd :: Hs.Type -> Hs.Type -> Hs.Type)
+ (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
- . Typeable arg
- => { staticRuleCommand :: !(ruleCmd arg (IO ()))
+ :: 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 deps ruleCmd
+ -> RuleCommands scope deps ruleCmd
DynamicRuleCommands
- :: forall depsArg depsRes arg deps ruleCmd
- . (Typeable depsArg, Typeable depsRes, Typeable arg)
- => { dynamicRuleInstances :: !(StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes)))
+ :: 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
@@ -444,82 +594,187 @@ data
-- 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 depsArg depsRes)
+ 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 arg (depsRes -> IO ()))
+ , 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 deps ruleCmd
+ -> 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 arg res = CmdOmitted
+data NoCmd (scope :: Scope) arg res = CmdOmitted
deriving stock (Generic, Eq, Ord, Show)
deriving anyclass (Binary)
-- | A dynamic dependency command.
-newtype DynDepsCmd depsArg depsRes = DynDepsCmd {dynDepsCmd :: Command depsArg (IO ([Dependency], depsRes))}
- deriving newtype (Show, Eq, Binary)
+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 depsArg depsRes = DepsRes {depsRes :: depsRes}
- deriving newtype (Show, Eq, Binary)
+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 = RuleCommands DynDepsCmd Command
+type RuleCmds scope = RuleCommands scope DynDepsCmd CommandData
-- | Only the (optional) dynamic dependency command.
-type RuleDynDepsCmd = RuleCommands DynDepsCmd NoCmd
+type RuleDynDepsCmd scope = RuleCommands scope DynDepsCmd NoCmd
-- | The rule command together with the result of the (optional) dynamic
-- dependency computation.
-type RuleExecCmd = RuleCommands DepsRes Command
+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 -> RuleDynDepsCmd
+ruleDepsCmd :: RuleCmds scope -> RuleDynDepsCmd scope
ruleDepsCmd = \case
- StaticRuleCommand{staticRuleCommand = _ :: Command args (IO ())} ->
- StaticRuleCommand{staticRuleCommand = CmdOmitted :: NoCmd args (IO ())}
+ StaticRuleCommand
+ { staticRuleCommand = _ :: CommandData scope args (IO ())
+ , staticRuleArgRep = tr
+ } ->
+ StaticRuleCommand
+ { staticRuleCommand = CmdOmitted :: NoCmd scope args (IO ())
+ , staticRuleArgRep = tr
+ }
DynamicRuleCommands
- { dynamicRuleCommand = _ :: Command args (depsRes -> IO ())
+ { dynamicRuleCommand = _ :: CommandData scope args (depsRes -> IO ())
, dynamicRuleInstances = instsPtr
, dynamicDeps = deps
+ , dynamicRuleTypeRep = tr
} ->
DynamicRuleCommands
{ dynamicRuleInstances = instsPtr
, dynamicDeps = deps
- , dynamicRuleCommand = CmdOmitted :: NoCmd args (depsRes -> IO ())
+ , dynamicRuleCommand = CmdOmitted :: NoCmd scope args (depsRes -> IO ())
+ , dynamicRuleTypeRep = tr
}
-- | Obtain the (optional) 'IO' action that computes dynamic dependencies.
-runRuleDynDepsCmd :: RuleDynDepsCmd -> Maybe (IO ([Dependency], LBS.ByteString))
+runRuleDynDepsCmd :: RuleDynDepsCmd User -> Maybe (IO ([Dependency], LBS.ByteString))
runRuleDynDepsCmd = \case
StaticRuleCommand{} -> Nothing
DynamicRuleCommands
- { dynamicRuleInstances = instsPtr
+ { dynamicRuleInstances = UserStatic instsPtr
, dynamicDeps = DynDepsCmd{dynDepsCmd = depsCmd}
}
| Dict <- deRefStaticPtr instsPtr ->
Just $ do
(deps, depsRes) <- runCommand depsCmd
- return $ (deps, Binary.encode depsRes)
+ -- 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 :: RuleCmds -> Maybe LBS.ByteString -> RuleExecCmd
-ruleExecCmd (StaticRuleCommand{staticRuleCommand = cmd}) _ =
- StaticRuleCommand{staticRuleCommand = cmd}
+ruleExecCmd :: SScope scope -> RuleCmds scope -> Maybe LBS.ByteString -> RuleExecCmd scope
ruleExecCmd
- ( DynamicRuleCommands
- { dynamicRuleInstances = instsPtr
- , dynamicRuleCommand = cmd :: Command arg (depsRes -> IO ())
- , dynamicDeps = _ :: DynDepsCmd depsArg depsRes
- }
- )
+ _
+ 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 ->
@@ -528,20 +783,33 @@ ruleExecCmd
[ "Missing ByteString argument in 'ruleExecCmd'."
, "Run 'runRuleDynDepsCmd' on the rule to obtain this data."
]
- Just depsResBinary
- | Dict <- deRefStaticPtr instsPtr ->
+ 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 (Binary.decode depsResBinary) :: DepsRes depsArg depsRes
+ , dynamicDeps = DepsRes $ ScopedArgument depsResBinary
+ , dynamicRuleTypeRep = tr
}
-- | Obtain the 'IO' action that executes a rule.
-runRuleExecCmd :: RuleExecCmd -> IO ()
+runRuleExecCmd :: RuleExecCmd User -> IO ()
runRuleExecCmd = \case
StaticRuleCommand{staticRuleCommand = cmd} -> runCommand cmd
- DynamicRuleCommands{dynamicDeps = DepsRes res, dynamicRuleCommand = cmd} ->
- runCommand cmd res
+ DynamicRuleCommands
+ { dynamicDeps = DepsRes (ScopedArgument{getArg = res})
+ , dynamicRuleCommand = cmd
+ } ->
+ runCommand cmd res
--------------------------------------------------------------------------------
-- Instances
@@ -550,52 +818,67 @@ runRuleExecCmd = \case
data Dict c where
Dict :: c => Dict c
-instance Show (Command arg res) where
+instance Show (CommandData User arg res) where
showsPrec prec (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts})
- | Dict <- deRefStaticPtr insts =
+ | Dict <- deRefStaticPtr (userStaticPtr insts) =
showParen (prec >= 11) $
showString "Command {"
. showString "actionPtrKey = "
- . shows (staticKey cmdPtr)
+ . shows cmdPtr
. showCommaSpace
. showString "actionArg = "
. shows arg
. showString "}"
-instance Eq (Command arg res) where
+instance Eq (CommandData User arg res) where
Command{actionPtr = cmdPtr1, actionArg = arg1, cmdInstances = insts1}
== Command{actionPtr = cmdPtr2, actionArg = arg2, cmdInstances = insts2}
- | staticKey cmdPtr1 == staticKey cmdPtr2
- , staticKey insts1 == staticKey insts2
- , Dict <- deRefStaticPtr insts1 =
+ | 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 (Command arg res) where
+instance Binary (CommandData User arg res) where
put (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts})
- | Dict <- deRefStaticPtr insts =
+ | Dict <- deRefStaticPtr (userStaticPtr insts) =
do
- put (staticKey cmdPtr)
- put (staticKey insts)
+ put cmdPtr
+ put insts
put arg
get = do
- cmdKey <- get @StaticKey
- instsKey <- get @StaticKey
- case unsafePerformIO $ unsafeLookupStaticPtr cmdKey of
- Just cmdPtr
- | Just instsPtr <- unsafePerformIO $ unsafeLookupStaticPtr instsKey
- , Dict <- deRefStaticPtr @(Dict (Binary arg, Show arg)) instsPtr ->
- do
- arg <- get
- return $ Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = instsPtr}
- _ -> error "failed to look up static pointer key for action"
+ 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 arg res)
- , forall depsArg depsRes. Show depsRes => Show (deps depsArg depsRes)
+ ( forall arg res. Show (ruleCmd User arg res)
+ , forall depsArg depsRes. Show depsRes => Show (deps User depsArg depsRes)
)
- => Show (RuleCommands deps ruleCmd)
+ => Show (RuleCommands User deps ruleCmd)
where
showsPrec prec (StaticRuleCommand{staticRuleCommand = cmd}) =
showParen (prec >= 11) $
@@ -608,7 +891,7 @@ instance
( DynamicRuleCommands
{ dynamicDeps = deps
, dynamicRuleCommand = cmd
- , dynamicRuleInstances = instsPtr
+ , dynamicRuleInstances = UserStatic instsPtr
}
)
| Dict <- deRefStaticPtr instsPtr =
@@ -622,28 +905,28 @@ instance
. showString "}"
instance
- ( forall arg res. Eq (ruleCmd arg res)
- , forall depsArg depsRes. Eq depsRes => Eq (deps depsArg depsRes)
+ ( forall arg res. Eq (ruleCmd User arg res)
+ , forall depsArg depsRes. Eq depsRes => Eq (deps User depsArg depsRes)
)
- => Eq (RuleCommands deps ruleCmd)
+ => Eq (RuleCommands User deps ruleCmd)
where
- StaticRuleCommand{staticRuleCommand = ruleCmd1 :: ruleCmd arg1 (IO ())}
- == StaticRuleCommand{staticRuleCommand = ruleCmd2 :: ruleCmd arg2 (IO ())}
- | Just Refl <- eqT @arg1 @arg2 =
+ 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 depsArg1 depsRes1
- , dynamicRuleCommand = ruleCmd1 :: ruleCmd arg1 (depsRes1 -> IO ())
- , dynamicRuleInstances = instsPtr1
+ { dynamicDeps = depsCmd1 :: deps User depsArg1 depsRes1
+ , dynamicRuleCommand = ruleCmd1 :: ruleCmd User arg1 (depsRes1 -> IO ())
+ , dynamicRuleInstances = UserStatic instsPtr1
+ , dynamicRuleTypeRep = tr1
}
== DynamicRuleCommands
- { dynamicDeps = depsCmd2 :: deps depsArg2 depsRes2
- , dynamicRuleCommand = ruleCmd2 :: ruleCmd arg2 (depsRes2 -> IO ())
- , dynamicRuleInstances = instsPtr2
+ { dynamicDeps = depsCmd2 :: deps User depsArg2 depsRes2
+ , dynamicRuleCommand = ruleCmd2 :: ruleCmd User arg2 (depsRes2 -> IO ())
+ , dynamicRuleInstances = UserStatic instsPtr2
+ , dynamicRuleTypeRep = tr2
}
- | Just Refl <- eqT @depsArg1 @depsArg2
- , Just Refl <- eqT @depsRes1 @depsRes2
- , Just Refl <- eqT @arg1 @arg2
+ | Just HRefl <- Typeable.eqTypeRep tr1 tr2
, Dict <- deRefStaticPtr instsPtr1 =
depsCmd1 == depsCmd2
&& ruleCmd1 == ruleCmd2
@@ -651,27 +934,40 @@ instance
_ == _ = False
instance
- ( forall arg res. Binary (ruleCmd arg res)
- , forall depsArg depsRes. Binary depsRes => Binary (deps depsArg depsRes)
+ ( forall res. Eq (ruleCmd System LBS.ByteString res)
+ , Eq (deps System LBS.ByteString LBS.ByteString)
)
- => Binary (RuleCommands deps ruleCmd)
+ => 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 arg (IO ())} -> do
- put @Word 0
- put $ Typeable.SomeTypeRep (Typeable.typeRep @arg)
- put ruleCmd
+ StaticRuleCommand
+ { staticRuleCommand = ruleCmd :: ruleCmd User arg (IO ())
+ , staticRuleArgRep = tr
+ } -> do
+ put @Word 0
+ put (Typeable.SomeTypeRep tr)
+ put ruleCmd
DynamicRuleCommands
- { dynamicDeps = deps :: deps depsArg depsRes
- , dynamicRuleCommand = ruleCmd :: ruleCmd arg (depsRes -> IO ())
+ { dynamicDeps = deps :: deps User depsArg depsRes
+ , dynamicRuleCommand = ruleCmd :: ruleCmd User arg (depsRes -> IO ())
, dynamicRuleInstances = instsPtr
- } | Dict <- deRefStaticPtr instsPtr ->
+ , dynamicRuleTypeRep = tr
+ } | Dict <- deRefStaticPtr (userStaticPtr instsPtr) ->
do
put @Word 1
- put $ Typeable.SomeTypeRep (Typeable.typeRep @depsArg)
- put $ Typeable.SomeTypeRep (Typeable.typeRep @depsRes)
- put $ Typeable.SomeTypeRep (Typeable.typeRep @arg)
- put $ staticKey instsPtr
+ put (Typeable.SomeTypeRep tr)
+ put instsPtr
put ruleCmd
put deps
get = do
@@ -682,37 +978,92 @@ instance
if
| Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trArg) (Typeable.typeRep @Hs.Type) ->
do
- ruleCmd <- get @(ruleCmd arg (IO ()))
+ 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 (trDepsArg :: Typeable.TypeRep depsArg) <- get
- Typeable.SomeTypeRep (trDepsRes :: Typeable.TypeRep depsRes) <- get
- Typeable.SomeTypeRep (trArg :: Typeable.TypeRep arg) <- get
- instsKey <- get @StaticKey
- if
- | Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trDepsArg) (Typeable.typeRep @Hs.Type)
- , Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trDepsRes) (Typeable.typeRep @Hs.Type)
- , Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trArg) (Typeable.typeRep @Hs.Type)
- , Just instsPtr <- unsafePerformIO $ unsafeLookupStaticPtr instsKey
- , Dict :: Dict (Binary depsRes, Show depsRes, Eq depsRes) <-
- deRefStaticPtr instsPtr ->
- do
- ruleCmd <- get @(ruleCmd arg (depsRes -> IO ()))
- deps <- get @(deps depsArg depsRes)
- return $
- Typeable.withTypeable trDepsArg $
- Typeable.withTypeable trDepsRes $
- Typeable.withTypeable trArg $
- DynamicRuleCommands
- { dynamicDeps = deps
- , dynamicRuleCommand = ruleCmd
- , dynamicRuleInstances = instsPtr
- }
- | otherwise ->
- error "internal error when decoding dynamic rule commands"
+ 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 443fc87ae584a646674edd189e04887df8446fe2..eb9096271efd2c8323351cd5d34d6138aa2e8406 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 3d364ae44b2c0312f8eeced57a1c427d0348d4a1..4b4ddb7e342a540f38f0e1c43d58bb84f65e987f 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 b27cd0b875f43a9c2ec6baffbfadf0166f8d74a9..75ab4a6bedfbad34f7e491ea8b97a6f0cf42ca44 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 8c30cc18abbae5aaf28fe9b964bde23cdecc53d7..6d440b78062efc3ef1d2740380be551f5517e2f4 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 37e0cbdf1eeed94949779bc71fbe46aa7ebbfeaf..66a0a103c232a761534d5448d9eb486377e36d87 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/Init/Defaults.hs b/cabal-install/src/Distribution/Client/Init/Defaults.hs
index 9be998feda79fea1dabc864488681b19a3160321..a915a5159d348cc402175fe0272773609d25967a 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 1e08e843d6f1c4e157c40909c4603ebbc63b6c09..48209d370679ff5e94fc1ecc33a30377e637ea32 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 2de2e48f3e48e92652111a49ba3e32c8c3a134bc..de14fc129c9ffc4c4f0f3a5835d16708b4eba1c3 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 cdde7d48062ac9f493f93a0a06765b9038446497..38a59b9818c3dd54db95a015c8c09633eb5d5224 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 86bc044342e2ec6fa98cf84a9e9fd3970e3574c2..212a5d93f816bebdafec12b446f14b9d7a8cc3bd 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 f344db1e389f55b518907bfc9b2b8b45c9403a87..5b4896b05685b91ef55bfa44c17dcb1195a15b88 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 f5432dad1c2c5c93e0f2eb04a3c59628338fd2c5..0fc5e89f1bc55375a1432c30a7bffaa05c4e2029 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 0000000000000000000000000000000000000000..4ad8e7121afa19004cceb157a530e6c15b8d6d42
--- /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 0000000000000000000000000000000000000000..d81c48d93e47f8435b509e6531467d80cdd5799f
--- /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 0000000000000000000000000000000000000000..e6fdbadb4398bc0e333947b5fb8021778310d943
--- /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 0000000000000000000000000000000000000000..37e0db3efdaa3a34fa248e7cad46c473fa95be3f
--- /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 0000000000000000000000000000000000000000..2fdce2d44c0fc595cd158737451f0f4bcbeac8e1
--- /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 0000000000000000000000000000000000000000..0096ff04cef7f21021e4d56c9d9ed21b7e4afa7a
--- /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 0000000000000000000000000000000000000000..4ad8e7121afa19004cceb157a530e6c15b8d6d42
--- /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 0000000000000000000000000000000000000000..1c79900b639b22ad762f0d65f6cdeee22b04053f
--- /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 0000000000000000000000000000000000000000..e6fdbadb4398bc0e333947b5fb8021778310d943
--- /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 0000000000000000000000000000000000000000..8f3bd230ab1a215dbb1ca0a14d650bfe0b4e81b5
--- /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 0000000000000000000000000000000000000000..0c9286b42dc758c0d16f3448d29b7f3da2ed030a
--- /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 0000000000000000000000000000000000000000..0096ff04cef7f21021e4d56c9d9ed21b7e4afa7a
--- /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 0000000000000000000000000000000000000000..5a5ad78c46c204316b7fabc00a436f6de45b38fb
--- /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 0000000000000000000000000000000000000000..8e504be4e148738260750ddc2efeeff07b33ecf3
--- /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 0000000000000000000000000000000000000000..b6fa9fbb8eceea7346ecbf79454ee1b84abe8d9e
--- /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 0000000000000000000000000000000000000000..44365beb319e24d550897729ab857442550a80fa
--- /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 0000000000000000000000000000000000000000..77fedb97265ce315a2f703dff6c5089c8703f562
--- /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 0000000000000000000000000000000000000000..4ad8e7121afa19004cceb157a530e6c15b8d6d42
--- /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 0000000000000000000000000000000000000000..67ac7b8ee1d57c06f26b53ef208b0008d1a072d9
--- /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 0000000000000000000000000000000000000000..823630037be8232efb34c8d6c29938fc05eb9859
--- /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 0000000000000000000000000000000000000000..e6fdbadb4398bc0e333947b5fb8021778310d943
--- /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 0000000000000000000000000000000000000000..e0627cb71b46b086d1f86d2d4d9df89f2484b7ad
--- /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 0000000000000000000000000000000000000000..11c1647571bc9fc22f1608bafcab7621892983c9
--- /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 0000000000000000000000000000000000000000..2df426a5dbf90950ec8f125d12f00b7bf8abb062
--- /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 0000000000000000000000000000000000000000..4ad8e7121afa19004cceb157a530e6c15b8d6d42
--- /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 0000000000000000000000000000000000000000..65067ebff97880dc2d4fe534cc831cb08cd5de8c
--- /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 0000000000000000000000000000000000000000..e6fdbadb4398bc0e333947b5fb8021778310d943
--- /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 0000000000000000000000000000000000000000..c0d3e0b9481996c32e3bb27315f8889333e75555
--- /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 0000000000000000000000000000000000000000..5076d3b207b972b5f289b4e6b8b11fc0041ded5c
--- /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 0000000000000000000000000000000000000000..370c60bd0f1308d4a9b3dd782501bdbf58903ca8
--- /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 0000000000000000000000000000000000000000..4ad8e7121afa19004cceb157a530e6c15b8d6d42
--- /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 0000000000000000000000000000000000000000..b7ac707e627ecc4a2ec7fc49bc0aba6ba6f063c0
--- /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 0000000000000000000000000000000000000000..e6fdbadb4398bc0e333947b5fb8021778310d943
--- /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 0000000000000000000000000000000000000000..ff982ea9abf51ccb028ae3b25d0b40e6633d2e09
--- /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 0000000000000000000000000000000000000000..2a5f2e99d6f0af9ff041768b171e8d057b732f15
--- /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 0000000000000000000000000000000000000000..370c60bd0f1308d4a9b3dd782501bdbf58903ca8
--- /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 0000000000000000000000000000000000000000..4ad8e7121afa19004cceb157a530e6c15b8d6d42
--- /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 0000000000000000000000000000000000000000..0949aff5b8991f758aaa8ea94d203088788fa202
--- /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 0000000000000000000000000000000000000000..e6fdbadb4398bc0e333947b5fb8021778310d943
--- /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 0000000000000000000000000000000000000000..8bb8a6ed2c6b003a1c8a875e3a6880da3d43a68e
--- /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 0000000000000000000000000000000000000000..82f5148e9b97e126dae435912bd28ea53d4a7efc
--- /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 0000000000000000000000000000000000000000..370c60bd0f1308d4a9b3dd782501bdbf58903ca8
--- /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 0000000000000000000000000000000000000000..4ad8e7121afa19004cceb157a530e6c15b8d6d42
--- /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 0000000000000000000000000000000000000000..47ff32961637d2d5386ce19985e4d9d8260c06d4
--- /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 0000000000000000000000000000000000000000..e6fdbadb4398bc0e333947b5fb8021778310d943
--- /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 0000000000000000000000000000000000000000..a0c841913b7284048aa70bfa19e28a1e4af1c218
--- /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 0000000000000000000000000000000000000000..bfbd911994ddad7c10df85c555e4e9a08abb2833
--- /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 0000000000000000000000000000000000000000..370c60bd0f1308d4a9b3dd782501bdbf58903ca8
--- /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 0000000000000000000000000000000000000000..4ad8e7121afa19004cceb157a530e6c15b8d6d42
--- /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 0000000000000000000000000000000000000000..6b5ce60dd81f0280be7101d6d44aef53957614f6
--- /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 0000000000000000000000000000000000000000..e6fdbadb4398bc0e333947b5fb8021778310d943
--- /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 0000000000000000000000000000000000000000..b4783b483df5b60a2d80f12c7ddfa987e486e366
--- /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 0000000000000000000000000000000000000000..5659bca63e1f5ccb314bd09508fc769ab836221b
--- /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 0000000000000000000000000000000000000000..370c60bd0f1308d4a9b3dd782501bdbf58903ca8
--- /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 0000000000000000000000000000000000000000..2f20e91a6c1714ca9eb580bef1c5543800abc473
--- /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 0000000000000000000000000000000000000000..4ad8e7121afa19004cceb157a530e6c15b8d6d42
--- /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 0000000000000000000000000000000000000000..a301e71cff01974895c0c774789a9136ca40fff6
--- /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 0000000000000000000000000000000000000000..e6fdbadb4398bc0e333947b5fb8021778310d943
--- /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 0000000000000000000000000000000000000000..f3885717b5d8f887e7a2cb566db290998f6b6cac
--- /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 0000000000000000000000000000000000000000..ccc3b1e74896c05303a182eaa56d00d234cbdf13
--- /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 0000000000000000000000000000000000000000..2df426a5dbf90950ec8f125d12f00b7bf8abb062
--- /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 0000000000000000000000000000000000000000..4ad8e7121afa19004cceb157a530e6c15b8d6d42
--- /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 0000000000000000000000000000000000000000..e1d2141aa61018bf724e6851a7425fc917c821b8
--- /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 0000000000000000000000000000000000000000..e6fdbadb4398bc0e333947b5fb8021778310d943
--- /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 0000000000000000000000000000000000000000..380a6273b45c749ced275f9e1ebbda653757c700
--- /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 0000000000000000000000000000000000000000..b5b0f048ce65754fdcc4fbe9450f0140257436d0
--- /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 0000000000000000000000000000000000000000..2df426a5dbf90950ec8f125d12f00b7bf8abb062
--- /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 4fdd0e51e7cc6bc829c87b957b36a01085237bc5..56b62690268039794b1e83fb2b34d8f66acc27ab 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 d6906a6d4164ebdbb17f0c58482ca2cc6c05e55f..76387a2bae193b3c9d3c4ff4fb8b8cff57d1eb90 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 0000000000000000000000000000000000000000..5116234a653da20618998b3bf6db97a8afd897f5
--- /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 dd8c505a85e300c41ae2314962354b891dfd9b10..c1ccf418f81726496dad069e2c74df11c3129e1e 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 652746b216a314ab89cdcc26871495900a7ec0f2..9ec167364e0c6c1a67c186a09a578fc9c8d53092 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<setup-hooks>` .
.. 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 <custom-setup>` 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 <https://hackage.haskell.org/package/Cabal-hooks/docs/Distribution-Simple-SetupHooks.html>`__
+for an overview of the ``Hooks`` API. Further motivation and a technical overview
+of the design is available in `Haskell Tech Proposal #60 <https://github.com/haskellfoundation/tech-proposals/blob/main/proposals/accepted/060-replacing-cabal-custom-build.md>`__ .
+
+.. _custom-setup:
+
Custom setup scripts
--------------------
+Deprecated since Cabal 3.14: prefer using the :ref:`Hooks build type<setup-hooks>` 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 2500cad5ecff058673ea88d7f50c01167ad748c3..3c1d897705da644d75a02f269f597305dbc5e022 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 9edc87eeaf34eba82c2b071a3fc8a0c688622d79..be167d40d438ed8e472cb90d9e7e0fe6a9f01417 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