Fix overlapping build rules and generalise the pattern
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 17 Aug 2017 18:59:54 +0000 (19:59 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 17 Aug 2017 18:59:54 +0000 (19:59 +0100)
See #391

src/Hadrian/Utilities.hs
src/Rules/Library.hs
src/Rules/Register.hs

index 3fe389d..0765891 100644 (file)
@@ -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@. 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)
index f4259fb..f3a162e 100644 (file)
@@ -53,7 +53,7 @@ buildDynamicLib context@Context{..} = do
 buildPackageLibrary :: Context -> Rules ()
 buildPackageLibrary context@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
index 261f142..cd48d91 100644 (file)
@@ -15,17 +15,15 @@ registerPackage rs context@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