[commit: ghc] wip/nfs-locking: Refactor oracles, drop redundant newCache. (13ad050)

[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/13ad050070d32c5c6267af8fba60125af878147c/ghc

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

commit 13ad050070d32c5c6267af8fba60125af878147c
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Fri Feb 19 01:15:10 2016 +0000

    Refactor oracles, drop redundant newCache.


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

13ad050070d32c5c6267af8fba60125af878147c
 src/Oracles/ArgsHash.hs     |  5 ++---
 src/Oracles/Dependencies.hs |  1 -
 src/Oracles/LookupInPath.hs | 12 +++++-------
 src/Oracles/PackageData.hs  |  5 ++---
 src/Oracles/PackageDb.hs    |  5 ++---
 src/Oracles/PackageDeps.hs  |  8 ++++----
 src/Oracles/WindowsPath.hs  | 10 ++++------
 7 files changed, 19 insertions(+), 27 deletions(-)

diff --git a/src/Oracles/ArgsHash.hs b/src/Oracles/ArgsHash.hs
index 796e753..aec0dc9 100644
--- a/src/Oracles/ArgsHash.hs
+++ b/src/Oracles/ArgsHash.hs
@@ -29,6 +29,5 @@ checkArgsHash target = when trackBuildSystem $ do
 
 -- Oracle for storing per-target argument list hashes
 argsHashOracle :: Rules ()
-argsHashOracle = do
-    _ <- addOracle $ \(ArgsHashKey target) -> hash <$> interpret target getArgs
-    return ()
+argsHashOracle = void $
+    addOracle $ \(ArgsHashKey target) -> hash <$> interpret target getArgs
diff --git a/src/Oracles/Dependencies.hs b/src/Oracles/Dependencies.hs
index 8895758..b34535b 100644
--- a/src/Oracles/Dependencies.hs
+++ b/src/Oracles/Dependencies.hs
@@ -33,6 +33,5 @@ dependenciesOracle = do
         putOracle $ "Reading dependencies from " ++ file ++ "..."
         contents <- map words <$> readFileLines file
         return . Map.fromList $ map (\(x:xs) -> (x, xs)) contents
-
     _ <- addOracle $ \(DependenciesKey (file, obj)) -> Map.lookup obj <$> deps file
     return ()
diff --git a/src/Oracles/LookupInPath.hs b/src/Oracles/LookupInPath.hs
index 2f6e713..0ea03fd 100644
--- a/src/Oracles/LookupInPath.hs
+++ b/src/Oracles/LookupInPath.hs
@@ -15,13 +15,11 @@ lookupInPath name
     | otherwise                 = return name
 
 lookupInPathOracle :: Rules ()
-lookupInPathOracle = do
-    answer <- newCache $ \query -> do
-        maybePath <- liftIO $ findExecutable query
+lookupInPathOracle = void $
+    addOracle $ \(LookupInPath name) -> do
+        maybePath <- liftIO $ findExecutable name
         path <- case maybePath of
             Just value -> return $ unifyPath value
-            Nothing    -> putError $ "Cannot find executable '" ++ query ++ "'."
-        putOracle $ "Executable found: " ++ query ++ " => " ++ path
+            Nothing    -> putError $ "Cannot find executable '" ++ name ++ "'."
+        putOracle $ "Executable found: " ++ name ++ " => " ++ path
         return path
-    _ <- addOracle $ \(LookupInPath query) -> answer query
-    return ()
diff --git a/src/Oracles/PackageData.hs b/src/Oracles/PackageData.hs
index d176839..ba3e205 100644
--- a/src/Oracles/PackageData.hs
+++ b/src/Oracles/PackageData.hs
@@ -86,10 +86,9 @@ pkgDataList packageData = fmap (map unquote . words) $ case packageData of
 -- Oracle for 'package-data.mk' files
 packageDataOracle :: Rules ()
 packageDataOracle = do
-    pkgDataContents <- newCache $ \file -> do
+    keys <- newCache $ \file -> do
         need [file]
         putOracle $ "Reading " ++ file ++ "..."
         liftIO $ readConfigFile file
-    _ <- addOracle $ \(PackageDataKey (file, key)) ->
-        Map.lookup key <$> pkgDataContents file
+    _ <- addOracle $ \(PackageDataKey (file, key)) -> Map.lookup key <$> keys file
     return ()
diff --git a/src/Oracles/PackageDb.hs b/src/Oracles/PackageDb.hs
index 97a2a5c..b644989 100644
--- a/src/Oracles/PackageDb.hs
+++ b/src/Oracles/PackageDb.hs
@@ -12,12 +12,11 @@ import Settings.Paths
 import Target
 
 packageDbOracle :: Rules ()
-packageDbOracle = do
-    _ <- addOracle $ \(PackageDbKey stage) -> do
+packageDbOracle = void $
+    addOracle $ \(PackageDbKey stage) -> do
         let dir  = packageDbDirectory stage
             file = dir -/- "package.cache"
         unlessM (liftIO $ IO.doesFileExist file) $ do
             removeDirectoryIfExists dir
             build $ Target (vanillaContext stage ghcPkg) (GhcPkg stage) [] [dir]
             putSuccess $ "| Successfully initialised " ++ dir
-    return ()
diff --git a/src/Oracles/PackageDeps.hs b/src/Oracles/PackageDeps.hs
index 94cdd91..6a5f7dd 100644
--- a/src/Oracles/PackageDeps.hs
+++ b/src/Oracles/PackageDeps.hs
@@ -8,9 +8,9 @@ import Package
 newtype PackageDepsKey = PackageDepsKey PackageName
     deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
 
--- packageDeps name is an action that given a package looks up its dependencies
--- in Base.packageDependencies file. The dependencies need to be computed by
--- scanning package cabal files (see Rules.Cabal).
+-- @packageDeps name@ is an action that given a 'Package' looks up its
+-- dependencies in 'Base.packageDependencies' file. The dependencies need to be
+-- computed by scanning package cabal files (see Rules.Cabal).
 packageDeps :: Package -> Action [PackageName]
 packageDeps pkg = do
     res <- askOracle . PackageDepsKey . pkgName $ pkg
@@ -23,6 +23,6 @@ packageDepsOracle = do
         putOracle $ "Reading package dependencies..."
         contents <- readFileLines packageDependencies
         return . Map.fromList $
-            [ (head ps, tail ps) | line <- contents, let ps = map PackageName $ words line ]
+            [ (p, ps) | line <- contents, let p:ps = map PackageName $ words line ]
     _ <- addOracle $ \(PackageDepsKey pkg) -> Map.lookup pkg <$> deps ()
     return ()
diff --git a/src/Oracles/WindowsPath.hs b/src/Oracles/WindowsPath.hs
index 3cbf1f1..a0343fb 100644
--- a/src/Oracles/WindowsPath.hs
+++ b/src/Oracles/WindowsPath.hs
@@ -15,7 +15,7 @@ topDirectory = do
     ghcSourcePath <- setting GhcSourcePath
     fixAbsolutePathOnWindows ghcSourcePath
 
--- Fix an absolute path on Windows:
+-- | Fix an absolute path on Windows:
 -- * "/c/" => "C:/"
 -- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
 fixAbsolutePathOnWindows :: FilePath -> Action FilePath
@@ -29,13 +29,11 @@ fixAbsolutePathOnWindows path = do
     else
         return path
 
--- Detecting path mapping on Windows. This is slow and requires caching.
+-- | Compute path mapping on Windows. This is slow and requires caching.
 windowsPathOracle :: Rules ()
-windowsPathOracle = do
-    answer <- newCache $ \path -> do
+windowsPathOracle = void $
+    addOracle $ \(WindowsPath path) -> do
         Stdout out <- quietly $ cmd ["cygpath", "-m", path]
         let windowsPath = unifyPath $ dropWhileEnd isSpace out
         putOracle $ "Windows path mapping: " ++ path ++ " => " ++ windowsPath
         return windowsPath
-    _ <- addOracle $ \(WindowsPath query) -> answer query
-    return ()