[commit: ghc] wip/nfs-locking: Add matchVersionedFilePath and use for matching library targets. (5fcb480)

[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/5fcb480b9e5efc1aea8c4b32965d65cdae5da766/ghc

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

commit 5fcb480b9e5efc1aea8c4b32965d65cdae5da766
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Tue Feb 16 17:30:13 2016 +0000

    Add matchVersionedFilePath and use for matching library targets.


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

5fcb480b9e5efc1aea8c4b32965d65cdae5da766
 src/Base.hs          | 19 ++++++++++++++++++-
 src/Rules/Library.hs | 22 ++++++++++++----------
 2 files changed, 30 insertions(+), 11 deletions(-)

diff --git a/src/Base.hs b/src/Base.hs
index 1a06120..feec868 100644
--- a/src/Base.hs
+++ b/src/Base.hs
@@ -23,12 +23,13 @@ module Base (
     -- * Miscellaneous utilities
     bimap, minusOrd, intersectOrd, replaceEq, quote, replaceSeparators,
     decodeModule, encodeModule, unifyPath, (-/-), versionToInt,
-    removeFileIfExists, removeDirectoryIfExists
+    removeFileIfExists, removeDirectoryIfExists, matchVersionedFilePath
     ) where
 
 import Control.Applicative
 import Control.Monad.Extra
 import Control.Monad.Reader
+import Data.Char
 import Data.Function
 import Data.List.Extra
 import Data.Maybe
@@ -175,3 +176,19 @@ removeFileIfExists f = liftIO . whenM (IO.doesFileExist f) $ IO.removeFile f
 removeDirectoryIfExists :: FilePath -> Action ()
 removeDirectoryIfExists d =
     liftIO . whenM (IO.doesDirectoryExist d) $ IO.removeDirectoryRecursive d
+
+-- | Given a @prefix@ and a @suffix@ check whether a @filePath@ matches the
+-- template @prefix ++ version ++ suffix@ where @version@ is an arbitrary string
+-- comprising digits (@0-9@), dashes (@-@), and dots (@.@). Examples:
+--
+--- * @'matchVersionedFilePath' "foo/bar"  ".a" "foo/bar.a"     '==' 'True'@
+--- * @'matchVersionedFilePath' "foo/bar"  "a"  "foo/bar.a"     '==' 'True'@
+--- * @'matchVersionedFilePath' "foo/bar"  ""   "foo/bar.a"     '==' 'False'@
+--- * @'matchVersionedFilePath' "foo/bar"  "a"  "foo/bar-0.1.a" '==' 'True'@
+--- * @'matchVersionedFilePath' "foo/bar-" "a"  "foo/bar-0.1.a" '==' 'True'@
+--- * @'matchVersionedFilePath' "foo/bar/" "a"  "foo/bar-0.1.a" '==' 'False'@
+matchVersionedFilePath :: String -> String -> FilePath -> Bool
+matchVersionedFilePath prefix suffix filePath =
+    case stripPrefix prefix (unifyPath filePath) >>= stripSuffix suffix of
+        Nothing      -> False
+        Just version -> all (\c -> isDigit c || c == '-' || c == '.') version
diff --git a/src/Rules/Library.hs b/src/Rules/Library.hs
index d77d58e..e53355f 100644
--- a/src/Rules/Library.hs
+++ b/src/Rules/Library.hs
@@ -17,9 +17,10 @@ import Target
 buildPackageLibrary :: Context -> Rules ()
 buildPackageLibrary context @ (Context {..}) = do
     let buildPath = targetPath stage package -/- "build"
+        libHs     = buildPath -/- "libHS" ++ pkgNameString package
 
     -- TODO: handle dynamic libraries
-    buildPath <//> "*" ++ waySuffix way ++ ".a" %> \a -> do
+    matchVersionedFilePath libHs (waySuffix way <.> "a") ?> \a -> do
         removeFileIfExists a
         cSrcs <- cSources context
         hSrcs <- hSources context
@@ -61,15 +62,16 @@ buildPackageLibrary context @ (Context {..}) = do
     -- TODO: this looks fragile as haskell objects can match this rule if their
     -- names start with "HS" and they are on top of the module hierarchy.
     -- This happens with hsc2hs, which has top-level file HSCParser.hs.
-    when (package /= hsc2hs) $ priority 2 $ (buildPath -/- "HS*.o") %> \obj -> do
-        cSrcs <- cSources context
-        hSrcs <- hSources context
-        let cObjs = [ buildPath -/- src -<.> "o" | src <- cSrcs
-                    , not ("//AutoApply.cmm" ?== src) ]
-                 ++ [ src -<.> "o" | src <- cSrcs, "//AutoApply.cmm" ?== src ]
-            hObjs = [ buildPath -/- src  <.> "o" | src <- hSrcs ]
-        need $ cObjs ++ hObjs
-        build $ Target context Ld (cObjs ++ hObjs) [obj]
+    priority 2 $ when (package /= hsc2hs && way == vanilla) $
+         (buildPath -/- "HS*.o") %> \obj -> do
+            cSrcs <- cSources context
+            hSrcs <- hSources context
+            let cObjs = [ buildPath -/- src -<.> "o" | src <- cSrcs
+                        , not ("//AutoApply.cmm" ?== src) ]
+                     ++ [ src -<.> "o" | src <- cSrcs, "//AutoApply.cmm" ?== src ]
+                hObjs = [ buildPath -/- src  <.> "o" | src <- hSrcs ]
+            need $ cObjs ++ hObjs
+            build $ Target context Ld (cObjs ++ hObjs) [obj]
 
 cSources :: Context -> Action [FilePath]
 cSources context = interpretInContext context $ getPkgDataList CSrcs