Allow pre-build rules to generate autogen extra sources files

Cabal-hooks/src/Distribution/Simple/SetupHooks.hs

@@ -73,7 +73,7 @@ module Distribution.Simple.SetupHooks
   , staticRule, dynamicRule
     -- *** Rule inputs/outputs
 
-    -- $rulesDemand
+    -- $rulesDeps
   , Location(..)
   , location
   , autogenComponentModulesDir
@@ -317,7 +317,7 @@ Each t'Rule' consists of:
 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.
+which are subject to change in between versions of the "Cabal-hooks" library.
 
 Note that:
 
@@ -335,7 +335,7 @@ Note that:
     when to re-compute the entire set of rules.
 -}
 
-{- $rulesDemand
+{- $rulesDeps
 Rules can declare various kinds of dependencies:
 
   - 'staticDependencies': files or other rules that a rule statically depends on,
@@ -373,6 +373,26 @@ 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).
 -}
 
 {- $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/src/Distribution/Simple/SetupHooks/Internal.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
 -- |
@@ -88,6 +89,7 @@ import Distribution.Compat.Prelude
 import Prelude ()
 
 import Distribution.Compat.Lens ((.~))
+import Distribution.ModuleName (ModuleName)
 import Distribution.PackageDescription
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.Compiler (Compiler (..))
@@ -123,6 +125,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 
 import System.Directory (doesFileExist)
+import qualified System.FilePath as FilePath
 
 --------------------------------------------------------------------------------
 -- SetupHooks
@@ -890,20 +893,64 @@ 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, ...
+    --    (there is no 'autogen' field for those, at least not yet)
+    --
+    -- 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
+        ]
+    leafRule_maybe
+      :: (RuleId, RuleData scope)
+      -> Either (NotDemandedRuleReasons scope) Graph.Vertex
+    leafRule_maybe (rId, r)
+      | any (any $ (r `ruleOutputsLocation`) . Location compAutogenDir) $
+          [ autogenModPaths
+          , autogenExtraSourcesPaths
+          ] =
+          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 leafRule_maybe $ Map.toList allRules
     demandedRuleVerts = Set.fromList $ concatMap (Graph.reachable ruleGraph) leafRules
     nonDemandedRuleVerts = Set.fromList (Graph.vertices ruleGraph) Set.\\ demandedRuleVerts
 
@@ -922,22 +969,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.
       for_ sccs $ \(Graph.Node ruleVertex _) ->
@@ -977,12 +1009,74 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
       SSystem -> id
     clbi = targetCLBI tgtInfo
     mbWorkDir = mbWorkDirLBI lbi
+    comp = targetComponent tgtInfo
     compAutogenDir = autogenComponentModulesDir lbi clbi
+    compBuildInfo = componentBuildInfo comp
     errorOut e =
       dieWithException verbosity $
         SetupHooksException $
           RulesException e
 
+    relativeToAutogen :: SymbolicPath Pkg to -> Maybe (RelativePath Source to)
+    relativeToAutogen = relativePathMaybe compAutogenDir
+
+data NotDemandedRuleReasons scope = NDRR
+  { nonDemandedRules :: Map RuleId (RuleData scope)
+  , nonAutogenHaskellModules :: Map RuleId [ModuleName]
+  , filesNotInAutogenFolders :: Map RuleId [RelativePath Pkg File]
+  }
+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 = aux mods_map
+      miss_files = aux miss_files_map
+
+      aux xs = concatMap (\(rId, x) -> map (rId,) x) $ Map.toList xs
+      ppr (rId, x) = "  - " ++ show x ++ "   (for rule " ++ show 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 '" ++ show comp ++ "'.")
+              : map ppr mods
+      files_lines
+        | null miss_files =
+            []
+        | otherwise =
+            ("The following autogenerated file" ++ s ++ " for " ++ show comp ++ " " ++ 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

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

cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Bot.c

@@ -0,0 +1,5 @@
+
+
+int xyzzy(int x) {
+  return (x - 99);
+}

cabal-testsuite/PackageTests/SetupHooks/SetupHooksNonHs/Bot.h

@@ -0,0 +1,2 @@
+
+int xyzzy(int);

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

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