Hadrian: generalise &%> to avoid warnings

This patch introduces a more general version of &%> that works
with general traversable shapes, instead of lists. This allows us
to pass along the information that the length of the list of filepaths
passed to the function exactly matches the length of the input list
of filepath patterns, avoiding pattern match warnings.

Fixes #22430

7 files changed, 91 insertions, 21 deletions

diff --git a/hadrian/src/Base.hs b/hadrian/src/Base.hs
index 3fcc3bb3c6..72baba6aaa 100644
--- a/hadrian/src/Base.hs
+++ b/hadrian/src/Base.hs
@@ -1,4 +1,10 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Base (
     -- * General utilities
@@ -15,6 +21,8 @@ module Base (
     module Development.Shake.FilePath,
     module Development.Shake.Util,
 
+    Vec(..), (&%>),
+
     -- * Basic data types
     module Hadrian.Package,
     module Stage,
@@ -36,14 +44,19 @@ module Base (
 import Control.Applicative
 import Control.Monad.Extra
 import Control.Monad.Reader
+import Control.Monad.State ( State )
+import qualified Control.Monad.State as State
+import Data.Foldable (toList)
+import Data.Kind
 import Data.List.Extra
 import Data.Maybe
 import Data.Semigroup
 #if MIN_VERSION_shake(0,19,0)
-import Development.Shake hiding (unit, Normal)
+import Development.Shake hiding (unit, (&%>), Normal)
 #else
-import Development.Shake hiding (unit, (*>), Normal)
+import Development.Shake hiding (unit, (&%>), (*>), Normal)
 #endif
+import qualified Development.Shake as Shake
 import Development.Shake.Classes
 import Development.Shake.FilePath
 import Development.Shake.Util
@@ -51,6 +64,8 @@ import Hadrian.Oracles.DirectoryContents
 import Hadrian.Utilities
 import Hadrian.Package
 
+import GHC.Stack ( HasCallStack )
+
 import Stage
 import Way
 
@@ -156,3 +171,43 @@ templateHscPath stage = stageLibPath stage <&> (-/- "template-hsc.h")
 --   Windows). See "Rules.Program".
 mingwStamp :: FilePath
 mingwStamp = "mingw" -/- ".stamp"
+
+-- | Same as @'Development.Shake.&%>'@ except that it works with an arbitrary
+-- traversable structure of 'FilePattern's, which avoids running into incomplete
+-- pattern match warnings (see #22430).
+(&%>) :: (HasCallStack, Traversable t, Show (t FilePath))
+      => t FilePattern -> (t FilePath -> Action ()) -> Rules ()
+ps &%> f = toList ps Shake.&%> ( \ fs -> f (fromListWithShape ps fs) )
+
+-- | Utility function that fills in the values of a traversable shape
+-- with the elements of the provided list.
+fromListWithShape :: forall t a b
+                  .  ( HasCallStack, Show (t a), Show b, Traversable t )
+                  => t a -> [b] -> t b
+fromListWithShape shape elts =
+  traverse (const getElt) shape `State.evalState` elts
+  where
+    getElt :: State [b] b
+    getElt = do { s <- State.get
+                ; case s of
+                { []   -> error $ "fromListWithShape: not enough elements to fill this shape\n"
+                               ++ "elements: " ++ show elts ++"\n"
+                               ++ "shape: " ++ show shape
+                ; b:bs ->
+             do { State.put bs
+                ; return b } } }
+
+infixr 5 :&
+data Nat = Zero | Succ Nat
+
+-- | A traversable vector type, defined for convenient use with '(&%>)'.
+type Vec :: Nat -> Type -> Type
+data Vec n a where
+  Nil  :: Vec Zero a
+  (:&) :: a -> Vec n a -> Vec (Succ n) a
+
+deriving instance Functor     (Vec n)
+deriving instance Foldable    (Vec n)
+deriving instance Traversable (Vec n)
+instance Show a => Show (Vec n a) where
+  showsPrec p v = showsPrec p (toList v)
diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
index ab7850771c..a968975837 100644
--- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
+++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
@@ -212,14 +212,18 @@ resolveContextData context@Context {..} = do
 
     -- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations
     -- See: https://github.com/snowleopard/hadrian/issues/548
-    let extDeps      = externalPackageDeps lbi'
-        deps         = map (C.display . snd) extDeps
-        depDirect    = map (fromMaybe (error "resolveContextData: depDirect failed")
-                     . C.lookupUnitId (C.installedPkgs lbi') . fst) extDeps
-        depIds       = map (C.display . Installed.installedUnitId) depDirect
-        Just ghcProg = C.lookupProgram C.ghcProgram (C.withPrograms lbi')
-        depPkgs      = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
-        forDeps f    = concatMap f depPkgs
+    let extDeps   = externalPackageDeps lbi'
+        deps      = map (C.display . snd) extDeps
+        depDirect = map (fromMaybe (error "resolveContextData: depDirect failed")
+                  . C.lookupUnitId (C.installedPkgs lbi') . fst) extDeps
+        depIds    = map (C.display . Installed.installedUnitId) depDirect
+        ghcProg   =
+          case C.lookupProgram C.ghcProgram (C.withPrograms lbi') of
+            Just ghc -> ghc
+            Nothing  -> error "resolveContextData: failed to look up 'ghc'"
+
+        depPkgs   = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
+        forDeps f = concatMap f depPkgs
 
         -- Copied from Distribution.Simple.PreProcess.ppHsc2Hs
         packageHacks = case C.compilerFlavor (C.compiler lbi') of
diff --git a/hadrian/src/Rules/Compile.hs b/hadrian/src/Rules/Compile.hs
index 93d24314ea..473d2cf76e 100644
--- a/hadrian/src/Rules/Compile.hs
+++ b/hadrian/src/Rules/Compile.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
 module Rules.Compile (compilePackage) where
 
 import Hadrian.BuildPath
@@ -57,8 +59,8 @@ compilePackage rs = do
       -- When building dynamically we depend on the static rule if shared libs
       -- are supported, because it will add the -dynamic-too flag when
       -- compiling to build the dynamic files alongside the static files
-      [ root -/- "**/build/**/*.dyn_o", root -/- "**/build/**/*.dyn_hi" ]
-        &%> \ [dyn_o, _dyn_hi] -> do
+      ( root -/- "**/build/**/*.dyn_o" :& root -/- "**/build/**/*.dyn_hi" :& Nil )
+        &%> \ ( dyn_o :& _dyn_hi :& _ ) -> do
           p <- platformSupportsSharedLibs
           if p
             then do
@@ -80,9 +82,11 @@ compilePackage rs = do
             else compileHsObjectAndHi rs dyn_o
 
       forM_ ((,) <$> hsExts <*> wayPats) $ \ ((oExt, hiExt), wayPat) ->
-        [ root -/- "**/build/**/*." ++ wayPat ++ oExt
-        , root -/- "**/build/**/*." ++ wayPat ++ hiExt ]
-          &%> \ [o, _hi] -> compileHsObjectAndHi rs o
+        (  (root -/- "**/build/**/*." ++ wayPat ++ oExt)
+        :& (root -/- "**/build/**/*." ++ wayPat ++ hiExt)
+        :& Nil ) &%>
+          \ ( o :& _hi :& _ ) ->
+            compileHsObjectAndHi rs o
   where
     hsExts = [ ("o", "hi")
              , ("o-boot", "hi-boot")
diff --git a/hadrian/src/Rules/Dependencies.hs b/hadrian/src/Rules/Dependencies.hs
index ebdb7b70d8..b807dddbc7 100644
--- a/hadrian/src/Rules/Dependencies.hs
+++ b/hadrian/src/Rules/Dependencies.hs
@@ -1,7 +1,6 @@
 module Rules.Dependencies (buildPackageDependencies) where
 
 import Data.Bifunctor
-import Data.Function
 import qualified Data.List.NonEmpty as NE
 
 import Base
diff --git a/hadrian/src/Rules/Documentation.hs b/hadrian/src/Rules/Documentation.hs
index df5fdfb94b..10a2c2ce57 100644
--- a/hadrian/src/Rules/Documentation.hs
+++ b/hadrian/src/Rules/Documentation.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
 module Rules.Documentation (
     -- * Rules
     buildPackageDocumentation, documentationRules,
@@ -333,7 +335,7 @@ buildSphinxInfoGuide = do
             -- default target of which actually produces the target
             -- for this build rule.
             let p = dir -/- path
-            let [texipath, infopath] = map (p <.>) ["texi", "info"]
+            let (texipath :& infopath :& _) = fmap (p <.>) ("texi" :& "info" :& Nil)
             build $ target docContext (Makeinfo) [texipath] [infopath]
             copyFileUntracked infopath file
 
diff --git a/hadrian/src/Rules/Gmp.hs b/hadrian/src/Rules/Gmp.hs
index 985f13ef29..f6222a6643 100644
--- a/hadrian/src/Rules/Gmp.hs
+++ b/hadrian/src/Rules/Gmp.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
 module Rules.Gmp (gmpRules, gmpBuildPath, gmpObjects) where
 
 import Base
@@ -96,7 +98,8 @@ gmpRules = do
         --  - <root>/stageN/gmp/gmp.h
         --  - <root>/stageN/gmp/libgmp.a
         --  - <root>/stageN/gmp/objs/*.o (unpacked objects from libgmp.a)
-        [gmpPath -/- "libgmp.a", gmpPath -/- "gmp.h"] &%> \[lib,header] -> do
+        (gmpPath -/- "libgmp.a" :& gmpPath -/- "gmp.h" :& Nil) &%>
+          \( lib :& header :& _) -> do
             let gmpP = takeDirectory lib
             ctx <- makeGmpPathContext gmpP
             -- build libgmp.a via gmp's Makefile
@@ -133,7 +136,8 @@ gmpRules = do
         -- Extract in-tree GMP sources and apply patches. Produce
         --  - <root>/stageN/gmp/gmpbuild/Makefile.in
         --  - <root>/stageN/gmp/gmpbuild/configure
-        [gmpPath -/- "gmpbuild/Makefile.in", gmpPath -/- "gmpbuild/configure"] &%> \[mkIn,_] -> do
+        (gmpPath -/- "gmpbuild/Makefile.in" :& gmpPath -/- "gmpbuild/configure" :& Nil)
+           &%> \( mkIn :& _ ) -> do
             top <- topDirectory
             let gmpBuildP = takeDirectory mkIn
                 gmpP      = takeDirectory gmpBuildP
diff --git a/hadrian/src/Rules/Libffi.hs b/hadrian/src/Rules/Libffi.hs
index 61aa133038..caa12fe51e 100644
--- a/hadrian/src/Rules/Libffi.hs
+++ b/hadrian/src/Rules/Libffi.hs
@@ -202,7 +202,8 @@ libffiRules = do
         writeFileLines dynLibMan dynLibFiles
         putSuccess "| Successfully build libffi."
 
-    fmap (libffiPath -/-) ["Makefile.in", "configure" ] &%> \[mkIn, _] -> do
+    fmap (libffiPath -/-) ( "Makefile.in" :& "configure" :& Nil ) &%>
+      \ ( mkIn :& _ ) -> do
         -- Extract libffi tar file
         context <- libffiContext stage
         removeDirectory libffiPath
@@ -225,7 +226,8 @@ libffiRules = do
         files <- liftIO $ getDirectoryFilesIO "." [libffiPath -/- "**"]
         produces files
 
-    fmap (libffiPath -/-) ["Makefile", "config.guess", "config.sub"] &%> \[mk, _, _] -> do
+    fmap (libffiPath -/-) ("Makefile" :& "config.guess" :& "config.sub" :& Nil)
+      &%> \( mk :& _ ) -> do
         _ <- needLibfffiArchive libffiPath
         context <- libffiContext stage