Avoid excessive retypechecking of TH codebases (haskell/ghcide#673)

* Hi file stability * fix missing early cutoff in GetModIface * tests for TH reloading * Do not run hlint on test/data * hlints * Fix legacy code path * Update test/exe/Main.hs Co-authored-by: Moritz Kiefer <[email protected]> Co-authored-by: Moritz Kiefer <[email protected]>
pepeiborra · Jul 1, 2020 · e8d9cb2 · e8d9cb2
1 parent 5d832c1
commit e8d9cb2
Show file tree

Hide file tree

Showing 10 changed files with 149 additions and 30 deletions.
diff --git a/fmt.sh b/fmt.sh
@@ -1,3 +1,3 @@
 #!/usr/bin/env bash
 set -eou pipefail
-curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . --with-group=extra
+curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s src exe bench/exe test/exe --with-group=extra
diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs
@@ -587,9 +587,6 @@ loadInterface session ms sourceMod regen = do
             -- 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
+            | not (mi_used_th x) || SourceUnmodifiedAndStable == sourceMod
             -> return ([], Just $ HiFileResult ms x)
           (_reason, _) -> regen
-    where
-        -- TODO support stability
-        stable = False
diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs
@@ -14,19 +14,20 @@ module Development.IDE.Core.RuleTypes(
 import           Control.DeepSeq
 import Data.Binary
 import           Development.IDE.Import.DependencyInformation
+import Development.IDE.GHC.Compat
 import Development.IDE.GHC.Util
 import           Data.Hashable
 import           Data.Typeable
 import qualified Data.Set as S
 import           Development.Shake
 import           GHC.Generics                             (Generic)
 
-import           GHC
 import Module (InstalledUnitId)
-import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
+import HscTypes (hm_iface, CgGuts, Linkable, HomeModInfo, ModDetails)
 
 import           Development.IDE.Spans.Type
 import           Development.IDE.Import.FindImports (ArtifactsLocation)
+import Data.ByteString (ByteString)
 
 
 -- NOTATION
@@ -67,6 +68,15 @@ data HiFileResult = HiFileResult
     , hirModIface :: !ModIface
     }
 
+tmr_hiFileResult :: TcModuleResult -> HiFileResult
+tmr_hiFileResult tmr = HiFileResult modSummary modIface
+  where
+    modIface = hm_iface . tmrModInfo $ tmr
+    modSummary = tmrModSummary tmr
+
+hiFileFingerPrint :: HiFileResult -> ByteString
+hiFileFingerPrint = fingerprintToBS . getModuleHash . hirModIface
+
 instance NFData HiFileResult where
     rnf = rwhnf
 

diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs
@@ -644,23 +644,37 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
   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
-        let sourceModified = case mbHiVersion of
-                Nothing -> SourceModified
-                Just x -> if modificationTime x >= modificationTime modVersion
-                            then SourceUnmodified else SourceModified
+        sourceModified <- use_ IsHiFileStable f
         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))
+                let fp = Just (hiFileFingerPrint x)
+                return (fp, (diags <> diags_session, Just x))
             (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing))
 
+isHiFileStableRule :: Rules ()
+isHiFileStableRule = define $ \IsHiFileStable f -> do
+    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
+    mbHiVersion <- use  GetModificationTime_{missingFileDiagnostics=False} hiFile
+    modVersion  <- use_ GetModificationTime f
+    sourceModified <- case mbHiVersion of
+        Nothing -> pure SourceModified
+        Just x ->
+            if modificationTime x < modificationTime modVersion
+                then pure SourceModified
+                else do
+                    (fileImports, _) <- use_ GetLocatedImports f
+                    let imports = fmap artifactFilePath . snd <$> fileImports
+                    deps <- uses_ IsHiFileStable (catMaybes imports)
+                    pure $ if all (== SourceUnmodifiedAndStable) deps
+                        then SourceUnmodifiedAndStable
+                        else SourceUnmodified
+    return ([], Just sourceModified)
+
 getModSummaryRule :: Rules ()
 getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do
     dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
@@ -691,21 +705,25 @@ getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do
             in BS.pack (show fp)
 
 getModIfaceRule :: Rules ()
-getModIfaceRule = define $ \GetModIface f -> do
+getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do
 #if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
     fileOfInterest <- use_ IsFileOfInterest f
     if fileOfInterest
         then do
             -- Never load from disk for files of interest
             tmr <- use TypeCheck f
-            return ([], extractHiFileResult tmr)
-        else
-            ([],) <$> use GetModIfaceFromDisk f
+            let !hiFile = extractHiFileResult tmr
+            let fp = hiFileFingerPrint <$> hiFile
+            return (fp, ([], hiFile))
+        else do
+            hiFile <- use GetModIfaceFromDisk f
+            let fp = hiFileFingerPrint <$> hiFile
+            return (fp, ([], hiFile))
 #else
     tm <- use TypeCheck f
-    let modIface = hm_iface . tmrModInfo <$> tm
-        modSummary = tmrModSummary <$> tm
-    return ([], HiFileResult <$> modSummary <*> modIface)
+    let !hiFile = extractHiFileResult tm
+    let fp = hiFileFingerPrint <$> hiFile
+    return (fp, ([], tmr_hiFileResult <$> tm))
 #endif
 
 regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> Action ([FileDiagnostic], Maybe HiFileResult)
