Interface file fixes (#645)

* Add test for inconsistent diagnostics

* 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.

Tentative fix for #597

* Split interface tests

* Always recompile modules with TH splices

Tentative fix for #614

TODO support stability

* Fix expectDiagnostics in MacOs

* Avoid File does not exist diagnostics for interface files

Fixes #642

* Clarify interface tests

* hlints

* Performance fixes

The previous changes were 10X slower, this is 20X faster than those, so 2X
faster than upstream, for some benchmarks

* formatting

* Fix GetModificationTime identity

The answer for a GetModification query is independent of the missingFileDiagnostics field
(as the diagnostics are not part of the answer)

* remove stale comment

* Avoid calling ghcSessionDepsDefinition twice

* Apply suggestions from code review

Co-authored-by: Moritz Kiefer <[email protected]>

* Code review feedback

* Address review feedback

https://github.com/digital-asset/ghcide/pull/645/files/49b0d9ac65399edf82a7a9cbbb8d8b5420458d8d#r443383239

* Change recomp to direct cradle

Co-authored-by: Zubin Duggal <[email protected]>
Co-authored-by: Moritz Kiefer <[email protected]>

Author: 3 people

src/Development/IDE/Core/Compile.hs

@@ -38,7 +38,6 @@ import Development.IDE.GHC.Util
 import qualified GHC.LanguageExtensions.Type as GHC
 import Development.IDE.Types.Options
 import Development.IDE.Types.Location
-import Outputable
 
 #if MIN_GHC_API_VERSION(8,6,0)
 import           DynamicLoading (initializePlugins)
@@ -59,8 +58,6 @@ import           GhcMonad
 import           GhcPlugins                     as GHC hiding (fst3, (<>))
 import qualified HeaderInfo                     as Hdr
 import           HscMain                        (hscInteractive, hscSimplify)
-import           LoadIface                      (readIface)
-import qualified Maybes
 import           MkIface
 import           NameCache
 import           StringBuffer                   as SB
@@ -81,7 +78,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 +560,36 @@ 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
-  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
-  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'
-    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"
+  -> SourceModified
+  -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface
+  -> m ([FileDiagnostic], Maybe HiFileResult)
+loadInterface session ms sourceMod regen = do
+    res <- liftIO $ checkOldIface session ms sourceMod Nothing
+    case res of
+          (UpToDate, Just x)
+            -- If the module used TH splices when it was last
+            -- compiled, then the recompilation check is not
+            -- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481)
+            -- and we must ignore
+            -- it.  However, if the module is stable (none of
+            -- the modules it depends on, directly or
+            -- indirectly, changed), then we *can* skip
+            -- recompilation. This is why the SourceModified
+            -- type contains SourceUnmodifiedAndStable, and
+            -- it's pretty important: otherwise ghc --make
+            -- would always recompile TH modules, even if
+            -- nothing at all has changed. Stability is just
+            -- the same check that make is doing for us in
+            -- one-shot mode.
+            | not (mi_used_th x) || stable
+            -> return ([], Just $ HiFileResult ms x)
+          (_reason, _) -> regen
+    where
+        -- TODO support stability
+        stable = False

src/Development/IDE/Core/FileStore.hs

@@ -94,7 +94,7 @@ instance Binary   GetFileContents
 
 getModificationTimeRule :: VFSHandle -> Rules ()
 getModificationTimeRule vfs =
-    defineEarlyCutoff $ \GetModificationTime file -> do
+    defineEarlyCutoff $ \(GetModificationTime_ missingFileDiags) file -> do
         let file' = fromNormalizedFilePath file
         let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))
         alwaysRerun
@@ -106,7 +106,10 @@ getModificationTimeRule vfs =
               `catch` \(e :: IOException) -> do
                 let err | isDoesNotExistError e = "File does not exist: " ++ file'
                         | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
-                return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
+                    diag = ideErrorText file (T.pack err)
+                if isDoesNotExistError e && not missingFileDiags
+                    then return (Nothing, ([], Nothing))
+                    else return (Nothing, ([diag], Nothing))
   where
     -- Dir.getModificationTime is surprisingly slow since it performs
     -- a ton of conversions. Since we do not actually care about

src/Development/IDE/Core/Rules.hs

@@ -622,37 +622,27 @@ ghcSessionDepsDefinition file = do
 
 getModIfaceFromDiskRule :: Rules ()
 getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
