[commit: ghc] master: When verbose, give more information about cache status (896d0f1)

[Ian Lynagh]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : master

https://github.com/ghc/ghc/commit/896d0f1ad4e67af1d3a731af21ab65a3f5d406e3

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

commit 896d0f1ad4e67af1d3a731af21ab65a3f5d406e3
Author: Ian Lynagh <ian at well-typed.com>
Date:   Thu May 30 19:18:29 2013 +0100

    When verbose, give more information about cache status

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

 utils/ghc-pkg/Main.hs | 52 ++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 35 insertions(+), 17 deletions(-)

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 532bc02..716e7ae 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -612,7 +612,7 @@ readParseDatabase verbosity mb_user_conf use_cache path
               pkgs <- parseMultiPackageConf verbosity path
               mkPackageDB pkgs
          Right fs
-           | not use_cache -> ignore_cache
+           | not use_cache -> ignore_cache (const $ return ())
            | otherwise -> do
               let cache = path </> cachefilename
               tdir     <- getModificationTime path
@@ -621,24 +621,42 @@ readParseDatabase verbosity mb_user_conf use_cache path
                 Left ex -> do
                      when (verbosity > Normal) $
                         warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
-                     ignore_cache
-                Right tcache
-                  | tcache >= tdir -> do
-                     when (verbosity > Normal) $
-                        infoLn ("using cache: " ++ cache)
-                     pkgs <- myReadBinPackageDB cache
-                     let pkgs' = map convertPackageInfoIn pkgs
-                     mkPackageDB pkgs'
-                  | otherwise -> do
-                     when (verbosity >= Normal) $ do
-                        warn ("WARNING: cache is out of date: " ++ cache)
-                        warn "  use 'ghc-pkg recache' to fix."
-                     ignore_cache
+                     ignore_cache (const $ return ())
+                Right tcache -> do
+                  let compareTimestampToCache file =
+                          when (verbosity >= Verbose) $ do
+                              tFile <- getModificationTime file
+                              compareTimestampToCache' file tFile
+                      compareTimestampToCache' file tFile = do
+                          let rel = case tcache `compare` tFile of
+                                    LT -> " (NEWER than cache)"
+                                    GT -> " (older than cache)"
+                                    EQ -> " (same as cache)"
+                          warn ("Timestamp " ++ show tFile
+                             ++ " for " ++ file ++ rel)
+                  when (verbosity >= Verbose) $ do
+                      warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
+                      compareTimestampToCache' path tdir
+                  if tcache >= tdir
+                      then do
+                          when (verbosity > Normal) $
+                             infoLn ("using cache: " ++ cache)
+                          pkgs <- myReadBinPackageDB cache
+                          let pkgs' = map convertPackageInfoIn pkgs
+                          mkPackageDB pkgs'
+                      else do
+                          when (verbosity >= Normal) $ do
+                              warn ("WARNING: cache is out of date: "
+                                 ++ cache)
+                              warn "Use 'ghc-pkg recache' to fix."
+                          ignore_cache compareTimestampToCache
             where
-                 ignore_cache = do
+                 ignore_cache :: (FilePath -> IO ()) -> IO PackageDB
+                 ignore_cache checkTime = do
                      let confs = filter (".conf" `isSuffixOf`) fs
-                     pkgs <- mapM (parseSingletonPackageConf verbosity) $
-                                   map (path </>) confs
+                         doFile f = do checkTime f
+                                       parseSingletonPackageConf verbosity f
+                     pkgs <- mapM doFile $ map (path </>) confs
                      mkPackageDB pkgs
   where
     mkPackageDB pkgs = do