diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs index 8c1c501cf95..717fd6a5c7a 100644 --- a/Cabal-described/src/Distribution/Described.hs +++ b/Cabal-described/src/Distribution/Described.hs @@ -355,7 +355,7 @@ instance Described BenchmarkType where describe _ = "exitcode-stdio-1.0" instance Described BuildType where - describe _ = REUnion ["Simple","Configure","Custom","Make","Default"] + describe _ = REUnion ["Simple","Configure","Custom","Hooks","Make","Default"] instance Described CompilerFlavor where describe _ = REUnion diff --git a/Cabal-hooks/Cabal-hooks.cabal b/Cabal-hooks/Cabal-hooks.cabal new file mode 100644 index 00000000000..e9768013129 --- /dev/null +++ b/Cabal-hooks/Cabal-hooks.cabal @@ -0,0 +1,69 @@ +cabal-version: 2.2 +name: Cabal-hooks +version: 0.1 +copyright: 2023, Cabal Development Team +license: BSD-3-Clause +license-file: LICENSE +author: Cabal Development Team +maintainer: cabal-devel@haskell.org +homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +synopsis: API for the Hooks build-type +description: + User-facing API for the Hooks build-type. +category: Distribution +build-type: Simple + +extra-source-files: + readme.md changelog.md + +source-repository head + type: git + location: https://github.com/haskell/cabal/ + subdir: Cabal-hooks + +library + default-language: Haskell2010 + hs-source-dirs: src + + build-depends: + Cabal-syntax >= 3.11 && < 3.13, + Cabal >= 3.11 && < 3.13, + base >= 4.9 && < 5, + containers >= 0.5.0.0 && < 0.8, + filepath >= 1.3.0.1 && < 1.5, + transformers >= 0.5.6.0 && < 0.7 + + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + + exposed-modules: + Distribution.Simple.SetupHooks + + other-extensions: + BangPatterns + CPP + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImplicitParams + KindSignatures + LambdaCase + NondecreasingIndentation + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + Trustworthy + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances diff --git a/Cabal-hooks/LICENSE b/Cabal-hooks/LICENSE new file mode 100644 index 00000000000..c134f098c03 --- /dev/null +++ b/Cabal-hooks/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2003-2023, Cabal Development Team. +See the AUTHORS file for the full list of copyright holders. + +See */LICENSE for the copyright holders of the subcomponents. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Cabal-hooks/changelog.md b/Cabal-hooks/changelog.md new file mode 100644 index 00000000000..ea633b2936a --- /dev/null +++ b/Cabal-hooks/changelog.md @@ -0,0 +1,6 @@ +# Changelog for `Cabal-hooks` + +## 0.1 – December 2023 + + * Initial release of the `Hooks` API. + diff --git a/Cabal-hooks/readme.md b/Cabal-hooks/readme.md new file mode 100644 index 00000000000..9304784efe6 --- /dev/null +++ b/Cabal-hooks/readme.md @@ -0,0 +1,64 @@ +# `Cabal-hooks` + +This library provides an API for the `Cabal` `Hooks` build type. + +## What is the `Hooks` build type? + +The `Hooks` build type is a new `Cabal` build type that is scheduled to +replace the `Custom` build type, providing better integration with +the rest of the Haskell ecosystem. + +The original specification for the `Hooks` build type can be found in +the associated [Haskell Foundation Tech Proposal](https://github.com/haskellfoundation/tech-proposals/pull/60). + +These *setup hooks* allow package authors to customise the configuration and +building of a package by providing certain hooks that get folded into the +general package configuration and building logic within `Cabal`. + +## Defining a package with custom hooks + +To use the `Hooks` build type, you will need to + + * Update your `.cabal` file by: + + - using `cabal-version >= 3.14`, + - declaring `build-type: Hooks`, + - declaring a `custom-setup` stanza, with a `setup-depends` + field which includes a dependency on `Cabal-hooks`. + + * Define a Haskell module `SetupHooks`, which must be placed + at the root of your project and must define a value + `setupHooks :: SetupHooks`. + +That is, your `.cabal` file should contain the following + +```cabal +-- my-package.cabal +cabal-version: 3.14 +name: my-package +build-type: Hooks + +custom-setup + setup-depends: + Cabal-hooks >= 0.1 && < 0.2 +``` + +and your `SetupHooks.hs` file should look like: + +```haskell +-- SetupHooks.hs +module SetupHooks ( setupHooks ) where + +-- Cabal-hooks +import Distribution.Simple.SetupHooks + +setupHooks :: SetupHooks +setupHooks = ... + -- use the API provided by 'Distribution.Simple.SetupHooks' + -- to define the hooks relevant to your package +``` + +## Using the API + +The [Haddock documentation](https://hackage.haskell.org/package/Cabal-hooks) +should help you get started using this library's API. diff --git a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs index 3434ab27537..48929bd4ce5 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 eb029b5ffc9..3d1f9418e4a 100644 --- a/Cabal-syntax/src/Distribution/CabalSpecVersion.hs +++ b/Cabal-syntax/src/Distribution/CabalSpecVersion.hs @@ -34,6 +34,7 @@ data CabalSpecVersion | CabalSpecV3_8 | -- 3.10: no changes CabalSpecV3_12 + | CabalSpecV3_14 deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic) instance Binary CabalSpecVersion @@ -44,6 +45,7 @@ instance NFData CabalSpecVersion where rnf = genericRnf -- -- @since 3.0.0.0 showCabalSpecVersion :: CabalSpecVersion -> String +showCabalSpecVersion CabalSpecV3_14 = "3.14" showCabalSpecVersion CabalSpecV3_12 = "3.12" showCabalSpecVersion CabalSpecV3_8 = "3.8" showCabalSpecVersion CabalSpecV3_6 = "3.6" @@ -65,13 +67,14 @@ showCabalSpecVersion CabalSpecV1_2 = "1.2" showCabalSpecVersion CabalSpecV1_0 = "1.0" cabalSpecLatest :: CabalSpecVersion -cabalSpecLatest = CabalSpecV3_12 +cabalSpecLatest = CabalSpecV3_14 -- | Parse 'CabalSpecVersion' from version digits. -- -- It may fail if for recent versions the version is not exact. cabalSpecFromVersionDigits :: [Int] -> Maybe CabalSpecVersion cabalSpecFromVersionDigits v + | v == [3, 14] = Just CabalSpecV3_14 | v == [3, 12] = Just CabalSpecV3_12 | v == [3, 8] = Just CabalSpecV3_8 | v == [3, 6] = Just CabalSpecV3_6 @@ -95,6 +98,7 @@ cabalSpecFromVersionDigits v -- | @since 3.4.0.0 cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] +cabalSpecToVersionDigits CabalSpecV3_14 = [3, 14] cabalSpecToVersionDigits CabalSpecV3_12 = [3, 12] cabalSpecToVersionDigits CabalSpecV3_8 = [3, 8] cabalSpecToVersionDigits CabalSpecV3_6 = [3, 6] diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index cd299b87675..ae4c0cfec6b 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -761,6 +761,10 @@ checkForUndefinedCustomSetup gpd = do parseFailure zeroPos $ "Since cabal-version: 1.24 specifying custom-setup section is mandatory" + when (buildType pd == Hooks && isNothing (setupBuildInfo pd)) $ + parseFailure zeroPos $ + "Packages with build-type: Hooks require a custom-setup stanza" + ------------------------------------------------------------------------------- -- Post processing of internal dependencies ------------------------------------------------------------------------------- @@ -988,7 +992,7 @@ parseHookedBuildInfo' lexWarnings fs = do -- RFC5234 ABNF): -- -- @ --- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS +-- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-spec-version *WS -- -- spec-version = NUM "." NUM [ "." NUM ] -- diff --git a/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs b/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs index ba6cb0284a3..88280ca56f9 100644 --- a/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs +++ b/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs @@ -17,6 +17,7 @@ data LicenseListVersion deriving (Eq, Ord, Show, Enum, Bounded) cabalSpecVersionToSPDXListVersion :: CabalSpecVersion -> LicenseListVersion +cabalSpecVersionToSPDXListVersion CabalSpecV3_14 = LicenseListVersion_3_23 cabalSpecVersionToSPDXListVersion CabalSpecV3_12 = LicenseListVersion_3_23 cabalSpecVersionToSPDXListVersion CabalSpecV3_8 = LicenseListVersion_3_16 cabalSpecVersionToSPDXListVersion CabalSpecV3_6 = LicenseListVersion_3_10 diff --git a/Cabal-syntax/src/Distribution/Types/BuildType.hs b/Cabal-syntax/src/Distribution/Types/BuildType.hs index e80770843f3..b94279eaf2e 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildType.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildType.hs @@ -29,6 +29,7 @@ data BuildType Make | -- | uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) Custom + | Hooks deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary BuildType @@ -36,7 +37,7 @@ instance Structured BuildType instance NFData BuildType where rnf = genericRnf knownBuildTypes :: [BuildType] -knownBuildTypes = [Simple, Configure, Make, Custom] +knownBuildTypes = [Simple, Configure, Make, Custom, Hooks] instance Pretty BuildType where pretty = Disp.text . show @@ -49,6 +50,11 @@ instance Parsec BuildType where "Configure" -> return Configure "Custom" -> return Custom "Make" -> return Make + "Hooks" -> do + v <- askCabalSpecVersion + if v >= CabalSpecV3_14 + then return Hooks + else fail "build-type: 'Hooks'. This feature requires cabal-version >= 3.14." "Default" -> do v <- askCabalSpecVersion if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs index 2bc8e206666..9b36dd9d7ce 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs @@ -33,15 +33,15 @@ md5Check proxy md5Int = structureHash proxy @?= md5FromInteger md5Int md5CheckGenericPackageDescription :: Proxy GenericPackageDescription -> Assertion md5CheckGenericPackageDescription proxy = md5Check proxy #if MIN_VERSION_base(4,19,0) - 0x6639f65b143830a97e9c4f448b9cabb0 + 0x4acd7857947385180d814f36dc1a759e #else - 0x855933700dccfbcc1d642e3470c3702c + 0x3ff3fa6c3c570bcafa10b457b1208cc8 #endif md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion md5CheckLocalBuildInfo proxy = md5Check proxy #if MIN_VERSION_base(4,19,0) - 0x2ae73730f60c7c947e2cb63c4aac1e54 + 0x5f774efdb0aedcbf5263d3d99e38d50b #else - 0x906cbfdef0bcdfe5734499cfabc615f5 + 0x0f53d756836a410f72b31feb7d9f7b09 #endif diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 2e9a6b765a6..6b35ac92e12 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 f444a4c23fe..ef97b0d23be 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -510,7 +510,7 @@ checkPackageDescription (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) (PackageBuildWarning NoBuildType) checkP - (isJust setupBuildInfo_ && buildType pkg /= Custom) + (isJust setupBuildInfo_ && buildType pkg `notElem` [Custom, Hooks]) (PackageBuildWarning NoCustomSetup) -- Contents. diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 657e37cbbc1..85eabcbe93c 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/Cabal/src/Distribution/Simple.hs @@ -1,8 +1,12 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- {- Work around this warning: @@ -54,6 +58,8 @@ module Distribution.Simple , UserHooks (..) , Args , defaultMainWithHooks + , defaultMainWithSetupHooks + , defaultMainWithSetupHooksArgs , defaultMainWithHooksArgs , defaultMainWithHooksNoRead , defaultMainWithHooksNoReadArgs @@ -67,6 +73,7 @@ module Distribution.Simple import Control.Exception (try) import Distribution.Compat.Prelude +import Distribution.Compat.ResponseFile (expandResponse) import Prelude () -- local @@ -80,6 +87,7 @@ import Distribution.Simple.PackageDescription import Distribution.Simple.PreProcess import Distribution.Simple.Program import Distribution.Simple.Setup +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import Distribution.Simple.UserHooks import Distribution.Simple.Build @@ -92,11 +100,14 @@ import Distribution.License import Distribution.Pretty import Distribution.Simple.Bench import Distribution.Simple.BuildPaths -import Distribution.Simple.ConfigureScript +import Distribution.Simple.ConfigureScript (runConfigureScript) import Distribution.Simple.Errors import Distribution.Simple.Haddock import Distribution.Simple.Install import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.SetupHooks.Internal + ( SetupHooks + ) import Distribution.Simple.Test import Distribution.Simple.Utils import Distribution.Utils.Path @@ -105,8 +116,7 @@ import Distribution.Version import Language.Haskell.Extension -- Base - -import Distribution.Compat.ResponseFile (expandResponse) +import Data.List (unionBy, (\\)) import System.Directory ( doesDirectoryExist , doesFileExist @@ -115,8 +125,6 @@ import System.Directory ) import System.Environment (getArgs, getProgName) -import Data.List (unionBy, (\\)) - -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the -- action specified on the command line. @@ -128,6 +136,112 @@ defaultMain = getArgs >>= defaultMainHelper simpleUserHooks defaultMainArgs :: [String] -> IO () defaultMainArgs = defaultMainHelper simpleUserHooks +defaultMainWithSetupHooks :: SetupHooks -> IO () +defaultMainWithSetupHooks setup_hooks = + getArgs >>= defaultMainWithSetupHooksArgs setup_hooks + +defaultMainWithSetupHooksArgs :: SetupHooks -> [String] -> IO () +defaultMainWithSetupHooksArgs setupHooks = + defaultMainHelper $ + simpleUserHooks + { confHook = setup_confHook + , buildHook = setup_buildHook + , copyHook = setup_copyHook + , instHook = setup_installHook + , replHook = setup_replHook + , haddockHook = setup_haddockHook + , hscolourHook = setup_hscolourHook + } + where + setup_confHook + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo + setup_confHook = + configure_setupHooks + (SetupHooks.configureHooks setupHooks) + + setup_buildHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () + setup_buildHook pkg_descr lbi hooks flags = + build_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + flags + (allSuffixHandlers hooks) + + setup_copyHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> CopyFlags + -> IO () + setup_copyHook pkg_descr lbi _hooks flags = + install_setupHooks + (SetupHooks.installHooks setupHooks) + pkg_descr + lbi + flags + + setup_installHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () + setup_installHook = + defaultInstallHook_setupHooks + (SetupHooks.installHooks setupHooks) + + setup_replHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> ReplFlags + -> [String] + -> IO () + setup_replHook pkg_descr lbi hooks flags args = + repl_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + flags + (allSuffixHandlers hooks) + args + + setup_haddockHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> HaddockFlags + -> IO () + setup_haddockHook pkg_descr lbi hooks flags = + haddock_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + (allSuffixHandlers hooks) + flags + + setup_hscolourHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> HscolourFlags + -> IO () + setup_hscolourHook pkg_descr lbi hooks flags = + hscolour_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + (allSuffixHandlers hooks) + flags + -- | A customizable version of 'defaultMain'. defaultMainWithHooks :: UserHooks -> IO () defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks @@ -256,12 +370,12 @@ configureAction globalFlags hooks flags args = do let epkg_descr = (pkg_descr0, pbi) - localbuildinfo0 <- confHook hooks epkg_descr flags' + lbi1 <- confHook hooks epkg_descr flags' -- remember the .cabal filename if we know it -- and all the extra command line args let localbuildinfo = - localbuildinfo0 + lbi1 { pkgDescrFile = mb_pd_file , extraConfigArgs = args } @@ -769,9 +883,9 @@ simpleUserHooks = , replHook = defaultReplHook , copyHook = \desc lbi _ f -> install desc lbi f , -- 'install' has correct 'copy' behavior with params - testHook = defaultTestHook + instHook = defaultInstallHook + , testHook = defaultTestHook , benchHook = defaultBenchHook - , instHook = defaultInstallHook , cleanHook = \p _ _ f -> clean p f , hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f , haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f @@ -903,19 +1017,30 @@ defaultInstallHook -> UserHooks -> InstallFlags -> IO () -defaultInstallHook pkg_descr localbuildinfo _ flags = do +defaultInstallHook = + defaultInstallHook_setupHooks SetupHooks.noInstallHooks + +defaultInstallHook_setupHooks + :: SetupHooks.InstallHooks + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () +defaultInstallHook_setupHooks inst_hooks pkg_descr localbuildinfo _ flags = do let copyFlags = defaultCopyFlags { copyDest = installDest flags , copyCommonFlags = installCommonFlags flags } - install pkg_descr localbuildinfo copyFlags + install_setupHooks inst_hooks pkg_descr localbuildinfo copyFlags let registerFlags = defaultRegisterFlags { regInPlace = installInPlace flags , regPackageDB = installPackageDB flags } - when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + when (hasLibs pkg_descr) $ + register pkg_descr localbuildinfo registerFlags defaultBuildHook :: PackageDescription diff --git a/Cabal/src/Distribution/Simple/Bench.hs b/Cabal/src/Distribution/Simple/Bench.hs index da4788adce0..3d22f2dc42d 100644 --- a/Cabal/src/Distribution/Simple/Bench.hs +++ b/Cabal/src/Distribution/Simple/Bench.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -53,13 +55,13 @@ bench args pkg_descr lbi flags = do let verbosity = fromFlag $ benchmarkVerbosity flags benchmarkNames = args pkgBenchmarks = PD.benchmarks pkg_descr - enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi) + enabledBenchmarks = LBI.enabledBenchLBIs pkg_descr lbi mbWorkDir = flagToMaybe $ benchmarkWorkingDir flags i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path -- Run the benchmark - doBench :: PD.Benchmark -> IO ExitCode - doBench bm = + doBench :: (PD.Benchmark, LBI.ComponentLocalBuildInfo) -> IO ExitCode + doBench (bm, _clbi) = case PD.benchmarkInterface bm of PD.BenchmarkExeV10 _ _ -> do let cmd = i $ LBI.buildDir lbi makeRelativePathEx (name name <.> exeExtension (LBI.hostPlatform lbi)) @@ -100,7 +102,7 @@ bench args pkg_descr lbi flags = do [] -> return enabledBenchmarks names -> for names $ \bmName -> let benchmarkMap = zip enabledNames enabledBenchmarks - enabledNames = map PD.benchmarkName enabledBenchmarks + enabledNames = map (PD.benchmarkName . fst) enabledBenchmarks allNames = map PD.benchmarkName pkgBenchmarks in case lookup (mkUnqualComponentName bmName) benchmarkMap of Just t -> return t @@ -112,6 +114,7 @@ bench args pkg_descr lbi flags = do let totalBenchmarks = length bmsToRun notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." exitcodes <- traverse doBench bmsToRun + let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) unless allOk exitFailure where diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index e4e40b5fb5f..a198f3d2f4f 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -23,9 +25,11 @@ module Distribution.Simple.Build ( -- * Build build + , build_setupHooks -- * Repl , repl + , repl_setupHooks , startInterpreter -- * Build preparation @@ -94,6 +98,13 @@ import Distribution.Simple.Setup.Build import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Config import Distribution.Simple.Setup.Repl +import Distribution.Simple.SetupHooks.Internal + ( BuildHooks (..) + , BuildingWhat (..) + , noBuildHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks import Distribution.Simple.ShowBuildInfo import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils @@ -127,70 +138,107 @@ build -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> IO () -build pkg_descr lbi flags suffixes = do - let distPref = fromFlag $ buildDistPref flags - verbosity = fromFlag $ buildVerbosity flags - checkSemaphoreSupport verbosity (compiler lbi) flags - targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags) - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - info verbosity $ - "Component build order: " - ++ intercalate - ", " - ( map - (showComponentName . componentLocalName . targetCLBI) - componentsToBuild - ) +build = build_setupHooks noBuildHooks - when (null targets) $ - -- Only bother with this message if we're building the whole package - setupMessage verbosity "Building" (packageId pkg_descr) - - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - -- Before the actual building, dump out build-information. - -- This way, if the actual compilation failed, the options have still been - -- dumped. - dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags $ lbi)) pkg_descr lbi $ - flags - - -- Now do the actual building - (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do - preBuildComponent verbosity lbi target - let comp = targetComponent target - clbi = targetCLBI target - bi = componentBuildInfo comp - progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) - lbi' = - lbi - { withPrograms = progs' - , withPackageDB = withPackageDB lbi ++ [internalPackageDB] - , installedPkgs = index - } - let numJobs = buildNumJobs flags - par_strat <- - toFlag <$> case buildUseSemaphore flags of - Flag sem_name -> case numJobs of - Flag{} -> do - warn verbosity $ "Ignoring -j due to --semaphore" - return $ UseSem sem_name - NoFlag -> return $ UseSem sem_name - NoFlag -> return $ case numJobs of - Flag n -> NumJobs n - NoFlag -> Serial - mb_ipi <- - buildComponent - flags - par_strat - pkg_descr - lbi' - suffixes - comp - clbi - distPref - return (maybe index (Index.insert `flip` index) mb_ipi) +build_setupHooks + :: BuildHooks + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> IO () +build_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild}) + pkg_descr + lbi + flags + suffixHandlers = do + checkSemaphoreSupport verbosity (compiler lbi) flags + targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags) + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) + info verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) - return () + when (null targets) $ + -- Only bother with this message if we're building the whole package + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + -- Before the actual building, dump out build-information. + -- This way, if the actual compilation failed, the options have still been + -- dumped. + dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags + + -- Now do the actual building + (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do + let comp = targetComponent target + clbi = targetCLBI target + bi = componentBuildInfo comp + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = + lbi + { withPrograms = progs' + , withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildNormal flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + preBuildComponent runPreBuildHooks verbosity lbi' target + + let numJobs = buildNumJobs flags + par_strat <- + toFlag <$> case buildUseSemaphore flags of + Flag sem_name -> case numJobs of + Flag{} -> do + warn verbosity $ "Ignoring -j due to --semaphore" + return $ UseSem sem_name + NoFlag -> return $ UseSem sem_name + NoFlag -> return $ case numJobs of + Flag n -> NumJobs n + NoFlag -> Serial + mb_ipi <- + buildComponent + flags + par_strat + pkg_descr + lbi' + suffixHandlers + comp + clbi + distPref + let postBuildInputs = + SetupHooks.PostBuildComponentInputs + { SetupHooks.buildFlags = flags + , SetupHooks.localBuildInfo = lbi' + , SetupHooks.targetInfo = target + } + for_ mbPostBuild ($ postBuildInputs) + return (maybe index (Index.insert `flip` index) mb_ipi) + + return () + where + distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) -- | Check for conditions that would prevent the build from succeeding. checkSemaphoreSupport @@ -277,66 +325,98 @@ repl -- ^ preprocessors to run before compiling -> [String] -> IO () -repl pkg_descr lbi flags suffixes args = do - let distPref = fromFlag $ replDistPref flags - verbosity = fromFlag $ replVerbosity flags - - target <- - readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of - -- This seems DEEPLY questionable. - [] -> case allTargetsInBuildOrder' pkg_descr lbi of - (target : _) -> return target - [] -> dieWithException verbosity $ FailedToDetermineTarget - [target] -> return target - _ -> dieWithException verbosity $ NoMultipleTargets - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] - debug verbosity $ - "Component build order: " - ++ intercalate - ", " - ( map - (showComponentName . componentLocalName . targetCLBI) - componentsToBuild - ) +repl = repl_setupHooks noBuildHooks - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - let lbiForComponent comp lbi' = - lbi' - { withPackageDB = withPackageDB lbi ++ [internalPackageDB] - , withPrograms = - addInternalBuildTools - pkg_descr - lbi' - (componentBuildInfo comp) - (withPrograms lbi') - } +repl_setupHooks + :: BuildHooks + -- ^ build hook + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> ReplFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> [String] + -> IO () +repl_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules}) + pkg_descr + lbi + flags + suffixHandlers + args = do + let distPref = fromFlag (replDistPref flags) + verbosity = fromFlag (replVerbosity flags) + + target <- + readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of + -- This seems DEEPLY questionable. + [] -> case allTargetsInBuildOrder' pkg_descr lbi of + (target : _) -> return target + [] -> dieWithException verbosity $ FailedToDetermineTarget + [target] -> return target + _ -> dieWithException verbosity $ NoMultipleTargets + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] + debug verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) - -- build any dependent components - sequence_ - [ do - let clbi = targetCLBI subtarget - comp = targetComponent subtarget - lbi' = lbiForComponent comp lbi - preBuildComponent verbosity lbi subtarget - buildComponent - mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}} - NoFlag - pkg_descr - lbi' - suffixes - comp - clbi - distPref - | subtarget <- safeInit componentsToBuild - ] - - -- REPL for target components - let clbi = targetCLBI target - comp = targetComponent target - lbi' = lbiForComponent comp lbi - preBuildComponent verbosity lbi target - replComponent flags verbosity pkg_descr lbi' suffixes comp clbi distPref + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + let lbiForComponent comp lbi' = + lbi' + { withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , withPrograms = + addInternalBuildTools + pkg_descr + lbi' + (componentBuildInfo comp) + (withPrograms lbi') + } + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildRepl flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + + -- build any dependent components + sequence_ + [ do + let clbi = targetCLBI subtarget + comp = targetComponent subtarget + lbi' = lbiForComponent comp lbi + preBuildComponent runPreBuildHooks verbosity lbi' subtarget + buildComponent + (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}}) + NoFlag + pkg_descr + lbi' + suffixHandlers + comp + clbi + distPref + | subtarget <- safeInit componentsToBuild + ] + + -- REPL for target components + let clbi = targetCLBI target + comp = targetComponent target + lbi' = lbiForComponent comp lbi + preBuildComponent runPreBuildHooks verbosity lbi' target + replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref -- | Start an interpreter without loading any package files. startInterpreter @@ -373,7 +453,7 @@ buildComponent numJobs pkg_descr lbi0 - suffixes + suffixHandlers comp@( CTest test@TestSuite{testInterface = TestSuiteLibV09{}} ) @@ -388,7 +468,7 @@ buildComponent let verbosity = fromFlag $ buildVerbosity flags let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity setupMessage' @@ -425,13 +505,13 @@ buildComponent numJobs pkg_descr lbi - suffixes + suffixHandlers comp clbi distPref = do let verbosity = fromFlag $ buildVerbosity flags - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi setupMessage' verbosity @@ -618,7 +698,7 @@ replComponent verbosity pkg_descr lbi0 - suffixes + suffixHandlers comp@( CTest test@TestSuite{testInterface = TestSuiteLibV09{}} ) @@ -627,7 +707,7 @@ replComponent inplaceDir <- absoluteWorkingDirLBI lbi0 let (pkg, lib, libClbi, lbi, _, _, _) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} @@ -637,12 +717,12 @@ replComponent verbosity pkg_descr lbi - suffixes + suffixHandlers comp clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi case comp of CLib lib -> do @@ -949,19 +1029,22 @@ replFLib flags pkg_descr lbi exe clbi = GHC -> GHC.replFLib flags NoFlag pkg_descr lbi exe clbi _ -> dieWithException verbosity REPLNotSupported --- | Pre-build steps for a component: creates the autogenerated files --- for a particular configured component. +-- | Creates the autogenerated files for a particular configured component, +-- and runs the pre-build hook. preBuildComponent - :: Verbosity + :: (LocalBuildInfo -> TargetInfo -> IO ()) + -- ^ pre-build hook + -> Verbosity -> LocalBuildInfo -- ^ Configuration information -> TargetInfo -> IO () -preBuildComponent verbosity lbi tgt = do +preBuildComponent preBuildHook verbosity lbi tgt = do let pkg_descr = localPkgDescr lbi clbi = targetCLBI tgt createDirectoryIfMissingVerbose verbosity True (interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi) writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi + preBuildHook lbi tgt -- | Generate and write to disk all built-in autogenerated files -- for the specified component. These files will be put in the diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 0a788af830c..3dfe0b7e0be 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -32,6 +32,7 @@ -- level. module Distribution.Simple.Configure ( configure + , configure_setupHooks , writePersistBuildConfig , getConfigStateFile , getPersistBuildConfig @@ -86,9 +87,21 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PreProcess import Distribution.Simple.Program -import Distribution.Simple.Program.Db (lookupProgramByName, modifyProgramSearchPath, prependProgramSearchPath) +import Distribution.Simple.Program.Db + ( ProgramDb (..) + , lookupProgramByName + , modifyProgramSearchPath + , prependProgramSearchPath + , updateConfiguredProgs + ) import Distribution.Simple.Setup.Common as Setup import Distribution.Simple.Setup.Config as Setup +import Distribution.Simple.SetupHooks.Internal + ( ConfigureHooks (..) + , applyComponentDiffs + , noConfigureHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentRequestedSpec @@ -435,17 +448,99 @@ configure :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo -configure (g_pkg_descr, hookedBuildInfo) cfg = do - -- Cabal pre-configure - (lbc1, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr +configure = configure_setupHooks noConfigureHooks + +configure_setupHooks + :: ConfigureHooks + -> (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +configure_setupHooks + (ConfigureHooks{preConfPackageHook, postConfPackageHook, preConfComponentHook}) + (g_pkg_descr, hookedBuildInfo) + cfg = do + -- Cabal pre-configure + let verbosity = fromFlag (configVerbosity cfg) + distPref = fromFlag $ configDistPref cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg + (lbc0, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr + + -- Package-wide pre-configure hook + lbc1 <- + case preConfPackageHook of + Nothing -> return lbc0 + Just pre_conf -> do + let programDb0 = LBC.withPrograms lbc0 + programDb0' = programDb0{unconfiguredProgs = Map.empty} + input = + SetupHooks.PreConfPackageInputs + { SetupHooks.configFlags = cfg + , SetupHooks.localBuildConfig = lbc0{LBC.withPrograms = programDb0'} + , -- Unconfigured programs are not supplied to the hook, + -- as these cannot be passed over a serialisation boundary + -- (see the "Binary ProgramDb" instance). + SetupHooks.compiler = comp + , SetupHooks.platform = platform + } + SetupHooks.PreConfPackageOutputs + { SetupHooks.buildOptions = opts1 + , SetupHooks.extraConfiguredProgs = progs1 + } <- + pre_conf input + -- The package-wide pre-configure hook returns BuildOptions that + -- overrides the one it was passed in, as well as an update to + -- the ProgramDb in the form of new configured programs to add + -- to the program database. + return $ + lbc0 + { LBC.withBuildOptions = opts1 + , LBC.withPrograms = + updateConfiguredProgs + (`Map.union` progs1) + programDb0 + } + + -- Cabal package-wide configure + (lbc2, pbd2, pkg_info) <- + finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps + + -- Package-wide post-configure hook + for_ postConfPackageHook $ \postConfPkg -> do + let input = + SetupHooks.PostConfPackageInputs + { SetupHooks.localBuildConfig = lbc2 + , SetupHooks.packageBuildDescr = pbd2 + } + postConfPkg input + + -- Per-component pre-configure hook + pkg_descr <- do + let pkg_descr2 = LBC.localPkgDescr pbd2 + applyComponentDiffs + verbosity + ( \c -> for preConfComponentHook $ \computeDiff -> do + let input = + SetupHooks.PreConfComponentInputs + { SetupHooks.localBuildConfig = lbc2 + , SetupHooks.packageBuildDescr = pbd2 + , SetupHooks.component = c + } + SetupHooks.PreConfComponentOutputs + { SetupHooks.componentDiff = diff + } <- + computeDiff input + return diff + ) + pkg_descr2 + let pbd3 = pbd2{LBC.localPkgDescr = pkg_descr} + + -- Cabal per-component configure + externalPkgDeps <- finalCheckPackage g_pkg_descr pbd3 hookedBuildInfo pkg_info + lbi <- configureComponents lbc2 pbd3 pkg_info externalPkgDeps - -- Cabal package-wide configure - (lbc2, pbd2, pkg_info) <- - finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps + writePersistBuildConfig mbWorkDir distPref lbi - -- Cabal per-component configure - externalPkgDeps <- finalCheckPackage g_pkg_descr pbd2 hookedBuildInfo pkg_info - configureComponents lbc2 pbd2 pkg_info externalPkgDeps + return lbi preConfigurePackage :: ConfigFlags diff --git a/Cabal/src/Distribution/Simple/Errors.hs b/Cabal/src/Distribution/Simple/Errors.hs index 1ca8c97c6c6..45029565e99 100644 --- a/Cabal/src/Distribution/Simple/Errors.hs +++ b/Cabal/src/Distribution/Simple/Errors.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- -- Module : Distribution.Simple.Errors @@ -20,18 +22,15 @@ import Distribution.Compiler import Distribution.InstalledPackageInfo import Distribution.ModuleName import Distribution.Package -import Distribution.PackageDescription (FlagName, UnqualComponentName) +import Distribution.PackageDescription import Distribution.Pretty ( Pretty (pretty) , prettyShow ) import Distribution.Simple.InstallDirs import Distribution.Simple.PreProcess.Types (Suffix) +import Distribution.Simple.SetupHooks.Errors import Distribution.System (OS) -import Distribution.Types.BenchmarkType -import Distribution.Types.LibraryName -import Distribution.Types.PkgconfigVersion -import Distribution.Types.TestType import Distribution.Types.VersionRange.Internal () import Distribution.Version import Text.PrettyPrint @@ -171,6 +170,7 @@ data CabalException | BadVersionDb String Version VersionRange FilePath | UnknownVersionDb String VersionRange FilePath | MissingCoveredInstalledLibrary UnitId + | SetupHooksException SetupHooksException deriving (Show, Typeable) exceptionCode :: CabalException -> Int @@ -302,6 +302,8 @@ exceptionCode e = case e of BadVersionDb{} -> 8038 UnknownVersionDb{} -> 1008 MissingCoveredInstalledLibrary{} -> 9341 + SetupHooksException err -> + setupHooksExceptionCode err versionRequirement :: VersionRange -> String versionRequirement range @@ -317,7 +319,7 @@ exceptionMessage e = case e of NoLibraryFound -> "No executables and no library found. Nothing to do." CompilerNotInstalled compilerFlavor -> "installing with " ++ prettyShow compilerFlavor ++ "is not implemented" CantFindIncludeFile file -> "can't find include file " ++ file - UnsupportedTestSuite testType -> "Unsupported test suite type: " ++ testType + UnsupportedTestSuite test_type -> "Unsupported test suite type: " ++ test_type UnsupportedBenchMark benchMarkType -> "Unsupported benchmark type: " ++ benchMarkType NoIncludeFileFound f -> "can't find include file " ++ f NoModuleFound m suffixes -> @@ -359,7 +361,7 @@ exceptionMessage e = case e of FailedToDetermineTarget -> "Failed to determine target." NoMultipleTargets -> "The 'repl' command does not support multiple targets at once." REPLNotSupported -> "A REPL is not supported with this compiler." - NoSupportBuildingTestSuite testType -> "No support for building test suite type " ++ show testType + NoSupportBuildingTestSuite test_type -> "No support for building test suite type " ++ show test_type NoSupportBuildingBenchMark benchMarkType -> "No support for building benchmark type " ++ show benchMarkType BuildingNotSupportedWithCompiler -> "Building is not supported with this compiler." ProvideHaskellSuiteTool msg -> show msg @@ -795,3 +797,5 @@ exceptionMessage e = case e of "Failed to find the installed unit '" ++ prettyShow unitId ++ "' in package database stack." + SetupHooksException err -> + setupHooksExceptionMessage err diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 50a88d6745a..8798d7a8578 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 a63b9195b67..3b801fd7b34 100644 --- a/Cabal/src/Distribution/Simple/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Haddock.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -24,8 +25,10 @@ -- source, with coloured syntax highlighting. module Distribution.Simple.Haddock ( haddock + , haddock_setupHooks , createHaddockIndex , hscolour + , hscolour_setupHooks , haddockPackagePaths , Visibility (..) ) where @@ -67,6 +70,13 @@ import Distribution.Simple.Register import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Haddock import Distribution.Simple.Setup.Hscolour +import Distribution.Simple.SetupHooks.Internal + ( BuildHooks (..) + , BuildingWhat (..) + , noBuildHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentLocalBuildInfo @@ -218,212 +228,251 @@ haddock -> [PPSuffixHandler] -> HaddockFlags -> IO () -haddock pkg_descr _ _ haddockFlags - | not (hasLibs pkg_descr) - && not (fromFlag $ haddockExecutables haddockFlags) - && not (fromFlag $ haddockTestSuites haddockFlags) - && not (fromFlag $ haddockBenchmarks haddockFlags) - && not (fromFlag $ haddockForeignLibs haddockFlags) = - warn (fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ - "No documentation was generated as this package does not contain " - ++ "a library. Perhaps you want to use the --executables, --tests," - ++ " --benchmarks or --foreign-libraries flags." -haddock pkg_descr lbi suffixes flags' = do - let verbosity = fromFlag $ haddockVerbosity flags - mbWorkDir = flagToMaybe $ haddockWorkingDir flags - comp = compiler lbi - platform = hostPlatform lbi - - quickJmpFlag = haddockQuickJump flags' - flags = case haddockTarget of - ForDevelopment -> flags' - ForHackage -> - flags' - { haddockHoogle = Flag True - , haddockHtml = Flag True - , haddockHtmlLocation = Flag (pkg_url ++ "/docs") - , haddockContents = Flag (toPathTemplate pkg_url) - , haddockLinkedSource = Flag True - , haddockQuickJump = Flag True +haddock = haddock_setupHooks noBuildHooks + +haddock_setupHooks + :: BuildHooks + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () +haddock_setupHooks + _ + pkg_descr + _ + _ + haddockFlags + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) + && not (fromFlag $ haddockTestSuites haddockFlags) + && not (fromFlag $ haddockBenchmarks haddockFlags) + && not (fromFlag $ haddockForeignLibs haddockFlags) = + warn (fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ + "No documentation was generated as this package does not contain " + ++ "a library. Perhaps you want to use the --executables, --tests," + ++ " --benchmarks or --foreign-libraries flags." +haddock_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules}) + pkg_descr + lbi + suffixes + flags' = do + let verbosity = fromFlag $ haddockVerbosity flags + mbWorkDir = flagToMaybe $ haddockWorkingDir flags + comp = compiler lbi + platform = hostPlatform lbi + + quickJmpFlag = haddockQuickJump flags' + flags = case haddockTarget of + ForDevelopment -> flags' + ForHackage -> + flags' + { haddockHoogle = Flag True + , haddockHtml = Flag True + , haddockHtmlLocation = Flag (pkg_url ++ "/docs") + , haddockContents = Flag (toPathTemplate pkg_url) + , haddockLinkedSource = Flag True + , haddockQuickJump = Flag True + } + pkg_url = "/package/$pkg-$version" + flag f = fromFlag $ f flags + + tmpFileOpts = + defaultTempFileOptions + { optKeepTempFiles = flag haddockKeepTempFiles } - pkg_url = "/package/$pkg-$version" - flag f = fromFlag $ f flags + htmlTemplate = + fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ + flags + haddockTarget = + fromFlagOrDefault ForDevelopment (haddockForHackage flags') + + libdirArgs <- getGhcLibDir verbosity lbi + -- The haddock-output-dir flag overrides any other documentation placement concerns. + -- The point is to give the user full freedom over the location if they need it. + let overrideWithOutputDir args = case haddockOutputDir flags of + NoFlag -> args + Flag dir -> args{argOutputDir = Dir dir} + let commonArgs = + overrideWithOutputDir $ + mconcat + [ libdirArgs + , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags + , fromPackageDescription haddockTarget pkg_descr + ] - tmpFileOpts = - defaultTempFileOptions - { optKeepTempFiles = flag haddockKeepTempFiles - } - htmlTemplate = - fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ - flags - haddockTarget = - fromFlagOrDefault ForDevelopment (haddockForHackage flags') - - libdirArgs <- getGhcLibDir verbosity lbi - -- The haddock-output-dir flag overrides any other documentation placement concerns. - -- The point is to give the user full freedom over the location if they need it. - let overrideWithOutputDir args = case haddockOutputDir flags of - NoFlag -> args - Flag dir -> args{argOutputDir = Dir dir} - let commonArgs = - overrideWithOutputDir $ - mconcat - [ libdirArgs - , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags - , fromPackageDescription haddockTarget pkg_descr - ] - - (haddockProg, version) <- - getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag - - -- We fall back to using HsColour only for versions of Haddock which don't - -- support '--hyperlinked-sources'. - let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] - when using_hscolour $ - hscolour' - (warn verbosity) - haddockTarget - pkg_descr - lbi - suffixes - (defaultHscolourFlags `mappend` haddockToHscolour flags) + (haddockProg, version) <- + getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag + + -- We fall back to using HsColour only for versions of Haddock which don't + -- support '--hyperlinked-sources'. + let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] + when using_hscolour $ + hscolour' + noBuildHooks + -- NB: we are not passing the user BuildHooks here, + -- because we are already running the pre/post build hooks + -- for Haddock. + (warn verbosity) + haddockTarget + pkg_descr + lbi + suffixes + (defaultHscolourFlags `mappend` haddockToHscolour flags) - targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags) + targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags) - let - targets' = - case targets of - [] -> allTargetsInBuildOrder' pkg_descr lbi - _ -> targets + let + targets' = + case targets of + [] -> allTargetsInBuildOrder' pkg_descr lbi + _ -> targets - internalPackageDB <- - createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags) + internalPackageDB <- + createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags) - (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do - let component = targetComponent target + (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do + let + component = targetComponent target clbi = targetCLBI target - preBuildComponent verbosity lbi target - - let - lbi' = - lbi - { withPackageDB = withPackageDB lbi ++ [internalPackageDB] - , installedPkgs = index - } + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildHaddock flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + preBuildComponent runPreBuildHooks verbosity lbi target + + let + lbi' = + lbi + { withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } - preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi') "tmp" $ + preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi') "tmp" $ + \tmp -> do + exeArgs <- + fromExecutable + verbosity + tmp + lbi' + clbi + htmlTemplate + version + exe + let exeArgs' = commonArgs `mappend` exeArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + exeArgs' + Nothing -> do + warn + verbosity + "Unsupported component, skipping..." + return () + -- We define 'smsg' once and then reuse it inside the case, so that + -- we don't say we are running Haddock when we actually aren't + -- (e.g., Haddock is not run on non-libraries) + smsg :: IO () + smsg = + setupMessage' + verbosity + "Running Haddock on" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + ipi <- case component of + CLib lib -> do + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi) "tmp" $ \tmp -> do - exeArgs <- - fromExecutable + smsg + libArgs <- + fromLibrary verbosity tmp lbi' clbi htmlTemplate version - exe - let exeArgs' = commonArgs `mappend` exeArgs - runHaddock + lib + let libArgs' = commonArgs `mappend` libArgs + runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg True libArgs' + inplaceDir <- absoluteWorkingDirLBI lbi + + let + ipi = + inplaceInstalledPackageInfo + inplaceDir + (flag $ setupDistPref . haddockCommonFlags) + pkg_descr + (mkAbiHash "inplace") + lib + lbi' + clbi + + debug verbosity $ + "Registering inplace:\n" + ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + + registerPackage verbosity + (compiler lbi') + (withPrograms lbi') mbWorkDir - tmpFileOpts - comp - platform - haddockProg - True - exeArgs' - Nothing -> do - warn - verbosity - "Unsupported component, skipping..." - -- We define 'smsg' once and then reuse it inside the case, so that - -- we don't say we are running Haddock when we actually aren't - -- (e.g., Haddock is not run on non-libraries) - smsg :: IO () - smsg = - setupMessage' - verbosity - "Running Haddock on" - (packageId pkg_descr) - (componentLocalName clbi) - (maybeComponentInstantiatedWith clbi) - case component of - CLib lib -> do - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi) "tmp" $ - \tmp -> do - smsg - libArgs <- - fromLibrary - verbosity - tmp - lbi' - clbi - htmlTemplate - version - lib - let libArgs' = commonArgs `mappend` libArgs - runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg True libArgs' - inplaceDir <- absoluteWorkingDirLBI lbi - let - ipi = - inplaceInstalledPackageInfo - inplaceDir - (flag $ setupDistPref . haddockCommonFlags) - pkg_descr - (mkAbiHash "inplace") - lib - lbi' - clbi - - debug verbosity $ - "Registering inplace:\n" - ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + (withPackageDB lbi') + ipi + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + + return $ PackageIndex.insert ipi index + CFLib flib -> + when + (flag haddockForeignLibs) + ( do + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi') "tmp" $ + \tmp -> do + smsg + flibArgs <- + fromForeignLib + verbosity + tmp + lbi' + clbi + htmlTemplate + version + flib + let libArgs' = commonArgs `mappend` flibArgs + runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg True libArgs' + ) + >> return index + CExe _ -> when (flag haddockExecutables) (smsg >> doExe component) >> return index + CTest _ -> when (flag haddockTestSuites) (smsg >> doExe component) >> return index + CBench _ -> when (flag haddockBenchmarks) (smsg >> doExe component) >> return index - registerPackage - verbosity - (compiler lbi') - (withPrograms lbi') - mbWorkDir - (withPackageDB lbi') - ipi - HcPkg.defaultRegisterOptions - { HcPkg.registerMultiInstance = True - } - - return $ PackageIndex.insert ipi index - CFLib flib -> - when - (flag haddockForeignLibs) - ( do - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (buildDir lbi') "tmp" $ - \tmp -> do - smsg - flibArgs <- - fromForeignLib - verbosity - tmp - lbi' - clbi - htmlTemplate - version - flib - let libArgs' = commonArgs `mappend` flibArgs - runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg True libArgs' - ) - >> return index - CExe _ -> when (flag haddockExecutables) (smsg >> doExe component) >> return index - CTest _ -> when (flag haddockTestSuites) (smsg >> doExe component) >> return index - CBench _ -> when (flag haddockBenchmarks) (smsg >> doExe component) >> return index + return ipi - for_ (extraDocFiles pkg_descr) $ \fpath -> do - files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath - for_ files $ - copyFileToCwd verbosity mbWorkDir (unDir $ argOutputDir commonArgs) + for_ (extraDocFiles pkg_descr) $ \fpath -> do + files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath + for_ files $ + copyFileToCwd verbosity mbWorkDir (unDir $ argOutputDir commonArgs) -- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build -- index and contents for documentation of multiple packages. @@ -1131,10 +1180,21 @@ hscolour -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour = hscolour' dieNoVerbosity ForDevelopment +hscolour = hscolour_setupHooks noBuildHooks + +hscolour_setupHooks + :: BuildHooks + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour_setupHooks setupHooks = + hscolour' setupHooks dieNoVerbosity ForDevelopment hscolour' - :: (String -> IO ()) + :: BuildHooks + -> (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. -> HaddockTarget -> PackageDescription @@ -1142,93 +1202,113 @@ hscolour' -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = - either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg) - =<< lookupProgramVersion - verbosity - hscolourProgram - (orLaterVersion (mkVersion [1, 8])) - (withPrograms lbi) - where - common = hscolourCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - distPref = fromFlag $ setupDistPref common - mbWorkDir = mbWorkDirLBI lbi - i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path - u :: SymbolicPath Pkg to -> FilePath - u = interpretSymbolicPathCWD - go :: ConfiguredProgram -> IO () - go hscolourProg = do - warn verbosity $ - "the 'cabal hscolour' command is deprecated in favour of 'cabal " - ++ "haddock --hyperlink-source' and will be removed in the next major " - ++ "release." - - setupMessage verbosity "Running hscolour for" (packageId pkg_descr) - createDirectoryIfMissingVerbose verbosity True $ - i $ - hscolourPref haddockTarget distPref pkg_descr - - withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do - let tgt = TargetInfo clbi comp - preBuildComponent verbosity lbi tgt - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do +hscolour' + (BuildHooks{preBuildComponentRules = mbPbcRules}) + onNoHsColour + haddockTarget + pkg_descr + lbi + suffixes + flags = + either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg) + =<< lookupProgramVersion + verbosity + hscolourProgram + (orLaterVersion (mkVersion [1, 8])) + (withPrograms lbi) + where + common = hscolourCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + distPref = fromFlag $ setupDistPref common + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + + go :: ConfiguredProgram -> IO () + go hscolourProg = do + warn verbosity $ + "the 'cabal hscolour' command is deprecated in favour of 'cabal " + ++ "haddock --hyperlink-source' and will be removed in the next major " + ++ "release." + + setupMessage verbosity "Running hscolour for" (packageId pkg_descr) + createDirectoryIfMissingVerbose verbosity True $ + i $ + hscolourPref haddockTarget distPref pkg_descr + + withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do + let tgt = TargetInfo clbi comp + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 target = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildHscolour flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = target + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + preBuildComponent runPreBuildHooks verbosity lbi tgt + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + let outputDir = + hscolourPref haddockTarget distPref pkg_descr + makeRelativePathEx (unUnqualComponentName (exeName exe) "src") + runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi + Nothing -> do + warn verbosity "Unsupported component, skipping..." + return () + case comp of + CLib lib -> do + let outputDir = hscolourPref haddockTarget distPref pkg_descr makeRelativePathEx "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi + CFLib flib -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr - makeRelativePathEx (unUnqualComponentName (exeName exe) "src") - runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi - Nothing -> do - warn verbosity "Unsupported component, skipping..." - case comp of - CLib lib -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr makeRelativePathEx "src" - runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi - CFLib flib -> do - let outputDir = - hscolourPref haddockTarget distPref pkg_descr - makeRelativePathEx - ( unUnqualComponentName (foreignLibName flib) - "src" - ) - runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi - CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp - CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp - CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp - - stylesheet = flagToMaybe (hscolourCSS flags) - - runHsColour - :: ConfiguredProgram - -> SymbolicPath Pkg to - -> [(ModuleName.ModuleName, SymbolicPath Pkg to1)] - -> IO () - runHsColour prog outputDir moduleFiles = do - createDirectoryIfMissingVerbose verbosity True (i outputDir) - - case stylesheet of -- copy the CSS file - Nothing - | programVersion prog >= Just (mkVersion [1, 9]) -> - runProgramCwd - verbosity - mbWorkDir - prog - ["-print-css", "-o" ++ u outputDir "hscolour.css"] - | otherwise -> return () - Just s -> copyFileVerbose verbosity s (i outputDir "hscolour.css") - - for_ moduleFiles $ \(m, inFile) -> - runProgramCwd - verbosity - mbWorkDir - prog - ["-css", "-anchor", "-o" ++ outFile m, u inFile] - where - outFile m = - i outputDir - intercalate "-" (ModuleName.components m) <.> "html" + makeRelativePathEx + ( unUnqualComponentName (foreignLibName flib) + "src" + ) + runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi + CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp + CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp + CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + + stylesheet = flagToMaybe (hscolourCSS flags) + + runHsColour + :: ConfiguredProgram + -> SymbolicPath Pkg to + -> [(ModuleName.ModuleName, SymbolicPath Pkg to1)] + -> IO () + runHsColour prog outputDir moduleFiles = do + createDirectoryIfMissingVerbose verbosity True (i outputDir) + + case stylesheet of -- copy the CSS file + Nothing + | programVersion prog >= Just (mkVersion [1, 9]) -> + runProgramCwd + verbosity + mbWorkDir + prog + ["-print-css", "-o" ++ u outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (i outputDir "hscolour.css") + + for_ moduleFiles $ \(m, inFile) -> + runProgramCwd + verbosity + mbWorkDir + prog + ["-css", "-anchor", "-o" ++ outFile m, u inFile] + where + outFile m = + i outputDir + intercalate "-" (ModuleName.components m) <.> "html" haddockToHscolour :: HaddockFlags -> HscolourFlags haddockToHscolour flags = diff --git a/Cabal/src/Distribution/Simple/Install.hs b/Cabal/src/Distribution/Simple/Install.hs index d09c970ae32..c1134e2b355 100644 --- a/Cabal/src/Distribution/Simple/Install.hs +++ b/Cabal/src/Distribution/Simple/Install.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -18,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 160b81fd4de..00e6e68cb5c 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/Cabal/src/Distribution/Simple/PreProcess.hs @@ -24,6 +24,7 @@ module Distribution.Simple.PreProcess ( preprocessComponent , preprocessExtras + , preprocessFile , knownSuffixHandlers , ppSuffixes , PPSuffixHandler @@ -297,7 +298,10 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS case psrcFiles of -- no preprocessor file exists, look for an ordinary source file -- just to make sure one actually exists at all for this module. - -- Note: by looking in the target/output build dir too, we allow + + -- Note [Dodgy build dirs for preprocessors] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- By looking in the target/output build dir too, we allow -- source files to appear magically in the target build dir without -- any corresponding "real" source file. This lets custom Setup.hs -- files generate source modules directly into the build dir without diff --git a/Cabal/src/Distribution/Simple/PreProcess/Types.hs b/Cabal/src/Distribution/Simple/PreProcess/Types.hs index 5315d3b1ac7..5b865349e78 100644 --- a/Cabal/src/Distribution/Simple/PreProcess/Types.hs +++ b/Cabal/src/Distribution/Simple/PreProcess/Types.hs @@ -19,6 +19,7 @@ module Distribution.Simple.PreProcess.Types ( Suffix (..) , PreProcessor (..) + , PreProcessCommand , builtinHaskellSuffixes , builtinHaskellBootSuffixes ) @@ -90,12 +91,22 @@ data PreProcessor = PreProcessor -- -- @since 3.8.1.0 , runPreProcessor - :: (FilePath, FilePath) -- Location of the source file relative to a base dir - -> (FilePath, FilePath) -- Output file name, relative to an output base dir - -> Verbosity -- verbosity - -> IO () -- Should exit if the preprocessor fails + :: PreProcessCommand } +-- | A command to run a given preprocessor on a single source file. +-- +-- The input and output file paths are passed in as arguments, as it is +-- the build system and not the package author which chooses the location of +-- source files. +type PreProcessCommand = + (FilePath, FilePath) + -- ^ Location of the source file relative to a base dir + -> (FilePath, FilePath) + -- ^ Output file name, relative to an output base dir + -> Verbosity + -> IO () -- Should exit if the preprocessor fails + -- | A suffix (or file extension). -- -- Mostly used to decide which preprocessor to use, e.g. files with suffix @"y"@ diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index a5e4e4ab381..1dda83a6b4e 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -26,7 +26,7 @@ -- don't have to write all the PATH logic inside Setup.lhs. module Distribution.Simple.Program.Db ( -- * The collection of configured programs we can run - ProgramDb + ProgramDb (..) , emptyProgramDb , defaultProgramDb , restoreProgramDb @@ -53,6 +53,7 @@ module Distribution.Simple.Program.Db -- ** Query and manipulate the program db , configureProgram + , configureUnconfiguredProgram , configureAllKnownPrograms , unconfigureProgram , lookupProgramVersion @@ -60,6 +61,12 @@ module Distribution.Simple.Program.Db , requireProgram , requireProgramVersion , needProgram + + -- * Internal functions + , UnconfiguredProgs + , ConfiguredProgs + , updateUnconfiguredProgs + , updateConfiguredProgs ) where import Distribution.Compat.Prelude @@ -338,10 +345,12 @@ configuredPrograms = Map.elems . configuredProgs -- --------------------------- -- Configuring known programs --- | Try to configure a specific program. If the program is already included in --- the collection of unconfigured programs then we use any user-supplied --- location and arguments. If the program gets configured successfully it gets --- added to the configured collection. +-- | Try to configure a specific program and add it to the program database. +-- +-- If the program is already included in the collection of unconfigured programs, +-- then we use any user-supplied location and arguments. +-- If the program gets configured successfully, it gets added to the configured +-- collection. -- -- Note that it is not a failure if the program cannot be configured. It's only -- a failure if the user supplied a location and the program could not be found @@ -357,6 +366,25 @@ configureProgram -> ProgramDb -> IO ProgramDb configureProgram verbosity prog progdb = do + mbConfiguredProg <- configureUnconfiguredProgram verbosity prog progdb + case mbConfiguredProg of + Nothing -> return progdb + Just configuredProg -> do + let progdb' = + updateConfiguredProgs + (Map.insert (programName prog) configuredProg) + progdb + return progdb' + +-- | Try to configure a specific program. If the program is already included in +-- the collection of unconfigured programs then we use any user-supplied +-- location and arguments. +configureUnconfiguredProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (Maybe ConfiguredProgram) +configureUnconfiguredProgram verbosity prog progdb = do let name = programName prog maybeLocation <- case userSpecifiedPath prog progdb of Nothing -> @@ -372,7 +400,7 @@ configureProgram verbosity prog progdb = do (dieWithException verbosity $ ConfigureProgram name path) (return . Just . swap . fmap UserSpecified . swap) case maybeLocation of - Nothing -> return progdb + Nothing -> return Nothing Just (location, triedLocations) -> do version <- programFindVersion prog verbosity (locationPath location) newPath <- programSearchPathAsPATHVar (progSearchPath progdb) @@ -388,7 +416,7 @@ configureProgram verbosity prog progdb = do , programMonitorFiles = triedLocations } configuredProg' <- programPostConf prog verbosity configuredProg - return (updateConfiguredProgs (Map.insert name configuredProg') progdb) + return $ Just configuredProg' -- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. configurePrograms diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs index 861cf16095c..dfde4466b30 100644 --- a/Cabal/src/Distribution/Simple/Setup.hs +++ b/Cabal/src/Distribution/Simple/Setup.hs @@ -141,8 +141,8 @@ module Distribution.Simple.Setup , buildingWhatDistPref ) where -import GHC.Generics (Generic) -import Prelude (Maybe, Show, (.)) +import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Flag import Distribution.Simple.InstallDirs @@ -172,7 +172,7 @@ import Distribution.Utils.Path import Distribution.Verbosity (Verbosity) --- | What kind of build are we doing? +-- | What kind of build phase are we doing/hooking into? -- -- Is this a normal build, or is it perhaps for running an interactive -- session or Haddock? @@ -246,3 +246,6 @@ buildingWhatDistPref = fromFlag . setupDistPref . buildingWhatCommonFlags * quickCheck to test permutations of arguments * what other options can we over-ride with a command-line flag? -} + +instance Binary BuildingWhat +instance Structured BuildingWhat diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs new file mode 100644 index 00000000000..11577f3506b --- /dev/null +++ b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- + +-- Module : Distribution.Simple.SetupHooks.Errors +-- Copyright : +-- License : +-- +-- Maintainer : +-- Portability : +-- +-- Exceptions for the Hooks build-type. + +module Distribution.Simple.SetupHooks.Errors + ( SetupHooksException (..) + , CannotApplyComponentDiffReason (..) + , IllegalComponentDiffReason (..) + , RulesException (..) + , setupHooksExceptionCode + , setupHooksExceptionMessage + , showLocs + ) where + +import Distribution.PackageDescription +import Distribution.Simple.SetupHooks.Rule +import qualified Distribution.Simple.SetupHooks.Rule as Rule +import Distribution.Types.Component + +import qualified Data.Graph as Graph +import Data.List + ( intercalate + ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Tree as Tree + +import System.FilePath (normalise, ()) + +-------------------------------------------------------------------------------- + +-- | An error involving the @SetupHooks@ module of a package with +-- Hooks build-type. +data SetupHooksException + = -- | Cannot apply a diff to a component in a per-component configure hook. + CannotApplyComponentDiff CannotApplyComponentDiffReason + | -- | An error with pre-build rules. + RulesException RulesException + deriving (Show) + +-- | AN error involving the @Rules@ in the @SetupHooks@ module of a +-- package with the Hooks build-type. +data RulesException + = -- | There are cycles in the dependency graph of fine-grained rules. + CyclicRuleDependencies + (NE.NonEmpty (RuleBinary, [Graph.Tree RuleBinary])) + | -- | When executing fine-grained rules compiled into the external hooks + -- executable, we failed to find dependencies of a rule. + CantFindSourceForRuleDependencies + RuleBinary + (NE.NonEmpty Rule.Location) + -- ^ missing dependencies + | -- | When executing fine-grained rules compiled into the external hooks + -- executable, a rule failed to generate the outputs it claimed it would. + MissingRuleOutputs + RuleBinary + (NE.NonEmpty Rule.Location) + -- ^ missing outputs + | -- | An invalid reference to a rule output, e.g. an out-of-range + -- index. + InvalidRuleOutputIndex + RuleId + -- ^ rule + RuleId + -- ^ dependency + (NE.NonEmpty Rule.Location) + -- ^ outputs of dependency + Word + -- ^ the invalid index + | -- | A duplicate 'RuleId' in the construction of pre-build rules. + DuplicateRuleId !RuleId !Rule !Rule + +deriving instance Show RulesException + +data CannotApplyComponentDiffReason + = MismatchedComponentTypes Component Component + | IllegalComponentDiff Component (NE.NonEmpty IllegalComponentDiffReason) + deriving (Show) + +data IllegalComponentDiffReason + = CannotChangeName + | CannotChangeComponentField String + | CannotChangeBuildInfoField String + deriving (Show) + +setupHooksExceptionCode :: SetupHooksException -> Int +setupHooksExceptionCode = \case + CannotApplyComponentDiff rea -> + cannotApplyComponentDiffCode rea + RulesException rea -> + rulesExceptionCode rea + +rulesExceptionCode :: RulesException -> Int +rulesExceptionCode = \case + CyclicRuleDependencies{} -> 9077 + CantFindSourceForRuleDependencies{} -> 1071 + MissingRuleOutputs{} -> 3498 + InvalidRuleOutputIndex{} -> 1173 + DuplicateRuleId{} -> 7717 + +setupHooksExceptionMessage :: SetupHooksException -> String +setupHooksExceptionMessage = \case + CannotApplyComponentDiff reason -> + cannotApplyComponentDiffMessage reason + RulesException reason -> + rulesExceptionMessage reason + +rulesExceptionMessage :: RulesException -> String +rulesExceptionMessage = \case + CyclicRuleDependencies cycles -> + unlines $ + ("Hooks: cycle" ++ plural ++ " in dependency structure of rules:") + : map showCycle (NE.toList cycles) + where + plural :: String + plural + | NE.length cycles >= 2 = + "s" + | otherwise = + "" + showCycle :: (RuleBinary, [Graph.Tree RuleBinary]) -> String + showCycle (r, rs) = + unlines . map (" " ++) . lines $ + Tree.drawTree $ + fmap showRule $ + Tree.Node r rs + CantFindSourceForRuleDependencies _r deps -> + unlines $ + ("Pre-build rules: can't find source for rule " ++ what ++ ":") + : map (\d -> " - " <> locPath d) depsL + where + depsL = NE.toList deps + what + | length depsL == 1 = + "dependency" + | otherwise = + "dependencies" + MissingRuleOutputs _r reslts -> + unlines $ + ("Pre-build rule did not generate expected result" <> plural <> ":") + : map (\res -> " - " <> locPath res) resultsL + where + resultsL = NE.toList reslts + plural + | length resultsL == 1 = + "" + | otherwise = + "s" + InvalidRuleOutputIndex rId depRuleId outputs i -> unlines [header, body] + where + header = "Invalid index '" ++ show i ++ "' in dependency of " ++ show rId ++ "." + nbOutputs = NE.length outputs + body + | (fromIntegral i :: Int) >= 0 = + unwords + [ "The dependency" + , show depRuleId + , "only has" + , show nbOutputs + , "output" ++ plural ++ "." + ] + | otherwise = + "The index is too large." + plural = if nbOutputs == 1 then "" else "s" + DuplicateRuleId rId r1 r2 -> + unlines $ + [ "Duplicate pre-build rule (" <> show rId <> ")" + , " - " <> showRule (ruleBinary r1) + , " - " <> showRule (ruleBinary r2) + ] + where + showRule :: RuleBinary -> String + showRule (Rule{staticDependencies = deps, results = reslts}) = + "Rule: " ++ showDeps deps ++ " --> " ++ showLocs (NE.toList reslts) + +locPath :: Location -> String +locPath (base, fp) = normalise $ base fp + +showLocs :: [Location] -> String +showLocs locs = "[" ++ intercalate ", " (map locPath locs) ++ "]" + +showDeps :: [Rule.Dependency] -> String +showDeps deps = "[" ++ intercalate ", " (map showDep deps) ++ "]" + +showDep :: Rule.Dependency -> String +showDep = \case + RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) -> + "(" ++ show rId ++ ")[" ++ show i ++ "]" + FileDependency loc -> locPath loc + +cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int +cannotApplyComponentDiffCode = \case + MismatchedComponentTypes{} -> 9491 + IllegalComponentDiff{} -> 7634 + +cannotApplyComponentDiffMessage :: CannotApplyComponentDiffReason -> String +cannotApplyComponentDiffMessage = \case + MismatchedComponentTypes comp diff -> + unlines + [ "Hooks: mismatched component types in per-component configure hook." + , "Trying to apply " ++ what ++ " diff to " ++ to ++ "." + ] + where + what = case diff of + CLib{} -> "a library" + CFLib{} -> "a foreign library" + CExe{} -> "an executable" + CTest{} -> "a testsuite" + CBench{} -> "a benchmark" + to = case componentName comp of + nm@(CExeName{}) -> "an " ++ showComponentName nm + nm -> "a " ++ showComponentName nm + IllegalComponentDiff comp reasons -> + unlines $ + ("Hooks: illegal component diff in per-component pre-configure hook for " ++ what ++ ":") + : map mk_rea (NE.toList reasons) + where + mk_rea err = " - " ++ illegalComponentDiffMessage err ++ "." + what = case componentName comp of + CLibName LMainLibName -> "main library" + nm -> showComponentName nm + +illegalComponentDiffMessage :: IllegalComponentDiffReason -> String +illegalComponentDiffMessage = \case + CannotChangeName -> + "cannot change the name of a component" + CannotChangeComponentField fld -> + "cannot change component field '" ++ fld ++ "'" + CannotChangeBuildInfoField fld -> + "cannot change BuildInfo field '" ++ fld ++ "'" diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs new file mode 100644 index 00000000000..25e2f39b1ad --- /dev/null +++ b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs @@ -0,0 +1,1090 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module: Distribution.Simple.SetupHooks.Internal +-- +-- Internal implementation module. +-- Users of @build-type: Hooks@ should import "Distribution.Simple.SetupHooks" +-- instead. +module Distribution.Simple.SetupHooks.Internal + ( -- * The setup hooks datatype + SetupHooks (..) + , noSetupHooks + + -- * Configure hooks + , ConfigureHooks (..) + , noConfigureHooks + + -- ** Per-package configure hooks + , PreConfPackageInputs (..) + , PreConfPackageOutputs (..) + , noPreConfPackageOutputs + , PreConfPackageHook + , PostConfPackageInputs (..) + , PostConfPackageHook + + -- ** Per-component configure hooks + , PreConfComponentInputs (..) + , PreConfComponentOutputs (..) + , noPreConfComponentOutputs + , PreConfComponentHook + , ComponentDiff (..) + , emptyComponentDiff + , buildInfoComponentDiff + , LibraryDiff + , ForeignLibDiff + , ExecutableDiff + , TestSuiteDiff + , BenchmarkDiff + , BuildInfoDiff + + -- * Build hooks + , BuildHooks (..) + , noBuildHooks + , BuildingWhat (..) + , buildingWhatVerbosity + , buildingWhatWorkingDir + , buildingWhatDistPref + + -- ** Pre-build rules + , PreBuildComponentInputs (..) + , PreBuildComponentRules + + -- ** Post-build hook + , PostBuildComponentInputs (..) + , PostBuildComponentHook + + -- * Install hooks + , InstallHooks (..) + , noInstallHooks + , InstallComponentInputs (..) + , InstallComponentHook + + -- * Internals + + -- ** Per-component hook utilities + , applyComponentDiffs + , forComponents_ + + -- ** Executing build rules + , executeRules + + -- ** HookedBuildInfo compatibility code + , hookedBuildInfoComponents + , hookedBuildInfoComponentDiff_maybe + ) +where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Lens ((.~)) +import Distribution.ModuleName +import Distribution.PackageDescription +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler (Compiler (..)) +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.Db +import Distribution.Simple.Setup + ( BuildingWhat (..) + , buildingWhatDistPref + , buildingWhatVerbosity + , buildingWhatWorkingDir + ) +import Distribution.Simple.Setup.Build (BuildFlags (..)) +import Distribution.Simple.Setup.Config (ConfigFlags (..)) +import Distribution.Simple.Setup.Copy (CopyFlags (..)) +import Distribution.Simple.SetupHooks.Errors +import Distribution.Simple.SetupHooks.Rule +import qualified Distribution.Simple.SetupHooks.Rule as Rule +import Distribution.Simple.Utils +import Distribution.System (Platform (..)) +import Distribution.Utils.Path (getSymbolicPath) + +import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo) +import Distribution.Types.LocalBuildConfig as LBC +import Distribution.Types.TargetInfo +import Distribution.Verbosity + +import qualified Data.ByteString.Lazy as LBS +import Data.Coerce (coerce) +import qualified Data.Graph as Graph +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import qualified Data.Set as Set + +import System.Directory (doesFileExist) +import System.FilePath (normalise, (<.>), ()) + +-------------------------------------------------------------------------------- +-- SetupHooks + +-- | Hooks into the @cabal@ build phases. +-- +-- Usage: +-- +-- - In your @.cabal@ file, declare @build-type: Hooks@ +-- (with a @cabal-version@ greater than or equal to @3.14@), +-- - In your @.cabal@ file, include a @custom-setup@ stanza +-- which declares the dependencies of your @SetupHooks@ module; +-- this will usually contain a dependency on the @Cabal-hooks@ package. +-- - Provide a @SetupHooks.hs@ module next to your @.cabal@ file; +-- it must export @setupHooks :: SetupHooks@. +data SetupHooks = SetupHooks + { configureHooks :: ConfigureHooks + -- ^ Hooks into the configure phase. + , buildHooks :: BuildHooks + -- ^ Hooks into the build phase. + -- + -- These hooks are relevant to any build-like phase, + -- such as repl or haddock. + , installHooks :: InstallHooks + -- ^ Hooks into the copy/install phase. + } + +-- | 'SetupHooks' can be combined monoidally. This is useful to combine +-- setup hooks defined by another package with your own package-specific +-- hooks. +-- +-- __Warning__: this 'Semigroup' instance is not commutative. +instance Semigroup SetupHooks where + SetupHooks + { configureHooks = conf1 + , buildHooks = build1 + , installHooks = inst1 + } + <> SetupHooks + { configureHooks = conf2 + , buildHooks = build2 + , installHooks = inst2 + } = + SetupHooks + { configureHooks = conf1 <> conf2 + , buildHooks = build1 <> build2 + , installHooks = inst1 <> inst2 + } + +instance Monoid SetupHooks where + mempty = noSetupHooks + +-- | Empty hooks. +noSetupHooks :: SetupHooks +noSetupHooks = + SetupHooks + { configureHooks = noConfigureHooks + , buildHooks = noBuildHooks + , installHooks = noInstallHooks + } + +-------------------------------------------------------------------------------- +-- Configure hooks. + +type PreConfPackageHook = PreConfPackageInputs -> IO PreConfPackageOutputs + +-- | Inputs to the package-wide pre-configure step. +data PreConfPackageInputs = PreConfPackageInputs + { configFlags :: ConfigFlags + , localBuildConfig :: LocalBuildConfig + -- ^ Warning: the 'ProgramDb' in the 'withPrograms' field + -- will not contain any unconfigured programs. + , compiler :: Compiler + , platform :: Platform + } + deriving (Generic, Show) + +-- | Outputs of the package-wide pre-configure step. +-- +-- Prefer using 'noPreConfPackageOutputs' and overriding the fields +-- you care about, to avoid depending on implementation details +-- of this datatype. +data PreConfPackageOutputs = PreConfPackageOutputs + { buildOptions :: BuildOptions + , extraConfiguredProgs :: ConfiguredProgs + } + deriving (Generic, Show) + +-- | Use this smart constructor to declare an empty set of changes +-- by the package-wide pre-configure hook, and override the fields you +-- care about. +-- +-- Use this rather than v'PreConfPackageOutputs' to avoid relying on +-- internal implementation details of the latter. +noPreConfPackageOutputs :: PreConfPackageInputs -> PreConfPackageOutputs +noPreConfPackageOutputs (PreConfPackageInputs{localBuildConfig = lbc}) = + PreConfPackageOutputs + { buildOptions = LBC.withBuildOptions lbc + , extraConfiguredProgs = Map.empty + } + +-- | Package-wide post-configure step. +-- +-- Perform side effects. Last opportunity for any package-wide logic; +-- any subsequent hooks work per-component. +type PostConfPackageHook = PostConfPackageInputs -> IO () + +-- | Inputs to the package-wide post-configure step. +data PostConfPackageInputs = PostConfPackageInputs + { localBuildConfig :: LocalBuildConfig + , packageBuildDescr :: PackageBuildDescr + } + deriving (Generic, Show) + +-- | Per-component pre-configure step. +-- +-- For each component of the package, this hook can perform side effects, +-- and return a diff to the passed in component, e.g. to declare additional +-- autogenerated modules. +type PreConfComponentHook = PreConfComponentInputs -> IO PreConfComponentOutputs + +-- | Inputs to the per-component pre-configure step. +data PreConfComponentInputs = PreConfComponentInputs + { localBuildConfig :: LocalBuildConfig + , packageBuildDescr :: PackageBuildDescr + , component :: Component + } + deriving (Generic, Show) + +-- | Outputs of the per-component pre-configure step. +-- +-- Prefer using 'noPreComponentOutputs' and overriding the fields +-- you care about, to avoid depending on implementation details +-- of this datatype. +data PreConfComponentOutputs = PreConfComponentOutputs + { componentDiff :: ComponentDiff + } + deriving (Generic, Show) + +-- | Use this smart constructor to declare an empty set of changes +-- by a per-component pre-configure hook, and override the fields you +-- care about. +-- +-- Use this rather than v'PreConfComponentOutputs' to avoid relying on +-- internal implementation details of the latter. +noPreConfComponentOutputs :: PreConfComponentInputs -> PreConfComponentOutputs +noPreConfComponentOutputs (PreConfComponentInputs{component = comp}) = + PreConfComponentOutputs + { componentDiff = emptyComponentDiff (componentName comp) + } + +-- | Configure-time hooks. +-- +-- Order of execution: +-- +-- - 'preConfPackageHook', +-- - configure the package, +-- - 'postConfPackageHook', +-- - 'preConfComponentHook', +-- - configure the components. +data ConfigureHooks = ConfigureHooks + { preConfPackageHook :: Maybe PreConfPackageHook + -- ^ Package-wide pre-configure hook. See 'PreConfPackageHook'. + , postConfPackageHook :: Maybe PostConfPackageHook + -- ^ Package-wide post-configure hook. See 'PostConfPackageHook'. + , preConfComponentHook :: Maybe PreConfComponentHook + -- ^ Per-component pre-configure hook. See 'PreConfComponentHook'. + } + +-- Note: these configure hooks don't track any kind of dependency information, +-- so we won't know when the configuration is out of date and should be re-done. +-- This seems okay: it should only matter while developing the package, in which +-- case it seems acceptable to rely on the user re-configuring. + +instance Semigroup ConfigureHooks where + ConfigureHooks + { preConfPackageHook = prePkg1 + , postConfPackageHook = postPkg1 + , preConfComponentHook = preComp1 + } + <> ConfigureHooks + { preConfPackageHook = prePkg2 + , postConfPackageHook = postPkg2 + , preConfComponentHook = preComp2 + } = + ConfigureHooks + { preConfPackageHook = + coerce + ((<>) @(Maybe PreConfPkgSemigroup)) + prePkg1 + prePkg2 + , postConfPackageHook = + postPkg1 <> postPkg2 + , preConfComponentHook = + coerce + ((<>) @(Maybe PreConfComponentSemigroup)) + preComp1 + preComp2 + } + +instance Monoid ConfigureHooks where + mempty = noConfigureHooks + +-- | Empty configure phase hooks. +noConfigureHooks :: ConfigureHooks +noConfigureHooks = + ConfigureHooks + { preConfPackageHook = Nothing + , postConfPackageHook = Nothing + , preConfComponentHook = Nothing + } + +-- | A newtype to hang off the @Semigroup PreConfPackageHook@ instance. +newtype PreConfPkgSemigroup = PreConfPkgSemigroup PreConfPackageHook + +instance Semigroup PreConfPkgSemigroup where + PreConfPkgSemigroup f1 <> PreConfPkgSemigroup f2 = + PreConfPkgSemigroup $ + \inputs@( PreConfPackageInputs + { configFlags = cfg + , compiler = comp + , platform = plat + , localBuildConfig = lbc0 + } + ) -> + do + PreConfPackageOutputs + { buildOptions = opts1 + , extraConfiguredProgs = progs1 + } <- + f1 inputs + PreConfPackageOutputs + { buildOptions = opts2 + , extraConfiguredProgs = progs2 + } <- + f2 $ + PreConfPackageInputs + { configFlags = cfg + , compiler = comp + , platform = plat + , localBuildConfig = + lbc0 + { LBC.withPrograms = + updateConfiguredProgs (`Map.union` progs1) $ + LBC.withPrograms lbc0 + , LBC.withBuildOptions = opts1 + } + } + return $ + PreConfPackageOutputs + { buildOptions = opts2 + , extraConfiguredProgs = progs1 <> progs2 + } + +-- | A newtype to hang off the @Semigroup PreConfComponentHook@ instance. +newtype PreConfComponentSemigroup = PreConfComponentSemigroup PreConfComponentHook + +instance Semigroup PreConfComponentSemigroup where + PreConfComponentSemigroup f1 <> PreConfComponentSemigroup f2 = + PreConfComponentSemigroup $ \inputs -> + do + PreConfComponentOutputs + { componentDiff = diff1 + } <- + f1 inputs + PreConfComponentOutputs + { componentDiff = diff2 + } <- + f2 inputs + return $ + PreConfComponentOutputs + { componentDiff = diff1 <> diff2 + } + +-------------------------------------------------------------------------------- +-- Build setup hooks. + +data PreBuildComponentInputs = PreBuildComponentInputs + { buildingWhat :: BuildingWhat + -- ^ what kind of build phase are we hooking into? + , localBuildInfo :: LocalBuildInfo + -- ^ information about the package + , targetInfo :: TargetInfo + -- ^ information about an individual component + } + deriving (Generic, Show) + +type PreBuildComponentRules = Rules PreBuildComponentInputs + +data PostBuildComponentInputs = PostBuildComponentInputs + { buildFlags :: BuildFlags + , localBuildInfo :: LocalBuildInfo + , targetInfo :: TargetInfo + } + deriving (Generic, Show) + +type PostBuildComponentHook = PostBuildComponentInputs -> IO () + +-- | Build-time hooks. +data BuildHooks = BuildHooks + { preBuildComponentRules :: Maybe PreBuildComponentRules + -- ^ Per-component fine-grained pre-build rules. + , postBuildComponentHook :: Maybe PostBuildComponentHook + -- ^ Per-component post-build hook. + } + +-- Note that the pre-build hook consists of a function which takes a component +-- as an argument (as part of the targetInfo field) and returns a collection of +-- pre-build rules. +-- +-- One might wonder why it isn't instead a collection of pre-build rules, one +-- for each component. The reason is that Backpack creates components on-the-fly +-- through instantiation, which means e.g. that a single component name can +-- resolve to multiple components. This means we really need to pass in the +-- components to the function, as we don't know the full details (e.g. their +-- unit ids) ahead of time. + +instance Semigroup BuildHooks where + BuildHooks + { preBuildComponentRules = rs1 + , postBuildComponentHook = post1 + } + <> BuildHooks + { preBuildComponentRules = rs2 + , postBuildComponentHook = post2 + } = + BuildHooks + { preBuildComponentRules = rs1 <> rs2 + , postBuildComponentHook = post1 <> post2 + } + +instance Monoid BuildHooks where + mempty = noBuildHooks + +-- | Empty build hooks. +noBuildHooks :: BuildHooks +noBuildHooks = + BuildHooks + { preBuildComponentRules = Nothing + , postBuildComponentHook = Nothing + } + +-------------------------------------------------------------------------------- +-- Install setup hooks. + +data InstallComponentInputs = InstallComponentInputs + { copyFlags :: CopyFlags + , localBuildInfo :: LocalBuildInfo + , targetInfo :: TargetInfo + } + deriving (Generic, Show) + +-- | A per-component install hook, +-- which can only perform side effects (e.g. copying files). +type InstallComponentHook = InstallComponentInputs -> IO () + +-- | Copy/install hooks. +data InstallHooks = InstallHooks + { installComponentHook :: Maybe InstallComponentHook + -- ^ Per-component install hook. + } + +instance Semigroup InstallHooks where + InstallHooks + { installComponentHook = inst1 + } + <> InstallHooks + { installComponentHook = inst2 + } = + InstallHooks + { installComponentHook = inst1 <> inst2 + } + +instance Monoid InstallHooks where + mempty = noInstallHooks + +-- | Empty copy/install hooks. +noInstallHooks :: InstallHooks +noInstallHooks = + InstallHooks + { installComponentHook = Nothing + } + +-------------------------------------------------------------------------------- +-- Per-component configure hook implementation details. + +type LibraryDiff = Library +type ForeignLibDiff = ForeignLib +type ExecutableDiff = Executable +type TestSuiteDiff = TestSuite +type BenchmarkDiff = Benchmark +type BuildInfoDiff = BuildInfo + +-- | A diff to a Cabal 'Component', that gets combined monoidally into +-- an existing 'Component'. +newtype ComponentDiff = ComponentDiff {componentDiff :: Component} + deriving (Semigroup, Show) + +emptyComponentDiff :: ComponentName -> ComponentDiff +emptyComponentDiff name = ComponentDiff $ + case name of + CLibName{} -> CLib emptyLibrary + CFLibName{} -> CFLib emptyForeignLib + CExeName{} -> CExe emptyExecutable + CTestName{} -> CTest emptyTestSuite + CBenchName{} -> CBench emptyBenchmark + +buildInfoComponentDiff :: ComponentName -> BuildInfo -> ComponentDiff +buildInfoComponentDiff name bi = ComponentDiff $ + BI.buildInfo .~ bi $ + case name of + CLibName{} -> CLib emptyLibrary + CFLibName{} -> CFLib emptyForeignLib + CExeName{} -> CExe emptyExecutable + CTestName{} -> CTest emptyTestSuite + CBenchName{} -> CBench emptyBenchmark + +applyLibraryDiff :: Verbosity -> Library -> LibraryDiff -> IO Library +applyLibraryDiff verbosity lib diff = + case illegalLibraryDiffReasons lib diff of + [] -> return $ lib <> diff + (r : rs) -> + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff $ + IllegalComponentDiff (CLib lib) (r NE.:| rs) + +illegalLibraryDiffReasons :: Library -> LibraryDiff -> [IllegalComponentDiffReason] +illegalLibraryDiffReasons + lib + Library + { libName = nm + , libExposed = e + , libVisibility = vis + , libBuildInfo = bi + } = + [ CannotChangeName + | not $ nm == libName emptyLibrary || nm == libName lib + ] + ++ [ CannotChangeComponentField "libExposed" + | not $ e == libExposed emptyLibrary || e == libExposed lib + ] + ++ [ CannotChangeComponentField "libVisibility" + | not $ vis == libVisibility emptyLibrary || vis == libVisibility lib + ] + ++ illegalBuildInfoDiffReasons (libBuildInfo lib) bi + +applyForeignLibDiff :: Verbosity -> ForeignLib -> ForeignLibDiff -> IO ForeignLib +applyForeignLibDiff verbosity flib diff = + case illegalForeignLibDiffReasons flib diff of + [] -> return $ flib <> diff + (r : rs) -> + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff $ + IllegalComponentDiff (CFLib flib) (r NE.:| rs) + +illegalForeignLibDiffReasons :: ForeignLib -> ForeignLibDiff -> [IllegalComponentDiffReason] +illegalForeignLibDiffReasons + flib + ForeignLib + { foreignLibName = nm + , foreignLibType = ty + , foreignLibOptions = opts + , foreignLibVersionInfo = vi + , foreignLibVersionLinux = linux + , foreignLibModDefFile = defs + , foreignLibBuildInfo = bi + } = + [ CannotChangeName + | not $ nm == foreignLibName emptyForeignLib || nm == foreignLibName flib + ] + ++ [ CannotChangeComponentField "foreignLibType" + | not $ ty == foreignLibType emptyForeignLib || ty == foreignLibType flib + ] + ++ [ CannotChangeComponentField "foreignLibOptions" + | not $ opts == foreignLibOptions emptyForeignLib || opts == foreignLibOptions flib + ] + ++ [ CannotChangeComponentField "foreignLibVersionInfo" + | not $ vi == foreignLibVersionInfo emptyForeignLib || vi == foreignLibVersionInfo flib + ] + ++ [ CannotChangeComponentField "foreignLibVersionLinux" + | not $ linux == foreignLibVersionLinux emptyForeignLib || linux == foreignLibVersionLinux flib + ] + ++ [ CannotChangeComponentField "foreignLibModDefFile" + | not $ defs == foreignLibModDefFile emptyForeignLib || defs == foreignLibModDefFile flib + ] + ++ illegalBuildInfoDiffReasons (foreignLibBuildInfo flib) bi + +applyExecutableDiff :: Verbosity -> Executable -> ExecutableDiff -> IO Executable +applyExecutableDiff verbosity exe diff = + case illegalExecutableDiffReasons exe diff of + [] -> return $ exe <> diff + (r : rs) -> + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff $ + IllegalComponentDiff (CExe exe) (r NE.:| rs) + +illegalExecutableDiffReasons :: Executable -> ExecutableDiff -> [IllegalComponentDiffReason] +illegalExecutableDiffReasons + exe + Executable + { exeName = nm + , modulePath = path + , exeScope = scope + , buildInfo = bi + } = + [ CannotChangeName + | not $ nm == exeName emptyExecutable || nm == exeName exe + ] + ++ [ CannotChangeComponentField "modulePath" + | not $ path == modulePath emptyExecutable || path == modulePath exe + ] + ++ [ CannotChangeComponentField "exeScope" + | not $ scope == exeScope emptyExecutable || scope == exeScope exe + ] + ++ illegalBuildInfoDiffReasons (buildInfo exe) bi + +applyTestSuiteDiff :: Verbosity -> TestSuite -> TestSuiteDiff -> IO TestSuite +applyTestSuiteDiff verbosity test diff = + case illegalTestSuiteDiffReasons test diff of + [] -> return $ test <> diff + (r : rs) -> + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff $ + IllegalComponentDiff (CTest test) (r NE.:| rs) + +illegalTestSuiteDiffReasons :: TestSuite -> TestSuiteDiff -> [IllegalComponentDiffReason] +illegalTestSuiteDiffReasons + test + TestSuite + { testName = nm + , testInterface = iface + , testCodeGenerators = gens + , testBuildInfo = bi + } = + [ CannotChangeName + | not $ nm == testName emptyTestSuite || nm == testName test + ] + ++ [ CannotChangeComponentField "testInterface" + | not $ iface == testInterface emptyTestSuite || iface == testInterface test + ] + ++ [ CannotChangeComponentField "testCodeGenerators" + | not $ gens == testCodeGenerators emptyTestSuite || gens == testCodeGenerators test + ] + ++ illegalBuildInfoDiffReasons (testBuildInfo test) bi + +applyBenchmarkDiff :: Verbosity -> Benchmark -> BenchmarkDiff -> IO Benchmark +applyBenchmarkDiff verbosity bench diff = + case illegalBenchmarkDiffReasons bench diff of + [] -> return $ bench <> diff + (r : rs) -> + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff $ + IllegalComponentDiff (CBench bench) (r NE.:| rs) + +illegalBenchmarkDiffReasons :: Benchmark -> BenchmarkDiff -> [IllegalComponentDiffReason] +illegalBenchmarkDiffReasons + bench + Benchmark + { benchmarkName = nm + , benchmarkInterface = iface + , benchmarkBuildInfo = bi + } = + [ CannotChangeName + | not $ nm == benchmarkName emptyBenchmark || nm == benchmarkName bench + ] + ++ [ CannotChangeComponentField "benchmarkInterface" + | not $ iface == benchmarkInterface emptyBenchmark || iface == benchmarkInterface bench + ] + ++ illegalBuildInfoDiffReasons (benchmarkBuildInfo bench) bi + +illegalBuildInfoDiffReasons :: BuildInfo -> BuildInfoDiff -> [IllegalComponentDiffReason] +illegalBuildInfoDiffReasons + bi + BuildInfo + { buildable = can_build + , buildTools = build_tools + , buildToolDepends = build_tools_depends + , pkgconfigDepends = pkgconfig_depends + , frameworks = fworks + , targetBuildDepends = target_build_depends + } = + map CannotChangeBuildInfoField $ + [ "buildable" + | not $ can_build == buildable bi || can_build == buildable emptyBuildInfo + ] + ++ [ "buildTools" + | not $ build_tools == buildTools bi || build_tools == buildTools emptyBuildInfo + ] + ++ [ "buildToolsDepends" + | not $ build_tools_depends == buildToolDepends bi || build_tools_depends == buildToolDepends emptyBuildInfo + ] + ++ [ "pkgconfigDepends" + | not $ pkgconfig_depends == pkgconfigDepends bi || pkgconfig_depends == pkgconfigDepends emptyBuildInfo + ] + ++ [ "frameworks" + | not $ fworks == frameworks bi || fworks == frameworks emptyBuildInfo + ] + ++ [ "targetBuildDepends" + | not $ target_build_depends == targetBuildDepends bi || target_build_depends == targetBuildDepends emptyBuildInfo + ] + +-- | Traverse the components of a 'PackageDescription'. +-- +-- The function must preserve the component type, i.e. map a 'CLib' to a 'CLib', +-- a 'CExe' to a 'CExe', etc. +traverseComponents + :: Applicative m + => (Component -> m Component) + -> PackageDescription + -> m PackageDescription +traverseComponents f pd = + upd_pd + <$> traverse f_lib (library pd) + <*> traverse f_lib (subLibraries pd) + <*> traverse f_flib (foreignLibs pd) + <*> traverse f_exe (executables pd) + <*> traverse f_test (testSuites pd) + <*> traverse f_bench (benchmarks pd) + where + f_lib lib = \case { CLib lib' -> lib'; c -> mismatch (CLib lib) c } <$> f (CLib lib) + f_flib flib = \case { CFLib flib' -> flib'; c -> mismatch (CFLib flib) c } <$> f (CFLib flib) + f_exe exe = \case { CExe exe' -> exe'; c -> mismatch (CExe exe) c } <$> f (CExe exe) + f_test test = \case { CTest test' -> test'; c -> mismatch (CTest test) c } <$> f (CTest test) + f_bench bench = \case { CBench bench' -> bench'; c -> mismatch (CBench bench) c } <$> f (CBench bench) + + upd_pd lib sublibs flibs exes tests benchs = + pd + { library = lib + , subLibraries = sublibs + , foreignLibs = flibs + , executables = exes + , testSuites = tests + , benchmarks = benchs + } + + -- This is a panic, because we maintain this invariant elsewhere: + -- see 'componentDiffError' in 'applyComponentDiff', which catches an + -- invalid per-component configure hook. + mismatch c1 c2 = + error $ + "Mismatched component types: " + ++ showComponentName (componentName c1) + ++ " " + ++ showComponentName (componentName c2) + ++ "." +{-# INLINEABLE traverseComponents #-} + +applyComponentDiffs + :: Verbosity + -> (Component -> IO (Maybe ComponentDiff)) + -> PackageDescription + -> IO PackageDescription +applyComponentDiffs verbosity f = traverseComponents apply_diff + where + apply_diff :: Component -> IO Component + apply_diff c = do + mbDiff <- f c + case mbDiff of + Just diff -> applyComponentDiff verbosity c diff + Nothing -> return c + +forComponents_ :: PackageDescription -> (Component -> IO ()) -> IO () +forComponents_ pd f = getConst $ traverseComponents (Const . f) pd + +applyComponentDiff + :: Verbosity + -> Component + -> ComponentDiff + -> IO Component +applyComponentDiff verbosity comp (ComponentDiff diff) + | CLib lib <- comp + , CLib lib_diff <- diff = + CLib <$> applyLibraryDiff verbosity lib lib_diff + | CFLib flib <- comp + , CFLib flib_diff <- diff = + CFLib <$> applyForeignLibDiff verbosity flib flib_diff + | CExe exe <- comp + , CExe exe_diff <- diff = + CExe <$> applyExecutableDiff verbosity exe exe_diff + | CTest test <- comp + , CTest test_diff <- diff = + CTest <$> applyTestSuiteDiff verbosity test test_diff + | CBench bench <- comp + , CBench bench_diff <- diff = + CBench <$> applyBenchmarkDiff verbosity bench bench_diff + | otherwise = + componentDiffError $ MismatchedComponentTypes comp diff + where + -- The per-component configure hook specified a diff of the wrong type, + -- e.g. tried to apply an executable diff to a library. + componentDiffError err = + dieWithException verbosity $ + SetupHooksException $ + CannotApplyComponentDiff err + +-------------------------------------------------------------------------------- +-- Running pre-build rules + +-- | Run all pre-build rules. +-- +-- This function should only be called internally within @Cabal@, as it is used +-- to implement the (legacy) Setup.hs interface. The build tool +-- (e.g. @cabal-install@ or @hls@) should instead go through the separate +-- hooks executable, which allows us to only rerun the out-of-date rules +-- (instead of running all of these rules at once). +executeRules + :: Verbosity + -> LocalBuildInfo + -> TargetInfo + -> Map RuleId Rule + -> IO () +executeRules = + executeRulesUserOrSystem + SUser + (\_rId cmd -> sequenceA $ runRuleDynDepsCmd cmd) + (\_rId cmd -> runRuleExecCmd cmd) + +-- | Like 'executeRules', except it can be used when communicating with +-- an external hooks executable. +executeRulesUserOrSystem + :: forall userOrSystem + . SScope userOrSystem + -> (RuleId -> RuleDynDepsCmd userOrSystem -> IO (Maybe ([Rule.Dependency], LBS.ByteString))) + -> (RuleId -> RuleExecCmd userOrSystem -> IO ()) + -> Verbosity + -> LocalBuildInfo + -> TargetInfo + -> Map RuleId (RuleData userOrSystem) + -> IO () +executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo allRules = do + -- Compute all extra dynamic dependency edges. + dynDepsEdges <- + flip Map.traverseMaybeWithKey allRules $ + \rId (Rule{ruleCommands = cmds}) -> + runDepsCmdData rId (ruleDepsCmd cmds) + + -- Create a build graph of all the rules, with static and dynamic dependencies + -- as edges. + let + (ruleGraph, ruleFromVertex, vertexFromRuleId) = + Graph.graphFromEdges + [ (rule, rId, nub $ mapMaybe directRuleDependencyMaybe allDeps) + | (rId, rule) <- Map.toList allRules + , let dynDeps = fromMaybe [] (fst <$> Map.lookup rId dynDepsEdges) + allDeps = staticDependencies rule ++ dynDeps + ] + + -- Topologically sort the graph of rules. + sccs = Graph.scc ruleGraph + cycles = mapMaybe $ \(Graph.Node v0 subforest) -> + case subforest of + [] + | r@(_, rId, deps) <- ruleFromVertex v0 -> + if rId `elem` deps + then Just (r, []) + else Nothing + v : vs -> + Just + ( ruleFromVertex v0 + , map (fmap ruleFromVertex) (v : vs) + ) + + -- Compute demanded rules. + -- + -- SetupHooks TODO: maybe requiring all generated modules to appear + -- in autogen-modules is excessive; we can look through all modules instead. + autogenModPaths = + map (\m -> toFilePath m <.> "hs") $ + autogenModules $ + componentBuildInfo $ + targetComponent tgtInfo + leafRule_maybe (rId, r) = + if any ((r `ruleOutputsLocation`) . (compAutogenDir,)) autogenModPaths + then vertexFromRuleId rId + else Nothing + leafRules = mapMaybe leafRule_maybe $ Map.toList allRules + demandedRuleVerts = Set.fromList $ concatMap (Graph.reachable ruleGraph) leafRules + nonDemandedRuleVerts = Set.fromList (Graph.vertices ruleGraph) Set.\\ demandedRuleVerts + + case cycles sccs of + -- If there are cycles in the dependency structure, don't execute + -- any rules at all; just throw an error right off the bat. + r : rs -> + let getRule ((ru, _, _), js) = (toRuleBinary ru, fmap (fmap (\(rv, _, _) -> toRuleBinary rv)) js) + in errorOut $ + CyclicRuleDependencies $ + fmap getRule (r NE.:| rs) + -- Otherwise, run all the demanded rules in dependency order (in one go). + -- (Fine-grained running of rules should happen in cabal-install or HLS, + -- not in the Cabal library.) + [] -> do + -- Emit a warning if there are non-demanded rules. + unless (null nonDemandedRuleVerts) $ + warn verbosity $ + unlines $ + "The following rules are not demanded and will not be run:" + : [ " - " ++ show rId ++ ", generating " ++ showLocs (NE.toList $ results r) + | v <- Set.toList nonDemandedRuleVerts + , let (r, rId, _) = ruleFromVertex v + ] + ++ [ "Possible reasons for this error:" + , " - Some autogenerated modules were not declared" + , " (in the package description or in the pre-configure hooks)" + , " - The output location for an autogenerated module is incorrect," + , " (e.g. it is not in the appropriate 'autogenComponentModules' directory)" + ] + + -- Run all the demanded rules, in dependency order. + for_ sccs $ \(Graph.Node ruleVertex _) -> + -- Don't run a rule unless it is demanded. + unless (ruleVertex `Set.member` nonDemandedRuleVerts) $ do + let ( r@Rule + { ruleCommands = cmds + , staticDependencies = staticDeps + , results = reslts + } + , rId + , _staticRuleDepIds + ) = + ruleFromVertex ruleVertex + mbDyn = Map.lookup rId dynDepsEdges + allDeps = staticDeps ++ fromMaybe [] (fst <$> mbDyn) + -- Check that the dependencies the rule expects are indeed present. + resolvedDeps <- traverse (resolveDependency verbosity rId allRules) allDeps + missingRuleDeps <- filterM missingDep resolvedDeps + case NE.nonEmpty missingRuleDeps of + Just missingDeps -> + errorOut $ CantFindSourceForRuleDependencies (toRuleBinary r) missingDeps + -- Dependencies OK: run the associated action. + Nothing -> do + let execCmd = ruleExecCmd scope cmds (snd <$> mbDyn) + runCmdData rId execCmd + -- Throw an error if running the action did not result in + -- the generation of outputs that we expected it to. + missingRuleResults <- filterM missingDep $ NE.toList reslts + for_ (NE.nonEmpty missingRuleResults) $ \missingResults -> + errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults + return () + where + toRuleBinary :: RuleData userOrSystem -> RuleBinary + toRuleBinary = case scope of + SUser -> ruleBinary + SSystem -> id + clbi = targetCLBI tgtInfo + compAutogenDir = getSymbolicPath $ autogenComponentModulesDir lbi clbi + errorOut e = + dieWithException verbosity $ + SetupHooksException $ + RulesException e + +directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId +directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep +directRuleDependencyMaybe (FileDependency{}) = Nothing + +resolveDependency :: Verbosity -> RuleId -> Map RuleId (RuleData scope) -> Rule.Dependency -> IO Location +resolveDependency verbosity rId allRules = \case + FileDependency l -> return l + RuleDependency (RuleOutput{outputOfRule = depId, outputIndex = i}) -> + case Map.lookup depId allRules of + Nothing -> + error $ + unlines $ + [ "Internal error: missing rule dependency." + , "Rule: " ++ show rId + , "Dependency: " ++ show depId + ] + Just (Rule{results = os}) -> + let j :: Int + j = fromIntegral i + in case listToMaybe $ drop j $ NE.toList os of + Just o + | j >= 0 -> + return o + _ -> + dieWithException verbosity $ + SetupHooksException $ + RulesException $ + InvalidRuleOutputIndex rId depId os i + +-- | Does the rule output the given location? +ruleOutputsLocation :: RuleData scope -> Location -> Bool +ruleOutputsLocation (Rule{results = rs}) fp = + any (\out -> normaliseLocation out == normaliseLocation fp) rs + +normaliseLocation :: Location -> Location +normaliseLocation (base, rel) = (normalise base, normalise rel) + +-- | Is the file we depend on missing? +missingDep :: Location -> IO Bool +missingDep (base, fp) = not <$> doesFileExist (base fp) + +-------------------------------------------------------------------------------- +-- Compatibility with HookedBuildInfo. +-- +-- NB: assumes that the components in HookedBuildInfo are: +-- - an (optional) main library, +-- - executables. +-- +-- No support for named sublibraries, foreign libraries, tests or benchmarks, +-- because the HookedBuildInfo datatype doesn't specify what type of component +-- each component name is (so we assume they are executables). + +hookedBuildInfoComponents :: HookedBuildInfo -> Set ComponentName +hookedBuildInfoComponents (mb_mainlib, exes) = + Set.fromList $ + (case mb_mainlib of Nothing -> id; Just{} -> (CLibName LMainLibName :)) + [CExeName exe_nm | (exe_nm, _) <- exes] + +hookedBuildInfoComponentDiff_maybe :: HookedBuildInfo -> ComponentName -> Maybe (IO ComponentDiff) +hookedBuildInfoComponentDiff_maybe (mb_mainlib, exes) comp_nm = + case comp_nm of + CLibName lib_nm -> + case lib_nm of + LMainLibName -> return . ComponentDiff . CLib . buildInfoLibraryDiff <$> mb_mainlib + LSubLibName{} -> Nothing + CExeName exe_nm -> + let mb_exe = lookup exe_nm exes + in return . ComponentDiff . CExe . buildInfoExecutableDiff <$> mb_exe + CFLibName{} -> Nothing + CTestName{} -> Nothing + CBenchName{} -> Nothing + +buildInfoLibraryDiff :: BuildInfo -> LibraryDiff +buildInfoLibraryDiff bi = emptyLibrary{libBuildInfo = bi} + +buildInfoExecutableDiff :: BuildInfo -> ExecutableDiff +buildInfoExecutableDiff bi = emptyExecutable{buildInfo = bi} + +-------------------------------------------------------------------------------- +-- Instances for serialisation + +deriving newtype instance Binary ComponentDiff +deriving newtype instance Structured ComponentDiff + +instance Binary PreConfPackageInputs +instance Structured PreConfPackageInputs +instance Binary PreConfPackageOutputs +instance Structured PreConfPackageOutputs + +instance Binary PostConfPackageInputs +instance Structured PostConfPackageInputs + +instance Binary PreConfComponentInputs +instance Structured PreConfComponentInputs +instance Binary PreConfComponentOutputs +instance Structured PreConfComponentOutputs + +instance Binary PreBuildComponentInputs +instance Structured PreBuildComponentInputs + +instance Binary PostBuildComponentInputs +instance Structured PostBuildComponentInputs + +instance Binary InstallComponentInputs +instance Structured InstallComponentInputs + +-------------------------------------------------------------------------------- diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs index 7e750245085..afbabb859f6 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 443fc87ae58..eb9096271ef 100644 --- a/Cabal/src/Distribution/Simple/SrcDist.hs +++ b/Cabal/src/Distribution/Simple/SrcDist.hs @@ -276,6 +276,8 @@ listPackageSources' verbosity rip mbWorkDir pkg_descr pps = traverse (fmap (makeSymbolicPath . snd) . findIncludeFile verbosity cwd relincdirs) incls , -- Setup script, if it exists. fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupFile cwd + , -- SetupHooks script, if it exists. + fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupHooksFile cwd , -- The .cabal file itself. fmap (\d -> [d]) (coerceSymbolicPath . relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir) ] @@ -325,6 +327,21 @@ findSetupFile targetDir = do setupHs = "Setup.hs" setupLhs = "Setup.lhs" +-- | Find the setup hooks script file, if it exists. +findSetupHooksFile :: FilePath -> IO (Maybe FilePath) +findSetupHooksFile targetDir = do + hsExists <- doesFileExist (targetDir setupHs) + lhsExists <- doesFileExist (targetDir setupLhs) + if hsExists + then return (Just setupHs) + else + if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = "SetupHooks.hs" + setupLhs = "SetupHooks.lhs" + -- | Create a default setup script in the target directory, if it doesn't exist. maybeCreateDefaultSetupScript :: FilePath -> IO () maybeCreateDefaultSetupScript targetDir = do diff --git a/Cabal/src/Distribution/Simple/Test.hs b/Cabal/src/Distribution/Simple/Test.hs index 3d364ae44b2..4b4ddb7e342 100644 --- a/Cabal/src/Distribution/Simple/Test.hs +++ b/Cabal/src/Distribution/Simple/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} diff --git a/Cabal/src/Distribution/Simple/UserHooks.hs b/Cabal/src/Distribution/Simple/UserHooks.hs index b27cd0b875f..75ab4a6bedf 100644 --- a/Cabal/src/Distribution/Simple/UserHooks.hs +++ b/Cabal/src/Distribution/Simple/UserHooks.hs @@ -32,7 +32,7 @@ module Distribution.Simple.UserHooks , emptyUserHooks ) where -import Distribution.Compat.Prelude +import Distribution.Compat.Prelude hiding (getContents, putStr) import Prelude () import Distribution.PackageDescription diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 8c30cc18abb..6d440b78062 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -114,6 +114,7 @@ module Distribution.Simple.Utils , findFileEx , findFileCwd , findFirstFile + , Suffix (..) , findFileWithExtension , findFileCwdWithExtension , findFileWithExtension' diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 37e0cbdf1ee..66a0a103c23 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -630,7 +630,7 @@ addDefaultSetupDependencies defaultSetupDeps params = } } where - isCustom = PD.buildType pkgdesc == PD.Custom + isCustom = PD.buildType pkgdesc == PD.Custom || PD.buildType pkgdesc == PD.Hooks gpkgdesc = srcpkgDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc @@ -729,7 +729,7 @@ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = gpkgdesc = srcpkgDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc bt = PD.buildType pkgdesc - affected = bt == PD.Custom && hasBuildableFalse gpkgdesc + affected = (bt == PD.Custom || bt == PD.Hooks) && hasBuildableFalse gpkgdesc -- Does this package contain any components with non-empty 'build-depends' -- and a 'buildable' field that could potentially be set to 'False'? False diff --git a/cabal-install/src/Distribution/Client/Init/Defaults.hs b/cabal-install/src/Distribution/Client/Init/Defaults.hs index 9be998feda7..a915a5159d3 100644 --- a/cabal-install/src/Distribution/Client/Init/Defaults.hs +++ b/cabal-install/src/Distribution/Client/Init/Defaults.hs @@ -135,6 +135,7 @@ defaultCabalVersions = , CabalSpecV2_4 , CabalSpecV3_0 , CabalSpecV3_4 + , CabalSpecV3_14 ] defaultInitFlags :: InitFlags diff --git a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs index 1e08e843d6f..48209d37067 100644 --- a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs +++ b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs @@ -313,6 +313,7 @@ cabalVersionPrompt flags = getCabalVersion flags $ do parseCabalVersion "3.0" = CabalSpecV3_0 parseCabalVersion "3.4" = CabalSpecV3_4 parseCabalVersion "3.12" = CabalSpecV3_12 + parseCabalVersion "3.14" = CabalSpecV3_14 parseCabalVersion _ = defaultCabalVersion -- 2.4 displayCabalVersion :: CabalSpecVersion -> String displayCabalVersion v = case v of @@ -321,6 +322,7 @@ cabalVersionPrompt flags = getCabalVersion flags $ do CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)" CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)" CabalSpecV3_4 -> "3.4 (+ sublibraries in 'mixins', optional 'default-language')" + CabalSpecV3_14 -> "3.14 (+ build-type: Hooks)" _ -> showCabalSpecVersion v packageNamePrompt :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 2de2e48f3e4..de14fc129c9 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -1474,6 +1474,7 @@ actAsSetupAction actAsSetupFlags args _globalFlags = Simple.autoconfUserHooks args Make -> Make.defaultMainArgs args + Hooks -> error "actAsSetupAction Hooks" Custom -> error "actAsSetupAction Custom" manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index cdde7d48062..38a59b9818c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1631,6 +1631,7 @@ elaborateInstallPlan 4 (vcat (map (text . componentNameStanza) cns)) where + bt = PD.buildType (elabPkgDescription elab0) -- You are eligible to per-component build if this list is empty why_not_per_component g = cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag @@ -1646,11 +1647,12 @@ elaborateInstallPlan -- type, and teach all of the code paths how to handle it. -- Once you've implemented this, swap it for the code below. cuz_buildtype = - case PD.buildType (elabPkgDescription elab0) of + case bt of PD.Configure -> [CuzBuildType CuzConfigureBuildType] PD.Custom -> [CuzBuildType CuzCustomBuildType] + PD.Hooks -> [CuzBuildType CuzHooksBuildType] PD.Make -> [CuzBuildType CuzMakeBuildType] - _ -> [] + PD.Simple -> [] -- cabal-format versions prior to 1.8 have different build-depends semantics -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 -- see, https://github.com/haskell/cabal/issues/4121 @@ -1694,7 +1696,7 @@ elaborateInstallPlan -- have to add dependencies on this from all other components setupComponent :: Maybe ElaboratedConfiguredPackage setupComponent - | PD.buildType (elabPkgDescription elab0) == PD.Custom = + | bt `elem` [PD.Custom, PD.Hooks] = Just elab0 { elabModuleShape = emptyModuleShape @@ -3678,7 +3680,14 @@ setupHsScriptOptions cacheLock = SetupScriptOptions { useCabalVersion = thisVersion elabSetupScriptCliVersion - , useCabalSpecVersion = Just elabSetupScriptCliVersion + , useCabalSpecVersion = + if PD.buildType elabPkgDescription == PD.Hooks + then -- NB: we don't want to commit to a Cabal version here: + -- - all that should matter for Hooks build-type is the + -- version of Cabal-hooks, not of Cabal, + -- - if we commit to a Cabal version, the logic in + Nothing + else Just elabSetupScriptCliVersion , useCompiler = Just pkgConfigCompiler , usePlatform = Just pkgConfigPlatform , usePackageDB = elabSetupPackageDBStack diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs index 86bc044342e..212a5d93f81 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs @@ -59,17 +59,17 @@ import qualified Distribution.Compat.Graph as Graph -- @since 3.12.0.0 packageSetupScriptStyle :: PackageDescription -> SetupScriptStyle packageSetupScriptStyle pkg - | buildType pkg == Custom + | customOrHooks , Just setupbi <- setupBuildInfo pkg -- does have a custom-setup stanza , not (defaultSetupDepends setupbi) -- but not one we added ourselves = SetupCustomExplicitDeps - | buildType pkg == Custom + | customOrHooks , Just setupbi <- setupBuildInfo pkg -- does have a custom-setup stanza , defaultSetupDepends setupbi -- that we had to add ourselves = SetupCustomImplicitDeps - | buildType pkg == Custom + | customOrHooks , Nothing <- setupBuildInfo pkg -- we get this case pre-solver = SetupCustomImplicitDeps @@ -79,6 +79,8 @@ packageSetupScriptStyle pkg SetupNonCustomExternalLib | otherwise = SetupNonCustomInternalLib + where + customOrHooks = buildType pkg `elem` [Custom, Hooks] -- | Part of our Setup.hs handling policy is implemented by getting the solver -- to work out setup dependencies for packages. The solver already handles diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index f344db1e389..5b4896b0568 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -762,6 +762,7 @@ data NotPerComponentReason data NotPerComponentBuildType = CuzConfigureBuildType | CuzCustomBuildType + | CuzHooksBuildType | CuzMakeBuildType deriving (Eq, Show, Generic) @@ -779,6 +780,7 @@ whyNotPerComponent = \case "build-type is " ++ case bt of CuzConfigureBuildType -> "Configure" CuzCustomBuildType -> "Custom" + CuzHooksBuildType -> "Hooks" CuzMakeBuildType -> "Make" CuzCabalSpecVersion -> "cabal-version is less than 1.8" CuzNoBuildableComponents -> "there are no buildable components" diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index f5432dad1c2..0fc5e89f1bc 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -156,6 +156,7 @@ import Distribution.Simple.Utils , copyFileVerbose , createDirectoryIfMissingVerbose , debug + , die' , dieWithException , info , infoNoWrap @@ -405,6 +406,7 @@ getSetupMethod -> IO (Version, SetupMethod, SetupScriptOptions) getSetupMethod verbosity options pkg buildType' | buildType' == Custom + || buildType' == Hooks || maybe False (cabalVersion /=) (useCabalSpecVersion options) || not (cabalVersion `withinRange` useCabalVersion options) = getExternalSetupMethod verbosity options pkg buildType' @@ -556,6 +558,7 @@ buildTypeAction Configure = Simple.defaultMainWithHooksArgs Simple.autoconfUserHooks buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Hooks = error "buildTypeAction Hooks" buildTypeAction Custom = error "buildTypeAction Custom" invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () @@ -712,6 +715,7 @@ getExternalSetupMethod verbosity options pkg bt = do setupDir = useDistPref options Cabal.Path. makeRelativePathEx "setup" setupVersionFile = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> "version") setupHs = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> "hs") + setupHooks = setupDir Cabal.Path. makeRelativePathEx ("SetupHooks" <.> "hs") setupProgFile = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> exeExtension buildPlatform) platform = fromMaybe buildPlatform (usePlatform options) @@ -838,6 +842,17 @@ getExternalSetupMethod verbosity options pkg bt = do where customSetupHs = workingDir options "Setup.hs" customSetupLhs = workingDir options "Setup.lhs" + updateSetupScript cabalLibVersion Hooks = do + + let customSetupHooks = workingDir options "SetupHooks.hs" + useHs <- doesFileExist customSetupHooks + unless (useHs) $ + die' + verbosity + "Using 'build-type: Hooks' but there is no SetupHooks.hs file." + copyFileVerbose verbosity customSetupHooks (i setupHooks) + rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) +-- rewriteFileLBS verbosity hooksHs hooksScript updateSetupScript cabalLibVersion _ = rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) @@ -848,6 +863,7 @@ getExternalSetupMethod verbosity options pkg bt = do | cabalLibVersion >= mkVersion [1, 3, 10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n" | otherwise -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n" Make -> "import Distribution.Make; main = defaultMain\n" + Hooks -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n" Custom -> error "buildTypeScript Custom" installedCabalVersion @@ -1049,26 +1065,18 @@ getExternalSetupMethod verbosity options pkg bt = do (\ipkgid -> [(ipkgid, cabalPkgid)]) maybeCabalLibInstalledPkgId - -- With 'useDependenciesExclusive' we enforce the deps specified, - -- so only the given ones can be used. Otherwise we allow the use - -- of packages in the ambient environment, and add on a dep on the - -- Cabal library (unless 'useDependencies' already contains one). - -- - -- With 'useVersionMacros' we use a version CPP macros .h file. - -- - -- Both of these options should be enabled for packages that have - -- opted-in and declared a custom-settup stanza. - -- + -- With 'useDependenciesExclusive' and Custom build type, + -- we enforce the deps specified, so only the given ones can be used. + -- Otherwise we add on a dep on the Cabal library + -- (unless 'useDependencies' already contains one). selectedDeps - | useDependenciesExclusive options' = - useDependencies options' + | (useDependenciesExclusive options' && (bt /= Hooks)) + -- NB: to compile build-type: Hooks packages, we need Cabal + -- in order to compile @main = defaultMainWithSetupHooks setupHooks@. + || any (isCabalPkgId . snd) (useDependencies options') + = useDependencies options' | otherwise = - useDependencies options' - ++ if any - (isCabalPkgId . snd) - (useDependencies options') - then [] - else cabalDep + useDependencies options' ++ cabalDep addRenaming (ipid, _) = -- Assert 'DefUnitId' invariant ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) @@ -1089,11 +1097,13 @@ getExternalSetupMethod verbosity options pkg bt = do , ghcOptSourcePathClear = Flag True , ghcOptSourcePath = case bt of Custom -> toNubListR [sameDirectory] + Hooks -> toNubListR [sameDirectory] _ -> mempty , ghcOptPackageDBs = usePackageDB options'' , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') , ghcOptCabal = Flag (useDependenciesExclusive options') , ghcOptPackages = toNubListR $ map addRenaming selectedDeps + -- With 'useVersionMacros', use a version CPP macros .h file. , ghcOptCppIncludes = toNubListR [ cppMacrosFile diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/SetupHooks.hs new file mode 100644 index 00000000000..d81c48d93e4 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/SetupHooks.hs @@ -0,0 +1,18 @@ +module SetupHooks where + +import Distribution.Simple.SetupHooks + +import Control.Monad ( void ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { configureHooks = + noConfigureHooks + { preConfComponentHook = Just pccHook } + } + +pccHook :: PreConfComponentHook +pccHook _ = return $ + PreConfComponentOutputs $ ComponentDiff $ CExe emptyExecutable + -- Bad: component is a library, but we returned an executable! diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup-hooks-bad-diff1-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup-hooks-bad-diff1-test.cabal new file mode 100644 index 00000000000..37e0db3efda --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup-hooks-bad-diff1-test.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.14 +name: setup-hooks-bad-diff1-test +version: 0.1.0.0 +synopsis: Test 1 for a bad component diff +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.out new file mode 100644 index 00000000000..2fdce2d44c0 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring setup-hooks-bad-diff1-test-0.1.0.0... +Error: [Cabal-9491] +Hooks: mismatched component types in per-component configure hook. +Trying to apply an executable diff to a library. diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.test.hs new file mode 100644 index 00000000000..0096ff04cef --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff1/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = setupTest $ do + fails $ setup "configure" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/SetupHooks.hs new file mode 100644 index 00000000000..1c79900b639 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/SetupHooks.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SetupHooks where + +import Distribution.Simple.SetupHooks + +import Control.Monad ( void ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { configureHooks = + noConfigureHooks + { preConfComponentHook = Just pccHook } + } + +pccHook :: PreConfComponentHook +pccHook _ = return $ + -- Make invalid changes to a library + PreConfComponentOutputs $ ComponentDiff $ CLib $ + emptyLibrary + { libName = LSubLibName "hocus-pocus" + , libExposed = False + , libBuildInfo = + emptyBuildInfo + { buildable = False } + } diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup-hooks-bad-diff2-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup-hooks-bad-diff2-test.cabal new file mode 100644 index 00000000000..8f3bd230ab1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup-hooks-bad-diff2-test.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.14 +name: setup-hooks-bad-diff2-test +version: 0.1.0.0 +synopsis: Test 2 for a bad component diff +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.out new file mode 100644 index 00000000000..0c9286b42dc --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring setup-hooks-bad-diff2-test-0.1.0.0... +Error: [Cabal-7634] +Hooks: illegal component diff in per-component pre-configure hook for main library: + - cannot change the name of a component. + - cannot change component field 'libExposed'. + - cannot change BuildInfo field 'buildable'. diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.test.hs new file mode 100644 index 00000000000..0096ff04cef --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksBadDiff2/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = setupTest $ do + fails $ setup "configure" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A1.myChs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A1.myChs new file mode 100644 index 00000000000..5a5ad78c46c --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A1.myChs @@ -0,0 +1,5 @@ +imports: + +import X +foo1 :: Double +foo1 = x diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A2.myChs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A2.myChs new file mode 100644 index 00000000000..8e504be4e14 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/A2.myChs @@ -0,0 +1,4 @@ +imports: + +foo2 :: Double +foo2 = 3.000003 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/B.myChs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/B.myChs new file mode 100644 index 00000000000..b6fa9fbb8ec --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/B.myChs @@ -0,0 +1,4 @@ +imports: A1 A2 + +bar :: Double +bar = foo1 + foo2 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/C.myChs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/C.myChs new file mode 100644 index 00000000000..44365beb319 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/C.myChs @@ -0,0 +1,4 @@ +imports: B + +quux :: Double +quux = bar + 11 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/D.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/D.hs new file mode 100644 index 00000000000..77fedb97265 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/D.hs @@ -0,0 +1,6 @@ +module D where + +import C + +xyzzy :: Double +xyzzy = 10 * quux diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs new file mode 100644 index 00000000000..67ac7b8ee1d --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Compat.Binary +import Distribution.ModuleName +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks +import Distribution.Simple.Utils + +import Data.Foldable ( for_ ) +import Data.List ( isPrefixOf ) +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) +import Data.String +import Data.Traversable ( for ) +import GHC.Generics + +import qualified Data.Map as Map +import System.FilePath + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) preBuildRules + } + } + +preBuildRules :: PreBuildComponentInputs -> RulesM () +preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = mdo + let verbosity = buildingWhatVerbosity what + clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + buildDir = i (componentBuildDir lbi clbi) + + computeC2HsDepsAction (C2HsDepsInput {..}) = do + importLine : _srcLines <- lines <$> readFile (inDir toFilePath modNm <.> "myChs") + let imports :: [ModuleName] + imports + | "imports:" `isPrefixOf` importLine + = map fromString $ words $ drop 8 importLine + | otherwise + = error "Malformed MyChs file: first line should start with 'imports:'" + warn verbosity $ "Computed C2Hs dependencies of " ++ modName modNm ++ ".myChs: " + ++ modNames imports + return $ + ( [ RuleDependency $ RuleOutput rId 1 + | imp <- imports + , let rId = ruleIds Map.! imp ] + , imports ) + + runC2HsAction (C2HsInput {..}) importModNms = do + let modPath = toFilePath modNm + warn verbosity $ "Running C2Hs on " ++ modName modNm ++ ".myChs.\n C2Hs dependencies: " ++ modNames importModNms + _importLine : srcLines <- lines <$> readFile (inDir modPath <.> "myChs") + + rewriteFileEx verbosity (hsDir modPath <.> "hs") $ + unlines $ ("module " ++ modName modNm ++ " where\n") : + (map ( ( "import " ++ ) . modName ) importModNms ++ srcLines) + rewriteFileEx verbosity (chiDir modPath <.> "myChi") "" + + mkRule modNm = + dynamicRule (static Dict) + (mkCommand (static Dict) (static computeC2HsDepsAction) $ C2HsDepsInput { ruleIds = modToRuleId, ..}) + (mkCommand (static Dict) (static runC2HsAction) $ C2HsInput {hsDir = autogenDir, chiDir = buildDir, ..}) + [ FileDependency (inDir, modPath <.> "myChs") ] + ( ( autogenDir, modPath <.> "hs" ) NE.:| [ ( buildDir, modPath <.> "myChi" ) ] ) + where + modPath = toFilePath modNm + inDir = "." + + -- NB: in practice, we would get the module names by looking at the .cabal + -- file and performing a search for `.chs` files on disk, but for this test + -- we bake this in for simplicity. + let mods = Map.fromList [ ((ix, fromString modNm), ()) + | (ix, modNm) <- [ (0, "C"), (1, "A1"), (2, "B"), (3, "A2") ] ] + -- NB: the extra indices are to ensure the traversal happens in a particular order, + -- which ensures we correctly re-order rules to execute them in dependency order. + modToRuleId <- fmap (Map.mapKeys snd) $ flip Map.traverseWithKey mods $ \ (i, modNm) () -> + registerRule ("C2Hs " <> fromString (show i ++ " " ++ modName modNm)) $ mkRule modNm + return () + +-- | Input to C2Hs dependency computation +data C2HsDepsInput + = C2HsDepsInput + { verbosity :: Verbosity + , inDir :: FilePath + , modNm :: ModuleName + , ruleIds :: Map.Map ModuleName RuleId + } + deriving stock ( Show, Generic ) + deriving anyclass Binary + +-- | Input to C2Hs command +data C2HsInput + = C2HsInput + { verbosity :: Verbosity + , modNm :: ModuleName + , inDir :: FilePath + , hsDir :: FilePath + , chiDir :: FilePath + } + deriving stock ( Show, Generic ) + deriving anyclass Binary + +modName :: ModuleName -> String +modName = intercalate "." . components + +modNames :: [ModuleName] -> String +modNames mns = "[" ++ intercalate ", " (map modName mns) ++ "]" diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/X.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/X.hs new file mode 100644 index 00000000000..823630037be --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/X.hs @@ -0,0 +1,4 @@ +module X where + +x :: Double +x = 123456789 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup-hooks-c2hs-rules-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup-hooks-c2hs-rules-test.cabal new file mode 100644 index 00000000000..e0627cb71b4 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup-hooks-c2hs-rules-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-c2hs-rules-test +version: 0.1.0.0 +synopsis: Test implementing a C2Hs-like preprocessor +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal, Cabal-hooks, base, filepath, containers + +library + exposed-modules: A1, A2, B, C, D, X + autogen-modules: A1, A2, B, C, D, X + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.out new file mode 100644 index 00000000000..11c1647571b --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.out @@ -0,0 +1,17 @@ +# Setup configure +Configuring setup-hooks-c2hs-rules-test-0.1.0.0... +# Setup build +Warning: Computed C2Hs dependencies of C.myChs: [B] +Warning: Computed C2Hs dependencies of A1.myChs: [] +Warning: Computed C2Hs dependencies of B.myChs: [A1, A2] +Warning: Computed C2Hs dependencies of A2.myChs: [] +Warning: Running C2Hs on A2.myChs. + C2Hs dependencies: [] +Warning: Running C2Hs on A1.myChs. + C2Hs dependencies: [] +Warning: Running C2Hs on B.myChs. + C2Hs dependencies: [A1, A2] +Warning: Running C2Hs on C.myChs. + C2Hs dependencies: [B] +Preprocessing library for setup-hooks-c2hs-rules-test-0.1.0.0... +Building library for setup-hooks-c2hs-rules-test-0.1.0.0... diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.test.hs new file mode 100644 index 00000000000..2df426a5dbf --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/SetupHooks.hs new file mode 100644 index 00000000000..65067ebff97 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/SetupHooks.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) cyclicPreBuildRules + } + } + +cyclicPreBuildRules :: PreBuildComponentInputs -> RulesM () +cyclicPreBuildRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = mdo + let clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + action = mkCommand (static Dict) (static (\ () -> error "This should not run")) () + r1 <- registerRule "r1" $ + staticRule action + [ RuleDependency $ RuleOutput r2 0 ] + ( ( autogenDir, "G1.hs" ) NE.:| [] ) + r2 <- registerRule "r2" $ + staticRule action + [ RuleDependency $ RuleOutput r1 0 ] + ( ( autogenDir, "G2.hs" ) NE.:| [] ) + r3 <- registerRule "r3" $ + staticRule action + [ RuleDependency $ RuleOutput r3 0 ] + ( ( autogenDir, "G3.hs" ) NE.:| [] ) + return () diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup-hooks-cyclic-rules-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup-hooks-cyclic-rules-test.cabal new file mode 100644 index 00000000000..c0d3e0b9481 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup-hooks-cyclic-rules-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-cyclic-rules-test +version: 0.1.0.0 +synopsis: Test for cyclic rules +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + exposed-modules: G1, G2 + autogen-modules: G1, G2 + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.out new file mode 100644 index 00000000000..5076d3b207b --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.out @@ -0,0 +1,11 @@ +# Setup configure +Configuring setup-hooks-cyclic-rules-test-0.1.0.0... +# Setup build +Error: [Cabal-9077] +Hooks: cycles in dependency structure of rules: + Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r3"})[0]] --> [setup.dist/work/dist/build/autogen/G3.hs] + + Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r2"})[0]] --> [setup.dist/work/dist/build/autogen/G1.hs] + | + `- Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r1"})[0]] --> [setup.dist/work/dist/build/autogen/G2.hs] + diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.test.hs new file mode 100644 index 00000000000..370c60bd0f1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + fails $ setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/SetupHooks.hs new file mode 100644 index 00000000000..b7ac707e627 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/SetupHooks.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.SetupHooks + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) dupRuleIdRules + } + } + +dupRuleIdRules :: PreBuildComponentInputs -> RulesM () +dupRuleIdRules _ = do + let cmd = mkCommand (static Dict) (static (\ _ -> error "This should not run")) () + registerRule_ "myRule" $ staticRule cmd [] ( ( "src", "A.hs" ) NE.:| [] ) + registerRule_ "myRule" $ staticRule cmd [] ( ( "src", "B.hs" ) NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup-hooks-duplicate-rule-id-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup-hooks-duplicate-rule-id-test.cabal new file mode 100644 index 00000000000..ff982ea9abf --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup-hooks-duplicate-rule-id-test.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.14 +name: setup-hooks-duplicate-rule-id-test +version: 0.1.0.0 +synopsis: Test duplicate rule ids +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.out new file mode 100644 index 00000000000..2a5f2e99d6f --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring setup-hooks-duplicate-rule-id-test-0.1.0.0... +# Setup build +Error: [Cabal-7717] +Duplicate pre-build rule (RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (17,59)}, ruleName = "myRule"}) + - Rule: [] --> [src/A.hs] + - Rule: [] --> [src/B.hs] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.test.hs new file mode 100644 index 00000000000..370c60bd0f1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + fails $ setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs new file mode 100644 index 00000000000..0949aff5b89 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks +import Distribution.Simple.Utils ( rewriteFileEx ) + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) +import System.FilePath + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) invalidRuleOutputIndexRules + } + } + +invalidRuleOutputIndexRules :: PreBuildComponentInputs -> RulesM () +invalidRuleOutputIndexRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = do + let clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + verbosity = buildingWhatVerbosity what + action = mkCommand (static Dict) $ static (\ ((dir, modNm), verb) -> do + let loc = dir modNm <.> "hs" + rewriteFileEx verb loc $ + "module " ++ modNm ++ " where {}" + ) + + r1 <- registerRule "r1" $ + staticRule + (action ((autogenDir, "A"), verbosity)) + [] ( ( autogenDir, "A.hs" ) NE.:| [] ) + registerRule_ "r2" $ + staticRule (action ((autogenDir, "B"), verbosity)) + [ RuleDependency $ RuleOutput r1 7 ] + ( ( autogenDir, "B.hs" ) NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup-hooks-invalid-rule-output-index-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup-hooks-invalid-rule-output-index-test.cabal new file mode 100644 index 00000000000..8bb8a6ed2c6 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup-hooks-invalid-rule-output-index-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-invalid-rule-output-index-test +version: 0.1.0.0 +synopsis: Test for an invalid rule output index +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + build-depends: base + default-language: Haskell2010 + autogen-modules: A, B + exposed-modules: A, B diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.out new file mode 100644 index 00000000000..82f5148e9b9 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.out @@ -0,0 +1,6 @@ +# Setup configure +Configuring setup-hooks-invalid-rule-output-index-test-0.1.0.0... +# Setup build +Error: [Cabal-1173] +Invalid index '7' in dependency of RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (20,59)}, ruleName = "r2"}. +The dependency RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (20,59)}, ruleName = "r1"} only has 1 output. diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.test.hs new file mode 100644 index 00000000000..370c60bd0f1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + fails $ setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/SetupHooks.hs new file mode 100644 index 00000000000..47ff3296163 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/SetupHooks.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) missingDepRules + } + } + +missingDepRules :: PreBuildComponentInputs -> RulesM () +missingDepRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = do + let clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + action = mkCommand (static Dict) (static (\ _ -> error "This should not run")) () + registerRule_ "r" $ + staticRule action + [ FileDependency ( ".", "Missing.hs" ) ] + ( ( autogenDir, "G.hs" ) NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup-hooks-missing-rule-dep-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup-hooks-missing-rule-dep-test.cabal new file mode 100644 index 00000000000..a0c841913b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup-hooks-missing-rule-dep-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-missing-rule-dep-test +version: 0.1.0.0 +synopsis: Test for missing dependency in rules +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + exposed-modules: G + autogen-modules: G + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.out new file mode 100644 index 00000000000..bfbd911994d --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.out @@ -0,0 +1,6 @@ +# Setup configure +Configuring setup-hooks-missing-rule-dep-test-0.1.0.0... +# Setup build +Error: [Cabal-1071] +Pre-build rules: can't find source for rule dependency: + - Missing.hs diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.test.hs new file mode 100644 index 00000000000..370c60bd0f1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + fails $ setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/SetupHooks.hs new file mode 100644 index 00000000000..6b5ce60dd81 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/SetupHooks.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) missingResRules + } + } + +missingResRules :: PreBuildComponentInputs -> RulesM () +missingResRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = do + let clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + action = mkCommand (static Dict) (static (\ _ -> return ())) () + registerRule_ "r" $ + staticRule action + [ ] + ( ( autogenDir, "G.hs" ) NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup-hooks-missing-rule-res-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup-hooks-missing-rule-res-test.cabal new file mode 100644 index 00000000000..b4783b483df --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup-hooks-missing-rule-res-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-missing-rule-res-test +version: 0.1.0.0 +synopsis: Test for missing result in rules +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + exposed-modules: G + autogen-modules: G + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.out new file mode 100644 index 00000000000..5659bca63e1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.out @@ -0,0 +1,6 @@ +# Setup configure +Configuring setup-hooks-missing-rule-res-test-0.1.0.0... +# Setup build +Error: [Cabal-3498] +Pre-build rule did not generate expected result: + - setup.dist/work/dist/build/autogen/G.hs diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.test.hs new file mode 100644 index 00000000000..370c60bd0f1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + fails $ setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/A.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/A.hs new file mode 100644 index 00000000000..2f20e91a6c1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/A.hs @@ -0,0 +1 @@ +module A where {} diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs new file mode 100644 index 00000000000..a301e71cff0 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks +import Distribution.Simple.Utils ( rewriteFileEx, warn ) + +import Data.Foldable ( for_ ) +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) +import Data.Traversable ( for ) + +import System.FilePath + ( (<.>), () ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) preBuildRules + } + } + +-- Register three rules: +-- +-- r1: B --> C +-- r2: A --> B +-- r3: C --> D +-- +-- and check that we run them in dependency order, i.e. r2, r1, r3. +preBuildRules :: PreBuildComponentInputs -> RulesM () +preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = mdo + let verbosity = buildingWhatVerbosity what + clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + + mkAction = + mkCommand (static Dict) $ static (\ (dir, verb, (inMod, outMod)) -> do + warn verb $ "Running rule: " ++ inMod ++ " --> " ++ outMod + let loc = dir outMod <.> "hs" + rewriteFileEx verb loc $ + "module " ++ outMod ++ " where { import " ++ inMod ++ " }" + ) + + actionArg inMod outMod = (autogenDir, verbosity, (inMod, outMod)) + + mkRule action input outMod = + staticRule action + [ input ] + ( ( autogenDir, outMod <.> "hs" ) NE.:| [] ) + + r1 <- registerRule "r1" $ mkRule (mkAction (actionArg "B" "C")) (RuleDependency $ RuleOutput r2 0) "C" -- B --> C + r2 <- registerRule "r2" $ mkRule (mkAction (actionArg "A" "B")) (FileDependency (".", "A.hs")) "B" -- A --> B + r3 <- registerRule "r3" $ mkRule (mkAction (actionArg "C" "D")) (RuleDependency $ RuleOutput r1 0) "D" -- C --> D + return () diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup-hooks-rule-ordering-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup-hooks-rule-ordering-test.cabal new file mode 100644 index 00000000000..f3885717b5d --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup-hooks-rule-ordering-test.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: setup-hooks-rule-ordering-test +version: 0.1.0.0 +synopsis: Test that we execute pre-build rules in the correct order +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal, Cabal-hooks, base, filepath + +library + exposed-modules: A, B, C, D + autogen-modules: B, C, D + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.out new file mode 100644 index 00000000000..ccc3b1e7489 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.out @@ -0,0 +1,8 @@ +# Setup configure +Configuring setup-hooks-rule-ordering-test-0.1.0.0... +# Setup build +Warning: Running rule: A --> B +Warning: Running rule: B --> C +Warning: Running rule: C --> D +Preprocessing library for setup-hooks-rule-ordering-test-0.1.0.0... +Building library for setup-hooks-rule-ordering-test-0.1.0.0... diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.test.hs new file mode 100644 index 00000000000..2df426a5dbf --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + setup "build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/SetupHooks.hs new file mode 100644 index 00000000000..e1d2141aa61 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/SetupHooks.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) +import Distribution.Simple.SetupHooks + +import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) unusedPreBuildRules + } + } + +unusedPreBuildRules :: PreBuildComponentInputs -> RulesM () +unusedPreBuildRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = do + let clbi = targetCLBI tgt + i = interpretSymbolicPathLBI lbi + autogenDir = i (autogenComponentModulesDir lbi clbi) + action = mkCommand (static Dict) (static (\ _ -> error "This should not run")) () + registerRule_ "r1" $ + staticRule action [] + ( ( autogenDir, "X.hs" ) NE.:| [ ( autogenDir, "Y.hs" ) ] ) + registerRule_ "r2" $ + staticRule action [] + ( ( autogenDir, "Z.what" ) NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup-hooks-unused-rules-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup-hooks-unused-rules-test.cabal new file mode 100644 index 00000000000..380a6273b45 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup-hooks-unused-rules-test.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.14 +name: setup-hooks-unused-rules-test +version: 0.1.0.0 +synopsis: Test for unused pre-build rules +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal-hooks, base + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out new file mode 100644 index 00000000000..b5b0f048ce6 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out @@ -0,0 +1,13 @@ +# Setup configure +Configuring setup-hooks-unused-rules-test-0.1.0.0... +# Setup build +Warning: The following rules are not demanded and will not be run: + - RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r1"}, generating [setup.dist/work/dist/build/autogen/X.hs, setup.dist/work/dist/build/autogen/Y.hs] + - RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r2"}, generating [setup.dist/work/dist/build/autogen/Z.what] +Possible reasons for this error: + - Some autogenerated modules were not declared + (in the package description or in the pre-configure hooks) + - The output location for an autogenerated module is incorrect, + (e.g. it is not in the appropriate 'autogenComponentModules' directory) +Preprocessing library for setup-hooks-unused-rules-test-0.1.0.0... +Building library for setup-hooks-unused-rules-test-0.1.0.0... diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.test.hs new file mode 100644 index 00000000000..2df426a5dbf --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupTest $ do + setup "configure" [] + setup "build" [] diff --git a/cabal-testsuite/cabal-testsuite.cabal b/cabal-testsuite/cabal-testsuite.cabal index 4fdd0e51e7c..56b62690268 100644 --- a/cabal-testsuite/cabal-testsuite.cabal +++ b/cabal-testsuite/cabal-testsuite.cabal @@ -126,9 +126,11 @@ executable test-runtime-deps build-depends: , Cabal , Cabal-syntax + , Cabal-hooks , base , bytestring , cabal-testsuite + , containers , directory , exceptions , filepath diff --git a/cabal-testsuite/src/Test/Cabal/Server.hs b/cabal-testsuite/src/Test/Cabal/Server.hs index d6906a6d416..76387a2bae1 100644 --- a/cabal-testsuite/src/Test/Cabal/Server.hs +++ b/cabal-testsuite/src/Test/Cabal/Server.hs @@ -42,6 +42,9 @@ import qualified GHC.IO.Exception as GHC import Distribution.Verbosity import System.Process.Internals + ( ProcessHandle__( OpenHandle ) + , withProcessHandle + ) #if mingw32_HOST_OS import qualified System.Win32.Process as Win32 #endif diff --git a/changelog.d/pr-9551 b/changelog.d/pr-9551 new file mode 100644 index 00000000000..5116234a653 --- /dev/null +++ b/changelog.d/pr-9551 @@ -0,0 +1,19 @@ +synopsis: Introduce SetupHooks +packages: Cabal +prs: #9551 +description: { + Introduction of a new build type: Hooks. + This build type, intended as replacement to the Custom build type, integrates + better with the rest of the ecosystem (`cabal-install`, Haskell Language Server). + + The motivation and full design of this new build-type are specified in the + Haskell Foundation Tech Proposal + [Replacing the Cabal Custom build-type](https://github.com/haskellfoundation/tech-proposals/pull/60). + + Package authors willing to use this feature should declare `build-type: Hooks` + in their `.cabal` file, declare a custom-setup stanza with a dependency on the + `Cabal-hooks` package, and define a module `SetupHooks` that exports a value + `setupHooks :: SetupHooks`, using the API exported by `Distribution.Simple.SetupHooks` + from the `Cabal-hooks` package. Refer to the Haddock documentation of + `Distribution.Simple.SetupHooks` for example usage. +} diff --git a/doc/buildinfo-fields-reference.rst b/doc/buildinfo-fields-reference.rst index dd8c505a85e..c1ccf418f81 100644 --- a/doc/buildinfo-fields-reference.rst +++ b/doc/buildinfo-fields-reference.rst @@ -535,7 +535,7 @@ build-type * Documentation of :pkg-field:`build-type` .. math:: - \left\{ \begin{gathered}\mathop{\mathord{``}\mathtt{Simple}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Configure}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Custom}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Make}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Default}\mathord{"}}\end{gathered} \right\} + \left\{ \begin{gathered}\mathop{\mathord{``}\mathtt{Simple}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Configure}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Custom}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Hooks}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Make}\mathord{"}}\\\mathop{\mathord{``}\mathtt{Default}\mathord{"}}\end{gathered} \right\} cabal-version * Optional field diff --git a/doc/cabal-package-description-file.rst b/doc/cabal-package-description-file.rst index 652746b216a..9ec167364e0 100644 --- a/doc/cabal-package-description-file.rst +++ b/doc/cabal-package-description-file.rst @@ -441,6 +441,14 @@ describe the package as a whole: import Distribution.Simple main = defaultMain + For build type ``Hooks``, the contents of ``Setup.hs`` must be: + + .. code-block:: haskell + + import Distribution.Simple + import SetupHooks (setupHooks) + main = defaultMainWithSetupHooks setupHooks + For build type ``Configure`` (see the section on `system-dependent parameters`_ below), the contents of ``Setup.hs`` must be: @@ -461,7 +469,8 @@ describe the package as a whole: For build type ``Custom``, the file ``Setup.hs`` can be customized, and will be used both by ``cabal`` and other tools. - For most packages, the build type ``Simple`` is sufficient. + For most packages, the build type ``Simple`` is sufficient. For more exotic + needs, the ``Hooks`` build type is recommended; see :ref:`setup-hooks`. .. pkg-field:: license: SPDX expression @@ -1869,7 +1878,8 @@ system-dependent values for these fields. | ``hspec-discover`` | ``hspec-discover:hspec-discover`` | since Cabal 2.0 | +--------------------------+-----------------------------------+-----------------+ - This built-in set can be programmatically extended via ``Custom`` setup scripts; this, however, is of limited use since the Cabal solver cannot access information injected by ``Custom`` setup scripts. + This built-in set can be programmatically extended via use of the + :ref:`Hooks build type` . .. pkg-field:: buildable: boolean @@ -2783,9 +2793,64 @@ The exact fields are as follows: root directory of the repository. +.. _setup-hooks: + +Hooks +----- +The ``Hooks`` build type allows customising the configuration and the building +of a package using a collection of **hooks** into the build system. + +Introduced in Cabal 3.14, this build type provides an alternative +to :ref:`Custom setups ` which integrates better with the rest of the +Haskell ecosystem. + +To use this build type in your package, you need to: + + * Declare a ``cabal-version`` of at least 3.14 in your ``.cabal`` file. + * Declare ``build-type: Hooks`` in your ``.cabal`` file. + * Include a ``custom-setup`` stanza in your ``.cabal`` file, which declares + the version of the Hooks API your package is using. + * Define a ``SetupHooks.hs`` module next to your ``.cabal`` file. It must + export a value ``setupHooks :: SetupHooks``. + +More specifically, your ``.cabal`` file should resemble the following: + + .. code-block:: cabal + + cabal-version: 3.14 + build-type: Hooks + + custom-setup: + setup-depends: + base >= 4.18 && < 5, + Cabal-hooks >= 0.1 && < 0.2 + +while a basic ``SetupHooks.hs`` file might look like the following: + + .. code-block:: haskell + + module SetupHooks where + import Distribution.Simple.SetupHooks ( SetupHooks, noSetupHooks ) + + setupHooks :: SetupHooks + setupHooks = + noSetupHooks + { configureHooks = myConfigureHooks + , buildHooks = myBuildHooks } + + -- ... + +Refer to the `Hackage documentation for the Distribution.Simple.SetupHooks module `__ +for an overview of the ``Hooks`` API. Further motivation and a technical overview +of the design is available in `Haskell Tech Proposal #60 `__ . + +.. _custom-setup: + Custom setup scripts -------------------- +Deprecated since Cabal 3.14: prefer using the :ref:`Hooks build type` instead. + Since Cabal 1.24, custom ``Setup.hs`` are required to accurately track their dependencies by declaring them in the ``.cabal`` file rather than rely on dependencies being implicitly in scope. Please refer to @@ -2801,11 +2866,12 @@ Declaring a ``custom-setup`` stanza also enables the generation of ``MIN_VERSION_package_(A,B,C)`` CPP macros for the Setup component. .. pkg-section:: custom-setup - :synopsis: Custom Setup.hs build information. + :synopsis: Build information for ``Custom`` and ``Hooks`` build types :since: 1.24 - The optional :pkg-section:`custom-setup` stanza contains information needed - for the compilation of custom ``Setup.hs`` scripts, + The :pkg-section:`custom-setup` stanza contains information needed + for the compilation of custom ``Setup.hs`` scripts as well as for + ``SetupHooks.hs`` hooks modules. :: diff --git a/project-cabal/pkgs/cabal.config b/project-cabal/pkgs/cabal.config index 2500cad5ecf..3c1d897705d 100644 --- a/project-cabal/pkgs/cabal.config +++ b/project-cabal/pkgs/cabal.config @@ -2,3 +2,4 @@ packages: Cabal , Cabal-described , Cabal-syntax + , Cabal-hooks diff --git a/validate.sh b/validate.sh index 9edc87eeaf3..be167d40d43 100755 --- a/validate.sh +++ b/validate.sh @@ -280,7 +280,7 @@ if [ -z "$STEPS" ]; then STEPS="$STEPS time-summary" fi -TARGETS="Cabal cabal-testsuite Cabal-tests Cabal-QuickCheck Cabal-tree-diff Cabal-described" +TARGETS="Cabal Cabal-hooks cabal-testsuite Cabal-tests Cabal-QuickCheck Cabal-tree-diff Cabal-described" if ! $LIBONLY; then TARGETS="$TARGETS cabal-install cabal-install-solver cabal-benchmarks"; fi if $BENCHMARKS; then TARGETS="$TARGETS solver-benchmarks"; fi