Refactor summarise{File,Module} to extract checkSummaryTimestamp

This introduces a slight change of behaviour in the interrest of keeping
the code simple: Previously summariseModule would not call
addHomeModuleToFinder for summaries that are being re-used but now we do.

We're forced to to do this in summariseFile because the file being
summarised might not even be on the regular search path! So if GHC is to
find it at all we have to pre-populate the cache with its location. For
modules however the finder cache is really just a cache so we don't have to
pre-populate it with the module's location.

As straightforward as that seems I did almost manage to introduce a bug (or
so I thought) because the call to addHomeModuleToFinder I copied from
summariseFile used to use `ms_location old_summary` instead of the
`location` argument to checkSummaryTimestamp. If this call were to
overwrite the existing entry in the cache that would have resulted in us
using the old location of any module even if it was, say, moved to a
different directory between calls to 'depanal'.

However it turns out the cache just ignores the location if the module is
already in the cache. Since summariseModule has to search for the module,
which has the side effect of populating the cache, everything would have
been fine either way.

Well I'm adding a test for this anyways: tests/depanal/OldModLocation.hs.

4 files changed, 123 insertions, 47 deletions

diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 760d9d4f97..bfbeb55c75 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -2224,40 +2224,20 @@ summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf
                 -- behaviour.
 
                 -- return the cached summary if the source didn't change
-        if ms_hs_date old_summary == src_timestamp &&
-           not (gopt Opt_ForceRecomp (hsc_dflags hsc_env))
-           then do -- update the object-file timestamp
-                  obj_timestamp <-
-                    if isObjectTarget (hscTarget (hsc_dflags hsc_env))
-                        || obj_allowed -- bug #1205
-                        then liftIO $ getObjTimestamp location NotBoot
-                        else return Nothing
-                  hi_timestamp <- maybeGetIfaceDate dflags location
-                  let hie_location = ml_hie_file location
-                  hie_timestamp <- modificationTimeIfExists hie_location
-
-                  -- We have to repopulate the Finder's cache because it
-                  -- was flushed before the downsweep.
-                  _ <- liftIO $ addHomeModuleToFinder hsc_env
-                    (moduleName (ms_mod old_summary)) (ms_location old_summary)
-
-                  return $ Right
-                         old_summary{ ms_obj_date = obj_timestamp
-                                    , ms_iface_date = hi_timestamp
-                                    , ms_hie_date = hie_timestamp }
-           else
-                new_summary src_timestamp
+        checkSummaryTimestamp
+            hsc_env dflags obj_allowed NotBoot (new_summary src_fn)
+            old_summary location src_timestamp
 
    | otherwise
    = do src_timestamp <- get_src_timestamp
-        new_summary src_timestamp
+        new_summary src_fn src_timestamp
   where
     get_src_timestamp = case maybe_buf of
                            Just (_,t) -> return t
                            Nothing    -> liftIO $ getModificationUTCTime src_fn
                         -- getModificationUTCTime may fail
 
-    new_summary src_timestamp = fmap Right $ do
+    new_summary src_fn src_timestamp = fmap Right $ do
         preimps@PreprocessedImports {..}
             <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
 
@@ -2290,6 +2270,44 @@ findSummaryBySourceFile summaries file
         [] -> Nothing
         (x:_) -> Just x
 
+checkSummaryTimestamp
+    :: HscEnv -> DynFlags -> Bool -> IsBoot
+    -> (UTCTime -> IO (Either a ModSummary))
+    -> ModSummary -> ModLocation -> UTCTime
+    -> IO (Either a ModSummary)
+checkSummaryTimestamp
+  hsc_env dflags obj_allowed is_boot new_summary
+  old_summary location src_timestamp
+  | ms_hs_date old_summary == src_timestamp &&
+      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do
+           -- update the object-file timestamp
+           obj_timestamp <-
+             if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+                 || obj_allowed -- bug #1205
+                 then liftIO $ getObjTimestamp location is_boot
+                 else return Nothing
+
+           -- We have to repopulate the Finder's cache for file targets
+           -- because the file might not even be on the regular serach path
+           -- and it was likely flushed in depanal. This is not technically
+           -- needed when we're called from sumariseModule but it shouldn't
+           -- hurt.
+           _ <- addHomeModuleToFinder hsc_env
+                  (moduleName (ms_mod old_summary)) location
+
+           hi_timestamp <- maybeGetIfaceDate dflags location
+           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
+
+           return $ Right old_summary
+               { ms_obj_date = obj_timestamp
+               , ms_iface_date = hi_timestamp
+               , ms_hie_date = hie_timestamp
+               }
+
+   | otherwise =
+           -- source changed: re-summarise.
+           new_summary src_timestamp
+
 -- Summarise a module, and pick up source and timestamp.
 summariseModule
           :: HscEnv
@@ -2316,11 +2334,13 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                 -- return the cached summary if it hasn't changed.  If the
                 -- file has disappeared, we need to call the Finder again.
         case maybe_buf of
-           Just (_,t) -> check_timestamp old_summary location src_fn t
+           Just (_,t) ->
+               Just <$> check_timestamp old_summary location src_fn t
            Nothing    -> do
                 m <- tryIO (getModificationUTCTime src_fn)
                 case m of