-  -- get all dependencies interface files, to check for freshness
-  (deps,_) <- use_ GetLocatedImports f
-  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)
-                _ -> ml_hi_file $ ms_location ms
-
-  case sequence depHis of
-    Nothing -> pure (Nothing, ([], Nothing))
-    Just deps -> do
-        mbHiVersion <- use  GetModificationTime hiFile
+  (diags_session, mb_session) <- ghcSessionDepsDefinition f
+  case mb_session of
+      Nothing -> return (Nothing, (diags_session, Nothing))
+      Just session -> do
+        let hiFile = toNormalizedFilePath'
+                    $ case ms_hsc_src ms of
+                        HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
+                        _ -> ml_hi_file $ ms_location ms
+        mbHiVersion <- use  GetModificationTime_{missingFileDiagnostics=False} hiFile
         modVersion  <- use_ GetModificationTime f
-        case (mbHiVersion, modVersion) of
-            (Just hiVersion, ModificationTime{})
-              | modificationTime hiVersion >= modificationTime modVersion -> do
-                session <- hscEnv <$> use_ GhcSession f
-                r <- liftIO $ loadInterface session ms deps
-                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))
-            (_, VFSVersion{}) ->
-                error "internal error - GetModIfaceFromDisk of file of interest"
-            _ ->
-              pure (Nothing, ([], Nothing))
+        let sourceModified = case mbHiVersion of
+                Nothing -> SourceModified
+                Just x -> if modificationTime x >= modificationTime modVersion
+                            then SourceUnmodified else SourceModified
+        r <- loadInterface (hscEnv session) ms sourceModified (regenerateHiFile session f)
+        case r of
+            (diags, Just x) -> do
+                let fp = fingerprintToBS (getModuleHash (hirModIface x))
+                return (Just fp, (diags <> diags_session, Just x))
+            (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing))
 
 getModSummaryRule :: Rules ()
 getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do
@@ -687,62 +677,51 @@ getModIfaceRule :: Rules ()
 getModIfaceRule = define $ \GetModIface f -> do
 #if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
     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
+    if fileOfInterest
+        then 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
-                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)
+            return ([], extractHiFileResult tmr)
+        else
+            ([],) <$> use GetModIfaceFromDisk f
 #else
     tm <- use TypeCheck f
     let modIface = hm_iface . tmrModInfo <$> tm
         modSummary = tmrModSummary <$> tm
     return ([], HiFileResult <$> modSummary <*> modIface)
 #endif
 
+regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> Action ([FileDiagnostic], Maybe HiFileResult)
+regenerateHiFile sess f = do
+    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
+            -- Invoke typechecking directly to update it without incurring a dependency
+            -- on the parsed module and the typecheck rules
+            (diags', tmr) <- typeCheckRuleDefinition 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

src/Development/IDE/Core/Shake.hs

@@ -1,11 +1,12 @@
-{-# LANGUAGE RecursiveDo #-}
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE ConstraintKinds            #-}
+{-# LANGUAGE PatternSynonyms            #-}
 
 -- | A Shake implementation of the compiler service.
 --
@@ -23,7 +24,8 @@
 module Development.IDE.Core.Shake(
     IdeState, shakeExtras,
     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
-    IdeRule, IdeResult, GetModificationTime(..),
+    IdeRule, IdeResult,
+    GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
     shakeOpen, shakeShut,
     shakeRestart,
     shakeEnqueue,
@@ -903,12 +905,29 @@ actionLogger = do
     return logger
 
 
-data GetModificationTime = GetModificationTime
-    deriving (Eq, Show, Generic)
-instance Hashable GetModificationTime
+-- The Shake key type for getModificationTime queries
+data GetModificationTime = GetModificationTime_
+    { missingFileDiagnostics :: Bool
+      -- ^ If false, missing file diagnostics are not reported
+    }
+    deriving (Show, Generic)
+
+instance Eq GetModificationTime where
+    -- Since the diagnostics are not part of the answer, the query identity is
+    -- independent from the 'missingFileDiagnostics' field
+    _ == _ = True
+
+instance Hashable GetModificationTime where
+    -- Since the diagnostics are not part of the answer, the query identity is
+    -- independent from the 'missingFileDiagnostics' field
+    hashWithSalt salt _ = salt
+
 instance NFData   GetModificationTime
 instance Binary   GetModificationTime
 
+pattern GetModificationTime :: GetModificationTime
+pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}
+
 -- | Get the modification time of a file.
 type instance RuleResult GetModificationTime = FileVersion
 

test/data/recomp/A.hs

@@ -0,0 +1,6 @@
+module A(x) where
+
+import B
+
+x :: Int
+x = y

test/data/recomp/B.hs

@@ -0,0 +1,4 @@
+module B(y) where
+
+y :: Int
+y = undefined

test/data/recomp/P.hs

@@ -0,0 +1,5 @@
+module P() where
+import A
+import B
+
+bar = x :: Int

test/data/recomp/hie.yaml

@@ -0,0 +1 @@
+cradle: {direct: {arguments: ["-Wmissing-signatures","B", "A", "P"]}}