Allow pre-build rules to generate autogen extra sources files

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

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.

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

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"

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
+  ]