[commit: ghc] wip/nfs-locking: Fix overlapping build rules and generalise the pattern (e815c5f)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/e815c5f5100fa218415e19ea9a577c5428f8ec0a/ghc

>---------------------------------------------------------------

commit e815c5f5100fa218415e19ea9a577c5428f8ec0a
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Thu Aug 17 19:59:54 2017 +0100

    Fix overlapping build rules and generalise the pattern
    
    See #391


>---------------------------------------------------------------

e815c5f5100fa218415e19ea9a577c5428f8ec0a
 src/Hadrian/Utilities.hs | 11 ++++++++++-
 src/Rules/Library.hs     |  2 +-
 src/Rules/Register.hs    | 10 ++++------
 3 files changed, 15 insertions(+), 8 deletions(-)

diff --git a/src/Hadrian/Utilities.hs b/src/Hadrian/Utilities.hs
index 3fe389d..0765891 100644
--- a/src/Hadrian/Utilities.hs
+++ b/src/Hadrian/Utilities.hs
@@ -25,7 +25,7 @@ module Hadrian.Utilities (
     renderUnicorn,
 
     -- * Miscellaneous
-    (<&>),
+    (<&>), (%%>),
 
     -- * Useful re-exports
     Dynamic, fromDynamic, toDyn, TypeRep, typeOf
@@ -116,6 +116,15 @@ a  -/- b
 
 infixr 6 -/-
 
+-- | Like Shake's '%>' but gives higher priority to longer patterns. Useful
+-- in situations when a family of build rules, e.g. @"//*.a"@ and @"//*_p.a"@
+-- can be matched by the same file, such as @library_p.a at . We break the tie
+-- by preferring longer matches, which correpond to longer patterns.
+(%%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()
+p %%> a = priority (fromIntegral (length p) + 1) $ p %> a
+
+infix 1 %%>
+
 -- | Insert a value into Shake's type-indexed map.
 insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
 insertExtra value = Map.insert (typeOf value) (toDyn value)
diff --git a/src/Rules/Library.hs b/src/Rules/Library.hs
index f4259fb..f3a162e 100644
--- a/src/Rules/Library.hs
+++ b/src/Rules/Library.hs
@@ -53,7 +53,7 @@ buildDynamicLib context at Context{..} = do
 buildPackageLibrary :: Context -> Rules ()
 buildPackageLibrary context at Context {..} = do
     let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgNameString package
-    libPrefix ++ "*" ++ (waySuffix way <.> "a") %> \a -> do
+    libPrefix ++ "*" ++ (waySuffix way <.> "a") %%> \a -> do
         objs <- libraryObjects context
         asuf <- libsuf way
         let isLib0 = ("//*-0" ++ asuf) ?== a
diff --git a/src/Rules/Register.hs b/src/Rules/Register.hs
index 261f142..cd48d91 100644
--- a/src/Rules/Register.hs
+++ b/src/Rules/Register.hs
@@ -15,17 +15,15 @@ registerPackage rs context at Context {..} = do
         -- Packages @ghc-boot@ and @ghc-boot-th@ both match the @ghc-boot*@
         -- pattern, therefore we need to use priorities to match the right rule.
         -- TODO: Get rid of this hack.
-        priority (fromIntegral . length $ pkgNameString package) $
-            "//" ++ stage0PackageDbDir -/- pkgNameString package ++ "*.conf" %>
-                buildConf rs context
+        "//" ++ stage0PackageDbDir -/- pkgNameString package ++ "*.conf" %%>
+            buildConf rs context
 
         when (package == ghc) $ "//" ++ stage0PackageDbDir -/- packageDbStamp %>
             buildStamp rs context
 
     when (stage == Stage1) $ do
-        priority (fromIntegral . length $ pkgNameString package) $
-            inplacePackageDbPath -/- pkgNameString package ++ "*.conf" %>
-                buildConf rs context
+        inplacePackageDbPath -/- pkgNameString package ++ "*.conf" %%>
+            buildConf rs context
 
         when (package == ghc) $ inplacePackageDbPath -/- packageDbStamp %>
             buildStamp rs context