-                   Right t -> check_timestamp old_summary location src_fn t
+                   Right t ->
+                       Just <$> check_timestamp old_summary location src_fn t
                    Left e | isDoesNotExistError e -> find_it
                           | otherwise             -> ioError e
 
@@ -2328,23 +2348,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
   where
     dflags = hsc_dflags hsc_env
 
-    check_timestamp old_summary location src_fn src_timestamp
-        | ms_hs_date old_summary == src_timestamp &&
-          not (gopt Opt_ForceRecomp dflags) = do
-                -- update the object-file timestamp
-                obj_timestamp <-
-                    if isObjectTarget (hscTarget (hsc_dflags hsc_env))
-                       || obj_allowed -- bug #1205
-                       then getObjTimestamp location is_boot
-                       else return Nothing
-                hi_timestamp <- maybeGetIfaceDate dflags location
-                hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
-                return (Just (Right old_summary{ ms_obj_date = obj_timestamp
-                                               , ms_iface_date = hi_timestamp
-                                               , ms_hie_date = hie_timestamp }))
-        | otherwise =
-                -- source changed: re-summarise.
-                new_summary location (ms_mod old_summary) src_fn src_timestamp
+    check_timestamp old_summary location src_fn =
+        checkSummaryTimestamp
+          hsc_env dflags obj_allowed is_boot
+          (new_summary location (ms_mod old_summary) src_fn)
+          old_summary location
 
     find_it = do
         found <- findImportedModule hsc_env wanted_mod Nothing
@@ -2352,7 +2360,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
              Found location mod
                 | isJust (ml_hs_file location) ->
                         -- Home package
-                         just_found location mod
+                         Just <$> just_found location mod
 
              _ -> return Nothing
                         -- Not found
@@ -2370,12 +2378,12 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                 -- It might have been deleted since the Finder last found it
         maybe_t <- modificationTimeIfExists src_fn
         case maybe_t of
-          Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn
+          Nothing -> return $ Left $ noHsFileErr dflags loc src_fn
           Just t  -> new_summary location' mod src_fn t
 
 
     new_summary location mod src_fn src_timestamp
-      = fmap Just $ fmap Right $ do
+      = fmap Right $ do
         preimps@PreprocessedImports {..}
             <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf
 
diff --git a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs
new file mode 100644
index 0000000000..a96bd42d24
--- /dev/null
+++ b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE ViewPatterns #-}
+
+import GHC
+import GhcMake
+import DynFlags
+import Finder
+
+import Control.Monad.IO.Class (liftIO)
+import Data.List
+import Data.Either
+
+import System.Environment
+import System.Directory
+import System.IO
+
+main :: IO ()
+main = do
+  libdir:args <- getArgs
+
+  runGhc (Just libdir) $
+    defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
+
+    dflags0 <- getSessionDynFlags
+    (dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $
+        [ "-i", "-i.", "-imydir"
+        -- , "-v3"
+        ] ++ args
+    _ <- setSessionDynFlags dflags1
+
+    liftIO $ mapM_ writeMod
+      [ [ "module A where"
+        , "import B"
+        ]
+      , [ "module B where"
+        ]
+      ]
+
+    tgt <- guessTarget "A" Nothing
+    setTargets [tgt]
+    hsc_env <- getSession
+
+    liftIO $ do
+
+    _emss <- downsweep hsc_env [] [] False
+
+    flushFinderCaches hsc_env
+    createDirectoryIfMissing False "mydir"
+    renameFile "B.hs" "mydir/B.hs"
+
+    emss <- downsweep hsc_env [] [] False
+
+    -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with
+    -- (ms_location old_summary) like summariseFile used to instead of
+    -- using the 'location' parameter we'd end up using the old location of
+    -- the "B" module in this test. Make sure that doesn't happen.
+
+    hPrint stderr $ sort (map (ml_hs_file . ms_location) (rights emss))
+
+writeMod :: [String] -> IO ()
+writeMod src@(head -> stripPrefix "module " -> Just (takeWhile (/=' ') -> mod))
+  = writeFile (mod++".hs") $ unlines src
diff --git a/testsuite/tests/ghc-api/downsweep/OldModLocation.stderr b/testsuite/tests/ghc-api/downsweep/OldModLocation.stderr
new file mode 100644
index 0000000000..1bb974a936
--- /dev/null
+++ b/testsuite/tests/ghc-api/downsweep/OldModLocation.stderr
@@ -0,0 +1 @@
+[Just "A.hs",Just "mydir/B.hs"]
diff --git a/testsuite/tests/ghc-api/downsweep/all.T b/testsuite/tests/ghc-api/downsweep/all.T
index e20137dcf0..b3797113bc 100644
--- a/testsuite/tests/ghc-api/downsweep/all.T
+++ b/testsuite/tests/ghc-api/downsweep/all.T
@@ -4,3 +4,9 @@ test('PartialDownsweep',
      ],
      compile_and_run,
      ['-package ghc'])
+
+test('OldModLocation',
+     [ extra_run_opts('"' + config.libdir + '"')
+     ],
+     compile_and_run,
+     ['-package ghc'])