Pre-build rules can generate autogen extra sources

With this commit, the SetupHooks API now considers all extra source
files placed in the autogen directory for the component to be additional
demands on pre-build rules.

For example, a pre-build rule that generates a C or JavaScript source
file (putting it in the appropriate autogen module for the component)
will now be run, while it used to not be run before (as it used to be
considered "not demanded").

Author: sheaf

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