[commit: ghc] wip/nfs-locking: Add lookupAll and test it. (e054479)

[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/e0544796443fa3f220ac77f68891b6c4fc0f09bb/ghc

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

commit e0544796443fa3f220ac77f68891b6c4fc0f09bb
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Sun Feb 21 00:01:08 2016 +0000

    Add lookupAll and test it.
    
    See #210.


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

e0544796443fa3f220ac77f68891b6c4fc0f09bb
 src/Base.hs           | 22 ++++++++++++++++++----
 src/Rules/Selftest.hs | 15 +++++++++++++++
 2 files changed, 33 insertions(+), 4 deletions(-)

diff --git a/src/Base.hs b/src/Base.hs
index 7217834..324feb8 100644
--- a/src/Base.hs
+++ b/src/Base.hs
@@ -23,7 +23,7 @@ module Base (
     putColoured, putOracle, putBuild, putSuccess, putError,
 
     -- * Miscellaneous utilities
-    minusOrd, intersectOrd, replaceEq, quote, replaceSeparators,
+    minusOrd, intersectOrd, lookupAll, replaceEq, quote, replaceSeparators,
     decodeModule, encodeModule, unifyPath, (-/-), versionToInt,
     removeFileIfExists, removeDirectoryIfExists, matchVersionedFilePath
     ) where
@@ -165,9 +165,23 @@ intersectOrd cmp = loop
     loop [] _ = []
     loop _ [] = []
     loop (x:xs) (y:ys) = case cmp x y of
-         LT ->     loop xs (y:ys)
-         EQ -> x : loop xs ys
-         GT ->     loop (x:xs) ys
+        LT ->     loop xs (y:ys)
+        EQ -> x : loop xs ys
+        GT ->     loop (x:xs) ys
+
+-- | Lookup all elements of a given sorted list in a given sorted dictionary.
+-- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
+-- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
+--
+-- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
+-- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
+lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
+lookupAll []     _      = []
+lookupAll (_:xs) []     = Nothing : lookupAll xs []
+lookupAll (x:xs) (y:ys) = case compare x (fst y) of
+    LT -> Nothing      : lookupAll xs (y:ys)
+    EQ -> Just (snd y) : lookupAll xs (y:ys)
+    GT -> lookupAll (x:xs) ys
 
 -- | Remove a file that doesn't necessarily exist
 removeFileIfExists :: FilePath -> Action ()
diff --git a/src/Rules/Selftest.hs b/src/Rules/Selftest.hs
index c156b44..f549b0f 100644
--- a/src/Rules/Selftest.hs
+++ b/src/Rules/Selftest.hs
@@ -25,6 +25,7 @@ selftestRules =
         testChunksOfSize
         testMatchVersionedFilePath
         testModuleNames
+        testLookupAll
 
 testWays :: Action ()
 testWays = do
@@ -68,3 +69,17 @@ testModuleNames = do
     test $ forAll names $ \n -> uncurry encodeModule (decodeModule n) == n
   where
     names = intercalate "." <$> listOf1 (listOf1 $ elements "abcABC123_'")
+
+testLookupAll :: Action ()
+testLookupAll = do
+    putBuild $ "==== lookupAll"
+    test $ lookupAll ["b"    , "c"            ] [("a", 1), ("c", 3), ("d", 4)]
+                  == [Nothing, Just (3 :: Int)]
+    test $ forAll dicts $ \dict -> forAll extras $ \extra ->
+        let items = sort $ map fst dict ++ extra
+        in lookupAll items (sort dict) == map (flip lookup dict) items
+  where
+    dicts :: Gen [(Int, Int)]
+    dicts = nubBy ((==) `on` fst) <$> vector 20
+    extras :: Gen [Int]
+    extras = vector 20