Refactoring ModIfaceFromDisk

This started as a pure refactoring to clarify the responsibilities between
ModIface and ModIfaceFromDisk, but ended up having some behaviour changes:

1. Regenerate interface when checkOldIface returns something other than
UpToDate. This was a bug.

2. Do not generate a diagnostic when regenerating an interface.

2. Previously we conflated stale interface with other errors,
and would regenerate in both cases. Now we only regenerate in the first case.

src/Development/IDE/Core/Compile.hs

@@ -81,7 +81,6 @@ import qualified Data.Map.Strict                          as Map
 import           System.FilePath
 import           System.Directory
 import           System.IO.Extra
-import Data.Either.Extra (maybeToEither)
 import Control.DeepSeq (rnf)
 import Control.Exception (evaluate)
 import Exception (ExceptionMonad)
@@ -564,29 +563,29 @@ loadHieFile f = do
         let nameCache = initNameCache u []
         fmap (GHC.hie_file_result . fst) $ GHC.readHieFile nameCache f
 
--- | Retuns an up-to-date module interface if available.
+-- | Retuns an up-to-date module interface, regenerating if needed.
 --   Assumes file exists.
 --   Requires the 'HscEnv' to be set up with dependencies
 loadInterface
-  :: HscEnv
+  :: MonadIO m => HscEnv
   -> ModSummary
   -> [HiFileResult]
-  -> IO (Either String ModIface)
-loadInterface session ms deps = do
+  -> (m ([FileDiagnostic], Maybe HiFileResult))
+  -> m ([FileDiagnostic], Maybe HiFileResult)
+loadInterface session ms deps regen = do
   let hiFile = case ms_hsc_src ms of
                 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
                 _ -> ml_hi_file $ ms_location ms
-  r <- initIfaceLoad session $ readIface (ms_mod ms) hiFile
+  r <- liftIO $ initIfaceLoad session $ readIface (ms_mod ms) hiFile
   case r of
     Maybes.Succeeded iface -> do
