diff --git a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs index a625b17de0f..0851157a604 100644 --- a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs +++ b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs @@ -88,7 +88,7 @@ module Distribution.Simple.SetupHooks -- *** Rule inputs/outputs -- **** Rule dependencies - -- $rulesDemand + -- $rulesDeps , Dependency (..) , RuleOutput (..) , RuleId @@ -497,10 +497,9 @@ the result of the dynamic dependency command; these have the required instances needed for serialisation. If you use custom datatypes for these, you will need to derive @Binary@, @Show@, @Eq@ to satisfy the API requirements (enforced by the various calls to @static Dict@). - -} -{- $rulesDemand +{- $rulesDeps Rules can declare various kinds of dependencies: - static dependencies: files or other rules that a rule statically depends on, @@ -538,6 +537,30 @@ to behave as follows: 1. Any time the rules are out-of-date, query the rules to obtain up-to-date rules. 2. Re-run stale rules. + +Cabal will execute all **demanded** rules in dependency order. A rule is +demanded if it satisfies one of the following conditions: + + 1. It is a dependency of another demanded rule. + 2. The rule generates a Haskell file declared in the autogen-modules field. + In this case, the rule **must** place the generated source file in the + 'autogenComponentModulesDir' appropriate for the component. + 3. (Since Cabal 3.18 only) The rule generates a non-Haskell source file, such + as a C or JavaScript source. In this case (because there is no + "autogen-c-sources" field), the following steps must be taken: + a. Add the file to the 'c-sources' (or 'js-sources', etc) field of the + package description in a per-component pre-configure hook, declaring it + in the same 'autogenComponentModulesDir' directory (as if it was a @.hs@ file). + b. Add a pre-build rule that generates the source file and puts it in + this same 'autogenComponentModulesDir' directory. + Note that any file declared in the 'includes'/'autogen-includes' fields + must be present at **configure** time, so cannot be generated in a + pre-build rule. In that case, either use a pre-configure hook or don't + declare it under the 'includes' field (if possible). + 4. (Since Cabal 3.18 only) The rule generates an extra bundled library file, + placed in the 'autogenComponentModulesDir' and with a filename matching + one of the libraries named in the 'extra-bundled-libraries' field (ignoring + file extension). -} {- $rulesAPI diff --git a/Cabal-syntax/src/Distribution/Utils/Path.hs b/Cabal-syntax/src/Distribution/Utils/Path.hs index a4d09334e01..786fcda43ea 100644 --- a/Cabal-syntax/src/Distribution/Utils/Path.hs +++ b/Cabal-syntax/src/Distribution/Utils/Path.hs @@ -59,6 +59,7 @@ module Distribution.Utils.Path , dropExtensionsSymbolicPath , replaceExtensionSymbolicPath , normaliseSymbolicPath + , relativePathMaybe -- ** Working directory handling , interpretSymbolicPathCWD @@ -90,6 +91,9 @@ import qualified System.FilePath as FilePath import Data.Kind ( Type ) +import Data.List + ( stripPrefix + ) import GHC.Stack ( HasCallStack ) @@ -338,6 +342,22 @@ interpretSymbolicPathAbsolute (AbsolutePath p) sym = interpretSymbolicPath (Just coerceSymbolicPath :: SymbolicPathX allowAbsolute from to1 -> SymbolicPathX allowAbsolute from to2 coerceSymbolicPath = coerce +-- | Does the second argument point to a sub-directory of the first one? +-- If so, return the relative portion of the path, relative to the first argument. +relativePathMaybe :: SymbolicPath from (Dir dir) -> SymbolicPath from to -> Maybe (RelativePath dir to) +relativePathMaybe base fp = + let dirPieces = + FilePath.splitDirectories $ + FilePath.dropTrailingPathSeparator $ + FilePath.normalise $ + getSymbolicPath base + pathPieces = + FilePath.splitDirectories $ + FilePath.normalise $ + getSymbolicPath fp + in unsafeMakeSymbolicPath . FilePath.joinPath + <$> stripPrefix dirPieces pathPieces + -- | Change both what a symbolic path is pointing from and pointing to. -- -- Avoid using this in new code. diff --git a/Cabal-tests/Cabal-tests.cabal b/Cabal-tests/Cabal-tests.cabal index 50ee8893b3f..40435ba6d47 100644 --- a/Cabal-tests/Cabal-tests.cabal +++ b/Cabal-tests/Cabal-tests.cabal @@ -48,6 +48,7 @@ test-suite unit-tests UnitTests.Distribution.Utils.Generic UnitTests.Distribution.Utils.Json UnitTests.Distribution.Utils.NubList + UnitTests.Distribution.Utils.Path UnitTests.Distribution.Utils.ShortText UnitTests.Distribution.Utils.Structured UnitTests.Distribution.Version diff --git a/Cabal-tests/tests/UnitTests.hs b/Cabal-tests/tests/UnitTests.hs index 7a4518bcd5c..16b80813478 100644 --- a/Cabal-tests/tests/UnitTests.hs +++ b/Cabal-tests/tests/UnitTests.hs @@ -20,6 +20,7 @@ import qualified UnitTests.Distribution.Utils.CharSet import qualified UnitTests.Distribution.Utils.Generic import qualified UnitTests.Distribution.Utils.Json import qualified UnitTests.Distribution.Utils.NubList +import qualified UnitTests.Distribution.Utils.Path import qualified UnitTests.Distribution.Utils.ShortText import qualified UnitTests.Distribution.Utils.Structured import qualified UnitTests.Distribution.Version (versionTests) @@ -52,6 +53,8 @@ tests = , testGroup "Distribution.Utils.Json" UnitTests.Distribution.Utils.Json.tests , testGroup "Distribution.Utils.NubList" UnitTests.Distribution.Utils.NubList.tests + , testGroup "Distribution.Utils.Path" + UnitTests.Distribution.Utils.Path.tests , testGroup "Distribution.PackageDescription.Check" UnitTests.Distribution.PackageDescription.Check.tests , testGroup "Distribution.Utils.ShortText" diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Path.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Path.hs new file mode 100644 index 00000000000..30b358d6965 --- /dev/null +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Path.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} + +module UnitTests.Distribution.Utils.Path + ( tests + ) where + +import Distribution.Utils.Path + ( () + , makeRelativePathEx, makeSymbolicPath, relativePathMaybe + ) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: [TestTree] +tests = + [ testCase "relativePathMaybe: direct child" $ + relativePathMaybe + (makeSymbolicPath $ "a" "b") + (makeSymbolicPath $ "a" "b" "c") + @?= Just (makeRelativePathEx "c") + , testCase "relativePathMaybe: deeper nesting" $ + relativePathMaybe + (makeSymbolicPath "a") + (makeSymbolicPath $ "a" "b" "c") + @?= Just (makeRelativePathEx $ "b" "c") + , testCase "relativePathMaybe: unrelated path" $ + relativePathMaybe + (makeSymbolicPath $ "a" "b") + (makeSymbolicPath $ "x" "y") + @?= Nothing + , testCase "relativePathMaybe: partial prefix is not a match" $ + relativePathMaybe + (makeSymbolicPath $ "a" "bc") + (makeSymbolicPath $ "a" "bcd" "e") + @?= Nothing + ] diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs index d7fdf2311f3..f69fd72b03b 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs @@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | @@ -93,7 +94,9 @@ import Distribution.Compat.Prelude import Prelude () import Distribution.Compat.Lens ((.~)) +import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription +import Distribution.Pretty (prettyShow) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler (Compiler (..)) import Distribution.Simple.Errors @@ -136,6 +139,7 @@ import Data.Monoid (Ap (..)) import qualified Data.Set as Set import System.Directory (doesFileExist, getModificationTime) +import qualified System.FilePath as FilePath -------------------------------------------------------------------------------- -- SetupHooks @@ -913,20 +917,87 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a , map (fmap ruleFromVertex) (v : vs) ) - -- Compute demanded rules. + -- Compute demanded rules: anything reachable from the roots, which are: -- - -- SetupHooks TODO: maybe requiring all generated modules to appear - -- in autogen-modules is excessive; we can look through all modules instead. + -- - autogen modules + -- - extra-c-sources, extra-asm-sources, ... that happen to be in the + -- autogen directory (this is the workaround for there being no + -- 'autogen' field for those) + -- - extra-bundled-libs + -- + -- This does not include autogen-includes, because .h files are required + -- during configure time, so not relevant for pre-build rules which are run + -- after configure. + autogenModPaths :: [RelativePath Source File] autogenModPaths = map (\m -> moduleNameSymbolicPath m <.> "hs") $ - autogenModules $ - componentBuildInfo $ - targetComponent tgtInfo - leafRule_maybe (rId, r) = - if any ((r `ruleOutputsLocation`) . (Location compAutogenDir)) autogenModPaths - then vertexFromRuleId rId - else Nothing - leafRules = mapMaybe leafRule_maybe $ Map.toList allRules + autogenModules compBuildInfo + autogenExtraSourcesPaths :: [RelativePath Source File] + autogenExtraSourcesPaths = + concatMap + (mapMaybe relativeToAutogen) + [ cSources compBuildInfo + , cxxSources compBuildInfo + , cmmSources compBuildInfo + , asmSources compBuildInfo + , jsSources compBuildInfo + ] + extraBundledLibsPaths :: [RelativePath Source File] + extraBundledLibsPaths = + map makeRelativePathEx $ + extraBundledLibs compBuildInfo + + -- Is this rule directly demanded (e.g. it generates a Haskell module + -- declared in the autogen-modules field)? If so, return the appropriate + -- demand graph vertex (conceptually a leaf vertex). + isLeafRule + :: (RuleId, RuleData scope) + -> Either (NotDemandedRuleReasons scope) Graph.Vertex + isLeafRule (rId, r@Rule{results = ruleOutputLocs}) + | let + normOuts = fmap normaliseLocation ruleOutputLocs + anyOut f = + any + ( \demandedPath -> + let normDemanded = normaliseLocation $ Location compAutogenDir demandedPath + in any (f normDemanded) normOuts + ) + , -- Autogen modules + anyOut (==) autogenModPaths + -- Extra source files + || anyOut (==) autogenExtraSourcesPaths + -- Extra bundled libraries + -- They may have any extension (.dll, .so.1.2.3, etc) + -- so simply allow all extensions. + || anyOut (\dmdLoc outLoc -> dmdLoc == dropExtensionLocation outLoc) extraBundledLibsPaths = + case vertexFromRuleId rId of + Just v -> Right v + Nothing -> + error $ + unlines + [ "internal error: no graph vertex for rule " ++ show rId + , "Rule: " ++ show rId + ] + | otherwise = + Left $ + NDRR + { nonDemandedRules = Map.singleton rId r + , nonAutogenHaskellModules = + Map.singleton + rId + [ fromString $ intercalate "." $ FilePath.splitDirectories hsPath + | Location _ outPath <- NE.toList (results r) + , (hsPath, ".hs") <- [FilePath.splitExtension (getSymbolicPath outPath)] + ] + , filesNotInAutogenFolders = + Map.singleton + rId + [ unsafeCoerceSymbolicPath fp + | Location base fp <- NE.toList (results r) + , Nothing <- [relativeToAutogen base] + ] + } + (nonDmdReasons, leafRules) = partitionEithers $ map isLeafRule $ Map.toList allRules demandedRuleVerts = Set.fromList $ concatMap (Graph.reachable ruleGraph) leafRules nonDemandedRuleVerts = Set.fromList (Graph.vertices ruleGraph) Set.\\ demandedRuleVerts @@ -945,22 +1016,7 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a -- 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:" - : concat - [ [ " - " ++ show rId ++ "," - , " generating " ++ show (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. the file extension is incorrect, or" - , " it is not in the appropriate 'autogenComponentModules' directory)" - ] + pprNotDemandedRuleReasons comp compAutogenDir (mconcat nonDmdReasons) -- Run all the demanded rules, in dependency order, propagating staleness. staleRulesRef <- newIORef Set.empty @@ -1002,13 +1058,83 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a SSystem -> id clbi = targetCLBI tgtInfo mbWorkDir = mbWorkDirLBI lbi + comp = targetComponent tgtInfo compAutogenDir = autogenComponentModulesDir lbi clbi rulesCacheFile = interpretSymbolicPath mbWorkDir (preBuildRulesCacheFile lbi clbi) + compBuildInfo = componentBuildInfo comp errorOut e = dieWithException verbosity $ SetupHooksException $ RulesException e + relativeToAutogen :: SymbolicPath Pkg to -> Maybe (RelativePath Source to) + relativeToAutogen = relativePathMaybe compAutogenDir + +-- | Collects why certain rules were not demanded (and thus not run), in order +-- to construct an error message to report to the user. +data NotDemandedRuleReasons scope = NDRR + { nonDemandedRules :: Map RuleId (RuleData scope) + -- ^ The rules that were not demanded + , nonAutogenHaskellModules :: Map RuleId [ModuleName] + -- ^ Rules that generate Haskell files that are not declared as + -- autogenerated modules. + , filesNotInAutogenFolders :: Map RuleId [RelativePath Pkg File] + -- ^ Rules that generate files that aren't in the appropriate autogen + -- directory. + } + +instance Semigroup (NotDemandedRuleReasons scope) where + NDRR r1 m1 f1 <> NDRR r2 m2 f2 = NDRR (r1 <> r2) (m1 <> m2) (f1 <> f2) +instance Monoid (NotDemandedRuleReasons scope) where + mempty = NDRR mempty mempty mempty + +pprNotDemandedRuleReasons + :: Component + -> SymbolicPath Pkg (Dir Source) + -> NotDemandedRuleReasons scope + -> String +pprNotDemandedRuleReasons + comp + compAutogenDir + (NDRR non_dmd_verts mods_map miss_files_map) = + unlines $ header ++ mods_lines ++ files_lines + where + mods = tagByRuleId mods_map + miss_files = tagByRuleId miss_files_map + + tagByRuleId xs = concatMap (\(rId, x) -> map (rId,) x) $ Map.toList xs + ppr (rId, x) = " - " ++ prettyShow x ++ " (for rule " ++ show (ruleName rId) ++ ")" + + header :: [String] + header = + "The following rules are not demanded and will not be run:" + : concat + [ [ " - " ++ show rId ++ "," + , " generating " ++ show (NE.toList $ results r) + ] + | (rId, r) <- Map.toList non_dmd_verts + ] + + mods_lines, files_lines :: [String] + mods_lines + | null mods = + [] + | otherwise = + ("Perhaps add the following to the 'autogen-modules' field of the " ++ showComponentName (componentName comp) ++ " component.") + : map ppr mods + files_lines + | null miss_files = + [] + | otherwise = + ("The following autogenerated file" ++ s ++ " for the " ++ showComponentName (componentName comp) ++ " component " ++ isOrAre ++ " misplaced.") + : (itOrThey ++ " should go in " ++ show compAutogenDir ++ "'.") + : map ppr miss_files + where + (s, isOrAre, itOrThey) = + case miss_files of + [_] -> ("", "is", "It") + _ -> ("s", "are", "They") + directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep directRuleDependencyMaybe (FileDependency{}) = Nothing @@ -1091,15 +1217,14 @@ resolveDependency verbosity rId allRules = \case 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 (Location base rel) = Location (normaliseSymbolicPath base) (normaliseSymbolicPath rel) +dropExtensionLocation :: Location -> Location +dropExtensionLocation (Location base rel) = + Location base (makeRelativePathEx $ FilePath.dropExtensions $ getSymbolicPath rel) + -- | Is the file we depend on missing? missingDep :: Maybe (SymbolicPath CWD (Dir Pkg)) -> Location -> IO Bool missingDep mbWorkDir loc = not <$> doesFileExist fp diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/A.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/A.hs new file mode 100644 index 00000000000..8945f63c1f3 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/A.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ForeignFunctionInterface, CApiFFI #-} + +module A ( bobble, isNeeded ) where + +import Foreign.C.Types ( CInt(..) ) + +-- B is autogenerated +import B ( foo, isNeeded ) + +bar x = 2 + foo x * 3 + +foreign export ccall bar :: CInt -> CInt + +wobble x = gen_quux x + +foreign import capi "Gen.h gen_quux" gen_quux :: CInt -> CInt +foreign import capi "Gen.h gen_nozzle" gen_nozzle :: CInt -> CInt + +foreign import capi "Top.h wyzzy" wyzzy :: CInt -> CInt + +bobble = wyzzy 0 + +foreign export ccall wobble :: CInt -> CInt diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Bot.c b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Bot.c new file mode 100644 index 00000000000..a064199f267 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Bot.c @@ -0,0 +1,5 @@ + + +int xyzzy(int x) { + return (x - 99); +} diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Bot.h b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Bot.h new file mode 100644 index 00000000000..60b50c08a3d --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Bot.h @@ -0,0 +1,2 @@ + +int xyzzy(int); diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Main.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Main.hs new file mode 100644 index 00000000000..7c1cca760bd --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Main.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main where + +import Foreign.C.Types (CInt(..)) + +import A (bobble, isNeeded) + +foreign import ccall razzle :: CInt -> CInt + +main = do + print bobble + print $ razzle 3 + print $ isNeeded 77 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Setup.hs new file mode 100644 index 00000000000..4ad8e7121af --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/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/SetupHooksNonHs/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/SetupHooks.hs new file mode 100644 index 00000000000..d95e0568331 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/SetupHooks.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# 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 Distribution.Types.LocalBuildInfo + ( buildDirPBD ) +import Distribution.Types.UnqualComponentName + ( unUnqualComponentName ) +import Distribution.Utils.Path +import Distribution.Verbosity + +import Control.Monad ( void ) +import Data.Foldable ( for_ ) +import Data.List ( isPrefixOf ) +import qualified Data.List.NonEmpty as NE +import Data.String +import Data.Traversable ( for ) +import GHC.Generics + +import qualified Data.Map as Map + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { configureHooks = + noConfigureHooks + { preConfComponentHook = Just pcc } + , buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) preBuildRules + } + } + +pcc :: PreConfComponentHook +pcc (PreConfComponentInputs _lbc pbd _comp) = + return $ + PreConfComponentOutputs $ ComponentDiff $ CExe $ + emptyExecutable + { buildInfo = + -- Need to add the .c files, so that they get included in the final + -- linking invocation. + -- + -- For the .h file: + -- + -- - We don't need it at configure time, so we generate it in a pre-build rule. + -- We can't add it to 'includes'/'autogenIncludes', as Cabal would go looking for it + -- at configure time (before we run pre-build rules). + -- - If we needed it at configure time, we would need to generate it + -- in this per-component pre-configure hook and then add it to 'includes'/'autogenIncludes'. + -- That would work, but would mean we wouldn't benefit from + -- recompilation checking. + emptyBuildInfo + { cSources = [ autogenDir unsafeMakeSymbolicPath "Gen.c" + , autogenDir unsafeMakeSymbolicPath "Gen2.c"] + } + } + where + autogenDir = buildDirPBD pbd (unsafeMakeSymbolicPath "NonHs/autogen") + +preBuildRules :: PreBuildComponentInputs -> RulesM () +preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = mdo + let verbosityFlags = buildingWhatVerbosity what + clbi = targetCLBI tgt + autogenDir = autogenComponentModulesDir lbi clbi + buildDir = componentBuildDir lbi clbi + + runPpAction1 (PpInput {..}) = do + let verbosity = mkVerbosity defaultVerbosityHandles verbosityFlags + warn verbosity "Running MyPp1" + rewriteFileEx verbosity (getSymbolicPath genDir "Gen.h") $ unlines + [ "#include \"Bot.h\"" + , "int gen_quux(int);" + , "int gen_nozzle(int);" + , "int norbert(int);" + ] + rewriteFileEx verbosity (getSymbolicPath genDir "Gen.c") $ unlines + [ "#include \"A_stub.h\"" + , "#include \"B_stub.h\"" + , "int gen_quux(int x) { return (foo(x) + bar(x)); };" + , "int gen_nozzle(int x) { return (x + wobble(x)); };" + , "int norbert(int x) { return (x+x); };" + ] + + runPpAction2 (PpInput {..}) = do + let verbosity = mkVerbosity defaultVerbosityHandles verbosityFlags + warn verbosity "Running MyPp2" + rewriteFileEx verbosity (getSymbolicPath genDir "B.hs") $ unlines + [ "{-# LANGUAGE ForeignFunctionInterface, CApiFFI #-}" + , "module B where" + , "import Foreign.C.Types (CInt(..))" + , "foo :: CInt -> CInt" + , "foo x = 2 * x + 1" + , "" + , "foreign export ccall foo :: CInt -> CInt" + , "foreign import capi \"Gen.h norbert\" norbert :: CInt -> CInt" + , "" + , "foreign import ccall \"is_needed\" isNeeded :: Int -> Int" + ] + + -- Check that this rule is demanded via the cSources demand. + -- No other rule demands it. + runPpAction3 (PpInput {..}) = do + let verbosity = mkVerbosity defaultVerbosityHandles verbosityFlags + warn verbosity "Running MyPp3" + rewriteFileEx verbosity (getSymbolicPath genDir "Gen2.c") $ unlines + [ "int is_needed(int x) { return (x+ 999000); };" + ] + + -- Check that this rule is demanded via the extra-bundled-libraries demand. + -- No other rule demands it. + runPpAction4 (PpInput {..}) = do + let verbosity = mkVerbosity defaultVerbosityHandles verbosityFlags + warn verbosity "Running MyPp4" + rewriteFileEx verbosity (getSymbolicPath genDir "GenLib.a") "" + + mkRule1 = + staticRule + (mkCommand (static Dict) (static runPpAction1) $ PpInput {genDir = autogenDir, ..}) + [ ] + ( Location autogenDir (unsafeMakeSymbolicPath "Gen.h") NE.:| + [ Location autogenDir (unsafeMakeSymbolicPath "Gen.c") + ] ) + + mkRule2 dep = + staticRule + (mkCommand (static Dict) (static runPpAction2) $ PpInput {genDir = autogenDir, ..}) + [ RuleDependency (RuleOutput dep 0) ] + ( Location autogenDir (unsafeMakeSymbolicPath "B.hs") NE.:| [] ) + + mkRule3 = + staticRule + (mkCommand (static Dict) (static runPpAction3) $ PpInput {genDir = autogenDir, ..}) + [ ] + ( Location autogenDir (unsafeMakeSymbolicPath "Gen2.c") NE.:| [] ) + + mkRule4 = + staticRule + (mkCommand (static Dict) (static runPpAction4) $ PpInput {genDir = autogenDir, ..}) + [ ] + ( Location autogenDir (unsafeMakeSymbolicPath "GenLib.a") NE.:| [] ) + + r1 <- registerRule "MyPP1" mkRule1 + void $ registerRule "MyPP2" (mkRule2 r1) + void $ registerRule "MyPP3" mkRule3 + void $ registerRule "MyPP4" mkRule4 + +-- | Input to preprocessor command +data PpInput + = PpInput + { verbosityFlags :: VerbosityFlags + , genDir :: SymbolicPath Pkg (Dir Source) + } + 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/SetupHooksNonHs/Top.c b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Top.c new file mode 100644 index 00000000000..4b57bfe9e0a --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Top.c @@ -0,0 +1,9 @@ + +#include "Gen.h" +#include "A_stub.h" + +int wyzzy(int x) { return (gen_nozzle(x) + 1); }; + +int razzle(int x) { + return (bar(x) - wobble(x)); +} diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Top.h b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Top.h new file mode 100644 index 00000000000..0537d61aa97 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Top.h @@ -0,0 +1,6 @@ + +#include "Gen.h" + +int wyzzy(int); + +int razzle(int); diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/cabal.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/cabal.out new file mode 100644 index 00000000000..2d4b25dc90c --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/cabal.out @@ -0,0 +1,12 @@ +# cabal run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - setup-hooks-non-hs-rules-test-0.1.0.0 (exe:NonHs) (first run) +Configuring setup-hooks-non-hs-rules-test-0.1.0.0... +Warning: Running MyPp4 +Warning: Running MyPp3 +Warning: Running MyPp1 +Warning: Running MyPp2 +Preprocessing executable 'NonHs' for setup-hooks-non-hs-rules-test-0.1.0.0... +Building executable 'NonHs' for setup-hooks-non-hs-rules-test-0.1.0.0... diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/cabal.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/cabal.test.hs new file mode 100644 index 00000000000..927d123f0ff --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/cabal.test.hs @@ -0,0 +1,2 @@ +import Test.Cabal.Prelude +main = cabalTest $ cabal "run" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/setup-hooks-non-hs-rules-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/setup-hooks-non-hs-rules-test.cabal new file mode 100644 index 00000000000..1b4ece05550 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/setup-hooks-non-hs-rules-test.cabal @@ -0,0 +1,38 @@ +cabal-version: 3.14 +name: setup-hooks-non-hs-rules-test +version: 0.1.0.0 +synopsis: Test implementing rules for non-hs files (.c, .h etc) +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: Cabal, Cabal-hooks, base, filepath, containers + +executable NonHs + hs-source-dirs: . + main-is: Main.hs + + other-modules: A, B + autogen-modules: B + + include-dirs: . + includes: Bot.h + + c-sources: Bot.c, Top.c + + -- GenLib.a gets generated by a pre-build rule, demanded via extra-bundled-libs. + extra-bundled-libraries: GenLib + + -- Gen.c gets declared by a pre-conf hook, and generated by a pre-build rule. + -- + -- Gen.h gets generated by a pre-build rule, but we can't declare it in + -- the 'includes' or 'autogen-includes' fields, as those are expected to be + -- present at configure time. + -- Instead, we simply rely on it being present because the autogen module is + -- added to include paths. + + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out index 47872b4f83d..13fcc09bdbf 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out @@ -6,11 +6,9 @@ Warning: The following rules are not demanded and will not be run: 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 = (19,59)}, ruleName = "r2"}, generating [setup.dist/work/dist/build/autogen Z.hs] -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. the file extension is incorrect, or - it is not in the appropriate 'autogenComponentModules' directory) +Perhaps add the following to the 'autogen-modules' field of the library component. + - X (for rule "r1") + - Y (for rule "r1") + - Z (for rule "r2") 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/changelog.d/pr-11573.md b/changelog.d/pr-11573.md new file mode 100644 index 00000000000..d9db0763236 --- /dev/null +++ b/changelog.d/pr-11573.md @@ -0,0 +1,29 @@ +--- +synopsis: Pre-build rules can generate extra sources and bundled libraries +packages: [Cabal, Cabal-hooks] +prs: 11573 +issues: [10791, 11607] +--- + +It is now possible to write pre-build rules that generate source files other +than Haskell files, as well as extra bundled library files. + +Because there is no counterpart to `autogen-modules` for non-Haskell source +files, you will need to proceed in two steps: + + 1. In a per-component pre-configure hook, add the files you want to generate + to the relevant fields, e.g. the `cSources` field of `BuildInfo` for a + C source file. + + These files must be relative to `autogenCompModulesDir`. + + 2. Pre-build rules generating these files will now be demanded. This avoids + getting an error message "The following pre-build rules are not demanded + and will not be run". + +Note that include files (such as `.h` files) are a bit different: any files +listed under `includes`/`autogen-includes` are required at **configure** time. +This gives `SetupHooks` authors two choices: either list the include files in +`autogen-includes` but generate them in a pre-configure hook, or don't list them +there and generate them in a pre-build rule, relying on the files getting picked +up from included directories (this may be brittle). diff --git a/doc/cabal-package-description-file.rst b/doc/cabal-package-description-file.rst index 184c2abae56..2af204e68d7 100644 --- a/doc/cabal-package-description-file.rst +++ b/doc/cabal-package-description-file.rst @@ -1957,11 +1957,11 @@ system-dependent values for these fields. A list of libraries that are supposed to be copied from the build directory alongside the produced Haskell libraries. Note that you are under the obligation to produce those libraries in the build - directory (e.g. via a custom setup). Libraries listed here will - be included when ``copy``-ing packages and be listed in the - ``hs-libraries`` of the package configuration in the package database. - Library names must either be prefixed with "HS" or "C" and corresponding - library file names must match: + directory (e.g. via a custom setup or pre-build rules). + Libraries listed here will be included when ``copy``-ing packages and be + listed in the ``hs-libraries`` of the package configuration in the package + database. Library names must either be prefixed with "HS" or "C" and + corresponding library file names must match: - Libraries with name "HS": - `libHS.a`