Commit e815c5f5 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Fix overlapping build rules and generalise the pattern

See #391
parent 4fca3ae5
...@@ -25,7 +25,7 @@ module Hadrian.Utilities ( ...@@ -25,7 +25,7 @@ module Hadrian.Utilities (
renderUnicorn, renderUnicorn,
-- * Miscellaneous -- * Miscellaneous
(<&>), (<&>), (%%>),
-- * Useful re-exports -- * Useful re-exports
Dynamic, fromDynamic, toDyn, TypeRep, typeOf Dynamic, fromDynamic, toDyn, TypeRep, typeOf
...@@ -116,6 +116,15 @@ a -/- b ...@@ -116,6 +116,15 @@ a -/- b
infixr 6 -/- 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. -- | Insert a value into Shake's type-indexed map.
insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
insertExtra value = Map.insert (typeOf value) (toDyn value) insertExtra value = Map.insert (typeOf value) (toDyn value)
......
...@@ -53,7 +53,7 @@ buildDynamicLib context@Context{..} = do ...@@ -53,7 +53,7 @@ buildDynamicLib context@Context{..} = do
buildPackageLibrary :: Context -> Rules () buildPackageLibrary :: Context -> Rules ()
buildPackageLibrary context@Context {..} = do buildPackageLibrary context@Context {..} = do
let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgNameString package let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgNameString package
libPrefix ++ "*" ++ (waySuffix way <.> "a") %> \a -> do libPrefix ++ "*" ++ (waySuffix way <.> "a") %%> \a -> do
objs <- libraryObjects context objs <- libraryObjects context
asuf <- libsuf way asuf <- libsuf way
let isLib0 = ("//*-0" ++ asuf) ?== a let isLib0 = ("//*-0" ++ asuf) ?== a
......
...@@ -15,17 +15,15 @@ registerPackage rs context@Context {..} = do ...@@ -15,17 +15,15 @@ registerPackage rs context@Context {..} = do
-- Packages @ghc-boot@ and @ghc-boot-th@ both match the @ghc-boot*@ -- Packages @ghc-boot@ and @ghc-boot-th@ both match the @ghc-boot*@
-- pattern, therefore we need to use priorities to match the right rule. -- pattern, therefore we need to use priorities to match the right rule.
-- TODO: Get rid of this hack. -- TODO: Get rid of this hack.
priority (fromIntegral . length $ pkgNameString package) $ "//" ++ stage0PackageDbDir -/- pkgNameString package ++ "*.conf" %%>
"//" ++ stage0PackageDbDir -/- pkgNameString package ++ "*.conf" %> buildConf rs context
buildConf rs context
when (package == ghc) $ "//" ++ stage0PackageDbDir -/- packageDbStamp %> when (package == ghc) $ "//" ++ stage0PackageDbDir -/- packageDbStamp %>
buildStamp rs context buildStamp rs context
when (stage == Stage1) $ do when (stage == Stage1) $ do
priority (fromIntegral . length $ pkgNameString package) $ inplacePackageDbPath -/- pkgNameString package ++ "*.conf" %%>
inplacePackageDbPath -/- pkgNameString package ++ "*.conf" %> buildConf rs context
buildConf rs context
when (package == ghc) $ inplacePackageDbPath -/- packageDbStamp %> when (package == ghc) $ inplacePackageDbPath -/- packageDbStamp %>
buildStamp rs context buildStamp rs context
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment