hadrian: Refactor templating logic

This refactors Hadrian's autoconf-style templating logic to be explicit
about which interpolation variables should be substituted in which
files. This clears the way to fix #22714 without incurring rule cycles.

1 files changed, 90 insertions, 61 deletions

diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs
index b156c9dfdf..f17ff0eb21 100644
--- a/hadrian/src/Rules/Generate.hs
+++ b/hadrian/src/Rules/Generate.hs
@@ -235,71 +235,100 @@ emptyTarget :: Context
 emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
                              (error "Rules.Generate.emptyTarget: unknown package")
 
--- | Files generated by query-replace from a template
-templateResults :: [FilePath]
-templateResults =
-    [ "compiler/ghc.cabal"
-    , "rts/rts.cabal"
-    , "driver/ghci/ghci-wrapper.cabal"
-    , "ghc/ghc-bin.cabal"
-    , "utils/iserv/iserv.cabal"
-    , "utils/iserv-proxy/iserv-proxy.cabal"
-    , "utils/remote-iserv/remote-iserv.cabal"
-    , "utils/runghc/runghc.cabal"
-    , "libraries/ghc-boot/ghc-boot.cabal"
-    , "libraries/ghc-boot-th/ghc-boot-th.cabal"
-    , "libraries/ghci/ghci.cabal"
-    , "libraries/ghc-heap/ghc-heap.cabal"
-    , "utils/ghc-pkg/ghc-pkg.cabal"
-    , "libraries/libiserv/libiserv.cabal"
-    , "libraries/template-haskell/template-haskell.cabal"
-    , "libraries/prologue.txt"
+-- | A set of interpolation variable substitutions.
+newtype Interpolations = Interpolations (Action [(String, String)])
+
+instance Semigroup Interpolations where
+    Interpolations m <> Interpolations n = Interpolations ((++) <$> m <*> n)
+
+instance Monoid Interpolations where
+    mempty = Interpolations $ return []
+
+-- | @interpolateVar var value@ is an interpolation which replaces @\@var\@@
+-- with the result of @value@.
+interpolateVar :: String -> Action String -> Interpolations
+interpolateVar var value = Interpolations $ do
+    val <- value
+    return [(var, val)]
+
+runInterpolations :: Interpolations -> String -> Action String
+runInterpolations (Interpolations mk_substs) input = do
+    substs <- mk_substs
+    let subst :: String -> String
+        subst = foldr (.) id [replace ("@"++k++"@") v | (k,v) <- substs]
+    return (subst input)
+
+toCabalBool :: Bool -> String
+toCabalBool True  = "True"
+toCabalBool False = "False"
+
+-- | Interpolate the given variable with the value of the given 'Flag', using
+-- Cabal's boolean syntax.
+interpolateCabalFlag :: String -> Flag -> Interpolations
+interpolateCabalFlag name flg = interpolateVar name $ do
+    val <- flag flg
+    return (toCabalBool val)
+
+-- | Interpolate the given variable with the value of the given 'Setting'.
+interpolateSetting :: String -> Setting -> Interpolations
+interpolateSetting name settng = interpolateVar name $ setting settng
+
+-- | Interpolate the @ProjectVersion@ and @ProjectVersionMunged@ variables.
+projectVersion :: Interpolations
+projectVersion = mconcat
+    [ interpolateSetting "ProjectVersion" ProjectVersion
+    , interpolateSetting "ProjectVersionMunged" ProjectVersionMunged
     ]
 
+rtsCabalFlags :: Interpolations
+rtsCabalFlags = mconcat
+    [ flag "CabalMingwex" UseLibmingwex
+    , flag "CabalHaveLibdw" UseLibdw
+    , flag "CabalHaveLibm" UseLibm
+    , flag "CabalHaveLibrt" UseLibrt
+    , flag "CabalHaveLibdl" UseLibdl
+    , flag "CabalNeedLibpthread" UseLibpthread
+    , flag "CabalHaveLibbfd" UseLibbfd
+    , flag "CabalHaveLibNuma" UseLibnuma
+    , flag "CabalNeedLibatomic" NeedLibatomic
+    , flag "CabalUseSystemLibFFI" UseSystemFfi
+    , flag "CabalLibffiAdjustors" UseLibffiForAdjustors
+    , flag "CabalLeadingUnderscore" LeadingUnderscore
+    , interpolateVar "Cabal64bit" $ do
+        let settingWord :: Setting -> Action Word
+            settingWord s = read <$> setting s
+        ws <- settingWord TargetWordSize
+        return $ toCabalBool (ws == 8)
+    ]
+  where
+    flag = interpolateCabalFlag
+
+templateRule :: FilePath -> Interpolations -> Rules ()
+templateRule outPath interps = do
+    outPath %> \_ -> do
+        s <- readFile' (outPath <.> "in")
+        result <- runInterpolations interps s
+        writeFile' outPath result
+        putSuccess ("| Successfully generated " ++ outPath ++ " from its template")
+
 templateRules :: Rules ()
 templateRules = do
-  templateResults |%> \out -> do
-    let settingWord :: Setting -> Action Word
-        settingWord s = read <$> setting s
-
-    project_version        <- setting ProjectVersion
-    project_version_munged <- setting ProjectVersionMunged
-    target_word_size       <- settingWord TargetWordSize
-    lib_dw                 <- flag UseLibdw
-    lib_numa               <- flag UseLibnuma
-    lib_mingwex            <- flag UseLibmingwex
-    lib_m                  <- flag UseLibm
-    lib_rt                 <- flag UseLibrt
-    lib_dl                 <- flag UseLibdl
-    lib_ffi                <- flag UseSystemFfi
-    lib_ffi_adjustors      <- flag UseLibffiForAdjustors
-    lib_bfd                <- flag UseLibbfd
-    lib_pthread            <- flag UseLibpthread
-    leading_underscore     <- flag LeadingUnderscore
-    need_libatomic         <- flag NeedLibatomic
-
-    let cabal_bool True  = "True"
-        cabal_bool False = "False"
-
-        subst = replace "@ProjectVersion@" project_version
-                . replace "@ProjectVersionMunged@" project_version_munged
-                . replace "@Cabal64bit@" (cabal_bool (target_word_size == 8))
-                . replace "@CabalMingwex@" (cabal_bool lib_mingwex)
-                . replace "@CabalHaveLibdw@" (cabal_bool lib_dw)
-                . replace "@CabalHaveLibm@" (cabal_bool lib_m)
-                . replace "@CabalHaveLibrt@" (cabal_bool lib_rt)
-                . replace "@CabalHaveLibdl@" (cabal_bool lib_dl)
-                . replace "@CabalUseSystemLibFFI@" (cabal_bool lib_ffi)
-                . replace "@CabalLibffiAdjustors@" (cabal_bool lib_ffi_adjustors)
-                . replace "@CabalNeedLibpthread@" (cabal_bool lib_pthread)
-                . replace "@CabalHaveLibbfd@" (cabal_bool lib_bfd)
-                . replace "@CabalHaveLibNuma@" (cabal_bool lib_numa)
-                . replace "@CabalLeadingUnderscore@" (cabal_bool leading_underscore)
-                . replace "@CabalNeedLibatomic@" (cabal_bool need_libatomic)
-
-    s <- readFile' (out <.> "in")
-    writeFile' out (subst s)
-    putSuccess ("| Successfully generated " ++ out ++ " from its template")
+  templateRule "compiler/ghc.cabal" $ projectVersion
+  templateRule "rts/rts.cabal" $ rtsCabalFlags
+  templateRule "driver/ghci/ghci-wrapper.cabal" $ projectVersion
+  templateRule "ghc/ghc-bin.cabal" $ projectVersion
+  templateRule "utils/iserv/iserv.cabal" $ projectVersion
+  templateRule "utils/iserv-proxy/iserv-proxy.cabal" $ projectVersion
+  templateRule "utils/remote-iserv/remote-iserv.cabal" $ projectVersion
+  templateRule "utils/runghc/runghc.cabal" $ projectVersion
+  templateRule "libraries/ghc-boot/ghc-boot.cabal" $ projectVersion
+  templateRule "libraries/ghc-boot-th/ghc-boot-th.cabal" $ projectVersion
+  templateRule "libraries/ghci/ghci.cabal" $ projectVersion
+  templateRule "libraries/ghc-heap/ghc-heap.cabal" $ projectVersion
+  templateRule "utils/ghc-pkg/ghc-pkg.cabal" $ projectVersion
+  templateRule "libraries/libiserv/libiserv.cabal" $ projectVersion
+  templateRule "libraries/template-haskell/template-haskell.cabal" $ projectVersion
+
 
 -- Generators