diff --git a/ghcide/fmt.sh b/ghcide/fmt.sh index 8a18bba1d4..ef0cba9bc2 100755 --- a/ghcide/fmt.sh +++ b/ghcide/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/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 82bc042d28..1856fdd171 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/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/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 70ff1847c9..5c04df4d40 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -14,6 +14,7 @@ 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 @@ -21,12 +22,12 @@ 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/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index e1e6bd8403..2c66256ea0 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/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/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 643c76e36b..10813e8046 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/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/ghcide/test/data/TH/THA.hs b/ghcide/test/data/TH/THA.hs new file mode 100644 index 0000000000..ec6cf8ef39 --- /dev/null +++ b/ghcide/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/ghcide/test/data/TH/THB.hs b/ghcide/test/data/TH/THB.hs new file mode 100644 index 0000000000..2519ad8d6e --- /dev/null +++ b/ghcide/test/data/TH/THB.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module THB where +import THA + +$th_a + diff --git a/ghcide/test/data/TH/THC.hs b/ghcide/test/data/TH/THC.hs new file mode 100644 index 0000000000..79a02ef601 --- /dev/null +++ b/ghcide/test/data/TH/THC.hs @@ -0,0 +1,5 @@ +module THC where +import THB + +c ::() +c = a diff --git a/ghcide/test/data/TH/hie.yaml b/ghcide/test/data/TH/hie.yaml new file mode 100644 index 0000000000..a65c7b79c4 --- /dev/null +++ b/ghcide/test/data/TH/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}} diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index addd68100c..e27962e669 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/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