mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Avoid excessive retypechecking of TH codebases (#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 <moritz.kiefer@purelyfunctional.org> Co-authored-by: Moritz Kiefer <moritz.kiefer@purelyfunctional.org>
This commit is contained in:
parent
d999084820
commit
cdfc4b6e06
2
fmt.sh
2
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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
6
test/data/TH/THA.hs
Normal file
6
test/data/TH/THA.hs
Normal file
@ -0,0 +1,6 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module THA where
|
||||
import Language.Haskell.TH
|
||||
|
||||
th_a :: DecsQ
|
||||
th_a = [d| a = () |]
|
6
test/data/TH/THB.hs
Normal file
6
test/data/TH/THB.hs
Normal file
@ -0,0 +1,6 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module THB where
|
||||
import THA
|
||||
|
||||
$th_a
|
||||
|
5
test/data/TH/THC.hs
Normal file
5
test/data/TH/THC.hs
Normal file
@ -0,0 +1,5 @@
|
||||
module THC where
|
||||
import THB
|
||||
|
||||
c ::()
|
||||
c = a
|
1
test/data/TH/hie.yaml
Normal file
1
test/data/TH/hie.yaml
Normal file
@ -0,0 +1 @@
|
||||
cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}}
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user