@@ -738,7 +756,7 @@ 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)
+    Just $! tmr_hiFileResult tmr
 
 isFileOfInterestRule :: Rules ()
 isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
@@ -763,3 +781,15 @@ mainRule = do
     getModIfaceRule
     isFileOfInterestRule
     getModSummaryRule
+    isHiFileStableRule
+
+-- | Given the path to a module src file, this rule returns True if the
+-- corresponding `.hi` file is stable, that is, if it is newer
+--   than the src file, and all its dependencies are stable too.
+data IsHiFileStable = IsHiFileStable
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable IsHiFileStable
+instance NFData   IsHiFileStable
+instance Binary   IsHiFileStable
+
+type instance RuleResult IsHiFileStable = SourceModified
diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs
@@ -70,3 +70,8 @@ instance Show HieFile where
 
 instance NFData HieFile where
     rnf = rwhnf
+
+deriving instance Eq SourceModified
+deriving instance Show SourceModified
+instance NFData SourceModified where
+    rnf = rwhnf
diff --git a/test/data/TH/THA.hs b/test/data/TH/THA.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module THA where
+import Language.Haskell.TH
+
+th_a :: DecsQ
+th_a = [d| a = () |]
diff --git a/test/data/TH/THB.hs b/test/data/TH/THB.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module THB where
+import THA
+
+$th_a
+
diff --git a/test/data/TH/THC.hs b/test/data/TH/THC.hs
@@ -0,0 +1,5 @@
+module THC where
+import THB
+
+c ::()
+c = a
diff --git a/test/data/TH/hie.yaml b/test/data/TH/hie.yaml
@@ -0,0 +1 @@
+cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}}
diff --git a/test/exe/Main.hs b/test/exe/Main.hs
@@ -56,7 +56,7 @@ main :: IO ()
 main = do
   -- We mess with env vars so run single-threaded.
   setEnv "TASTY_NUM_THREADS" "1" True
-  defaultMainWithRerun $ testGroup "HIE"
+  defaultMainWithRerun $ testGroup "ghcide"
     [ testSession "open close" $ do
         doc <- createDoc "Testing.hs" "haskell" ""
         void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
@@ -1864,8 +1864,43 @@ thTests =
         _ <- createDoc "A.hs" "haskell" sourceA
         _ <- createDoc "B.hs" "haskell" sourceB
         return ()
+    , thReloadingTest `xfail` "expect broken (#672)"
     ]
 
+-- | test that TH is reevaluated on typecheck
+thReloadingTest :: TestTree
+thReloadingTest = testCase "reloading-th-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \dir -> do
+    let aPath = dir </> "THA.hs"
+        bPath = dir </> "THB.hs"
+        cPath = dir </> "THC.hs"
+
+    aSource <- liftIO $ readFileUtf8 aPath --  th = [d|a :: ()|]
+    bSource <- liftIO $ readFileUtf8 bPath --  $th
+    cSource <- liftIO $ readFileUtf8 cPath --  c = a :: ()
+
+    adoc <- createDoc aPath "haskell" aSource
+    bdoc <- createDoc bPath "haskell" bSource
+    cdoc <- createDoc cPath "haskell" cSource
+
+    expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]
+
+    -- Change th from () to Bool
+    let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"]
+    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']
+    -- generate an artificial warning to avoid timing out if the TH change does not propagate
+    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"]
+
+    -- Check that the change propagates to C
+    expectDiagnostics
+        [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])
+        ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")])
+        ]
+
+    closeDoc adoc
+    closeDoc bdoc
+    closeDoc cdoc
+
+
 completionTests :: TestTree
 completionTests
   = testGroup "completion"
@@ -2389,8 +2424,32 @@ ifaceTests = testGroup "Interface loading tests"
       ifaceErrorTest
     , ifaceErrorTest2
     , ifaceErrorTest3
+    , ifaceTHTest
     ]
 
+-- | test that TH reevaluates across interfaces
+ifaceTHTest :: TestTree
+ifaceTHTest = testCase "iface-th-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \dir -> do
+    let aPath = dir </> "THA.hs"
+        bPath = dir </> "THB.hs"
+        cPath = dir </> "THC.hs"
+
+    aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: ()
+    _bSource <- liftIO $ readFileUtf8 bPath -- a :: ()
+    cSource <- liftIO $ readFileUtf8 cPath -- c = a :: ()
+
+    cdoc <- createDoc cPath "haskell" cSource
+
+    -- Change [TH]a from () to Bool
+    liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])
+
+    -- Check that the change propogates to C
+    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource]
+    expectDiagnostics
+      [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])
+      ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]
+    closeDoc cdoc
+
 ifaceErrorTest :: TestTree
 ifaceErrorTest = testCase "iface-error-test-1" $ withoutStackEnv $ runWithExtraFiles "recomp" $ \dir -> do
     let aPath = dir </> "A.hs"
@@ -2629,9 +2688,9 @@ runInDir dir s = do
     conf = defaultConfig
       -- If you uncomment this you can see all logging
       -- which can be quite useful for debugging.
-      -- { logStdErr = True, logColor = False }
+    --   { logStdErr = True, logColor = False }
       -- If you really want to, you can also see all messages
-      -- { logMessages = True, logColor = False }
+    --   { logMessages = True, logColor = False }
 
 openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
 openTestDataDoc path = do
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1 @@
		cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}}