-      session' <- foldM (\e d -> loadDepModuleIO (hirModIface d) Nothing e) session deps
-      (reason, iface') <- checkOldIface session' ms SourceUnmodified (Just iface)
-      return $ maybeToEither (showReason reason) iface'
+      session' <- foldM (\e d -> liftIO $ loadDepModuleIO (hirModIface d) Nothing e) session deps
+      res <- liftIO $ checkOldIface session' ms SourceUnmodified (Just iface)
+      case res of
+          (UpToDate, Just x) -> return ([], Just $ HiFileResult ms x)
+          _ -> regen
     Maybes.Failed err -> do
-      let errMsg = showSDoc (hsc_dflags session) err
-      return $ Left errMsg
-
-showReason :: RecompileRequired -> String
-showReason MustCompile = "Stale"
-showReason (RecompBecause reason) = "Stale (" ++ reason ++ ")"
-showReason UpToDate = "Up to date"
+      let errMsg = showSDoc dflags err
+          dflags = hsc_dflags session
+          diag = diagFromString "interface file loading" DsError (noSpan hiFile) errMsg
+      return (diag, Nothing)

src/Development/IDE/Core/Rules.hs

@@ -617,6 +617,7 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
   depHis  <- traverse (use GetModIface) (mapMaybe (fmap artifactFilePath . snd) deps)
 
   ms <- use_ GetModSummary f
+
   let hiFile = toNormalizedFilePath'
              $ case ms_hsc_src ms of
                 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
@@ -631,18 +632,21 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
             (Just hiVersion, ModificationTime{})
               | modificationTime hiVersion >= modificationTime modVersion -> do
                 session <- hscEnv <$> use_ GhcSession f
-                r <- liftIO $ loadInterface session ms deps
+                r <- loadInterface session ms deps (regenerateHiFile f)
                 case r of
-                  Right iface -> do
-                    let result = HiFileResult ms iface
-                    return (Just (fingerprintToBS (getModuleHash iface)), ([], Just result))
-                  Left err -> do
-                    let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err
-                    return (Nothing, (pure diag, Nothing))
+                  (diags, Just x) -> result diags x
+                  (diags, Nothing) -> return (Nothing, (diags, Nothing))
             (_, VFSVersion{}) ->
                 error "internal error - GetModIfaceFromDisk of file of interest"
-            _ ->
-              pure (Nothing, ([], Nothing))
+            _ -> do
+                -- the interface file does not exist or is out of date.
+                mbRes <- regenerateHiFile f
+                case mbRes of
+                    (diags, Just res) -> result diags res
+                    (diags, Nothing) -> return (Nothing, (diags, Nothing))
+    where
+        result diags x =
+            return (Just (fingerprintToBS (getModuleHash (hirModIface x))), (diags, Just x))
 
 getModSummaryRule :: Rules ()
 getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do
@@ -676,55 +680,52 @@ getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do
 getModIfaceRule :: Rules ()
 getModIfaceRule = define $ \GetModIface f -> do
     fileOfInterest <- use_ IsFileOfInterest f
-    let useHiFile =
-          -- Never load interface files for files of interest
-          not fileOfInterest
-    mbHiFile <- if useHiFile then use GetModIfaceFromDisk f else return Nothing
-    case mbHiFile of
-        Just x ->
-            return ([], Just x)
-        Nothing
-          | fileOfInterest -> do
-            -- For files of interest only, create a Shake dependency on typecheck
+    case fileOfInterest of
+        True -> do
+            -- Never load from disk for files of interest
             tmr <- use TypeCheck f
-            return ([], extract tmr)
-          | otherwise -> do
-            -- the interface file does not exist or is out of date.
-            -- Invoke typechecking directly to update it without incurring a dependency
-            -- on the parsed module and the typecheck rules
-            sess <- use_ GhcSession f
-            let hsc = hscEnv sess
-                -- After parsing the module remove all package imports referring to
-                -- these packages as we have already dealt with what they map to.
-                comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
-            opt <- getIdeOptions
-            (_, contents) <- getFileContents f
-            -- Embed --haddocks in the interface file
-            (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs f contents
-            (diags, mb_pm) <- case mb_pm of
-                Just _ -> return (diags, mb_pm)
-                Nothing -> do
-                    -- if parsing fails, try parsing again with Haddock turned off
-                    (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents
-                    return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm)
-            case mb_pm of
+            return ([], extractHiFileResult tmr)
+        False ->
+            ([],) <$> use GetModIfaceFromDisk f
+
+regenerateHiFile :: NormalizedFilePath -> Action ([FileDiagnostic], Maybe HiFileResult)
+regenerateHiFile f = do
+    -- Invoke typechecking directly to update it without incurring a dependency
+    -- on the parsed module and the typecheck rules
+    sess <- use_ GhcSession f
+    let hsc = hscEnv sess
+        -- After parsing the module remove all package imports referring to
+        -- these packages as we have already dealt with what they map to.
+        comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
+    opt <- getIdeOptions
+    (_, contents) <- getFileContents f
+    -- Embed --haddocks in the interface file
+    (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs f contents
+    (diags, mb_pm) <- case mb_pm of
+        Just _ -> return (diags, mb_pm)
+        Nothing -> do
+            -- if parsing fails, try parsing again with Haddock turned off
+            (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents
+            return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm)
+    case mb_pm of
+        Nothing -> return (diags, Nothing)
+        Just pm -> do
+            -- We want GhcSessionDeps cache objects only for files of interest
+            -- As that's no the case here, call the implementation directly
+            (diags, mb_hsc) <- ghcSessionDepsDefinition f
+            case mb_hsc of
                 Nothing -> return (diags, Nothing)
-                Just pm -> do
-                    -- We want GhcSessionDeps cache objects only for files of interest
-                    -- As that's no the case here, call the implementation directly
-                    (diags, mb_hsc) <- ghcSessionDepsDefinition f
-                    case mb_hsc of
-                        Nothing -> return (diags, Nothing)
-                        Just hsc -> do
-                            (diags', tmr) <- typeCheckRuleDefinition (hscEnv hsc) pm DoGenerateInterfaceFiles
-                            -- Bang pattern is important to avoid leaking 'tmr'
-                            let !res = extract tmr
-                            return (diags <> diags', res)
-    where
-      extract Nothing = Nothing
-      extract (Just tmr) =
-        -- Bang patterns are important to force the inner fields
-        Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr)
+                Just hsc -> do
+                    (diags', tmr) <- typeCheckRuleDefinition (hscEnv hsc) pm DoGenerateInterfaceFiles
+                    -- Bang pattern is important to avoid leaking 'tmr'
+                    let !res = extractHiFileResult tmr
+                    return (diags <> diags', res)
+
+extractHiFileResult :: Maybe TcModuleResult -> Maybe HiFileResult
+extractHiFileResult Nothing = Nothing
+extractHiFileResult (Just tmr) =
+    -- Bang patterns are important to force the inner fields
+    Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr)
 
 isFileOfInterestRule :: Rules ()
 isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do