[Git][ghc/ghc][master] Hadrian: generalise &%> to avoid warnings
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Jan 17 01:49:25 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
33b58f77 by sheaf at 2023-01-16T20:48:57-05:00
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 changed files:
- hadrian/src/Base.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Rules/Compile.hs
- hadrian/src/Rules/Dependencies.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Gmp.hs
- hadrian/src/Rules/Libffi.hs
Changes:
=====================================
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)
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -212,14 +212,18 @@ resolveContextData context at 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
=====================================
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")
=====================================
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
=====================================
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
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/33b58f77d2dd2bf17cd5fbfc3c06c8b2c44f5181
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/33b58f77d2dd2bf17cd5fbfc3c06c8b2c44f5181
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230116/786e688e/attachment-0001.html>
More information about the ghc-commits
mailing list