Skip to content

Commit 0395e03

Browse files
pepeiborrapepeiborra
authored
Merge branch 'master' into cleanup-dirtyset
2 parents 9961e4e + 229faac commit 0395e03

File tree

17 files changed

+388
-199
lines changed

17 files changed

+388
-199
lines changed

‎ghcide/src/Development/IDE/Core/RuleTypes.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,14 @@ data LinkableType = ObjectLinkable | BCOLinkable
4949
instance Hashable LinkableType
5050
instance NFData LinkableType
5151

52+
-- | Encode the linkable into an ordered bytestring.
53+
-- This is used to drive an ordered "newness" predicate in the
54+
-- 'NeedsCompilation' build rule.
55+
encodeLinkableType :: Maybe LinkableType -> ByteString
56+
encodeLinkableType Nothing = "0"
57+
encodeLinkableType (Just BCOLinkable) = "1"
58+
encodeLinkableType (Just ObjectLinkable) = "2"
59+
5260
-- NOTATION
5361
-- Foo+ means Foo for the dependencies
5462
-- Foo* means Foo for me and Foo+

‎ghcide/src/Development/IDE/Core/Rules.hs

Lines changed: 25 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -50,6 +50,7 @@ module Development.IDE.Core.Rules(
5050
getHieAstsRule,
5151
getBindingsRule,
5252
needsCompilationRule,
53+
computeLinkableTypeForDynFlags,
5354
generateCoreRule,
5455
getImportMapRule,
5556
regenerateHiFile,
@@ -987,8 +988,9 @@ usePropertyAction kn plId p = do
987988
getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
988989
getLinkableType f = use_ NeedsCompilation f
989990

990-
needsCompilationRule :: Rules ()
991-
needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file -> do
991+
-- needsCompilationRule :: Rules ()
992+
needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))
993+
needsCompilationRule file = do
992994
graph <- useNoFile GetModuleGraph
993995
res <- case graph of
994996
-- Treat as False if some reverse dependency header fails to parse
@@ -1012,30 +1014,34 @@ needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation
10121014
(uses NeedsCompilation revdeps)
10131015
pure $ computeLinkableType ms modsums (map join needsComps)
10141016

1015-
pure (Just $ LBS.toStrict $ B.encode $ hash res, Just res)
1017+
pure (Just $ encodeLinkableType res, Just res)
10161018
where
10171019
uses_th_qq (ms_hspp_opts -> dflags) =
10181020
xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
10191021

1020-
unboxed_tuples_or_sums (ms_hspp_opts -> d) =
1021-
xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
1022-
10231022
computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType
10241023
computeLinkableType this deps xs
10251024
| Just ObjectLinkable `elem` xs = Just ObjectLinkable -- If any dependent needs object code, so do we
10261025
| Just BCOLinkable `elem` xs = Just this_type -- If any dependent needs bytecode, then we need to be compiled
10271026
| any (maybe False uses_th_qq) deps = Just this_type -- If any dependent needs TH, then we need to be compiled
10281027
| otherwise = Nothing -- If none of these conditions are satisfied, we don't need to compile
10291028
where
1030-
-- How should we compile this module? (assuming we do in fact need to compile it)
1031-
-- Depends on whether it uses unboxed tuples or sums
1032-
this_type
1029+
this_type = computeLinkableTypeForDynFlags (ms_hspp_opts this)
1030+
1031+
-- | How should we compile this module?
1032+
-- (assuming we do in fact need to compile it).
1033+
-- Depends on whether it uses unboxed tuples or sums
1034+
computeLinkableTypeForDynFlags :: DynFlags -> LinkableType
1035+
computeLinkableTypeForDynFlags d
10331036
#if defined(GHC_PATCHED_UNBOXED_BYTECODE)
10341037
= BCOLinkable
10351038
#else
1036-
| unboxed_tuples_or_sums this = ObjectLinkable
1037-
| otherwise = BCOLinkable
1039+
| unboxed_tuples_or_sums = ObjectLinkable
1040+
| otherwise = BCOLinkable
10381041
#endif
1042+
where
1043+
unboxed_tuples_or_sums =
1044+
xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
10391045

10401046
-- | Tracks which linkables are current, so we don't need to unload them
10411047
newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) }
@@ -1074,7 +1080,14 @@ mainRule = do
10741080
getClientSettingsRule
10751081
getHieAstsRule
10761082
getBindingsRule
1077-
needsCompilationRule
1083+
-- This rule uses a custom newness check that relies on the encoding
1084+
-- produced by 'encodeLinkable'. This works as follows:
1085+
-- * <previous> -> <new>
1086+
-- * ObjectLinkable -> BCOLinkable : the prev linkable can be reused, signal "no change"
1087+
-- * Object/BCO -> NoLinkable : the prev linkable can be ignored, signal "no change"
1088+
-- * otherwise : the prev linkable cannot be reused, signal "value has changed"
1089+
defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file ->
1090+
needsCompilationRule file
10781091
generateCoreRule
10791092
getImportMapRule
10801093
getAnnotatedParsedSourceRule

‎ghcide/src/Development/IDE/Core/Shake.hs

Lines changed: 17 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,7 @@
2424
-- always stored as real Haskell values, whereas Shake serialises all 'A' values
2525
-- between runs. To deserialise a Shake value, we just consult Values.
2626
module Development.IDE.Core.Shake(
27-
IdeState, shakeSessionInit, shakeExtras,
27+
IdeState, shakeSessionInit, shakeExtras, shakeDb,
2828
ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
2929
KnownTargets, Target(..), toKnownFiles,
3030
IdeRule, IdeResult,
@@ -871,17 +871,25 @@ usesWithStale key files = do
871871
data RuleBody k v
872872
= Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
873873
| RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v))
874-
874+
| RuleWithCustomNewnessCheck
875+
{ newnessCheck :: BS.ByteString -> BS.ByteString -> Bool
876+
, build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)
877+
}
875878

876879
-- | Define a new Rule with early cutoff
877880
defineEarlyCutoff
878881
:: IdeRule k v
879882
=> RuleBody k v
880883
-> Rules ()
881884
defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ do
882-
defineEarlyCutoff' True key file old mode $ op key file
885+
defineEarlyCutoff' True (==) key file old mode $ op key file
883886
defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ do
884-
defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file
887+
defineEarlyCutoff' False (==) key file old mode $ second (mempty,) <$> op key file
888+
defineEarlyCutoff RuleWithCustomNewnessCheck{..} =
889+
addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode ->
890+
otTracedAction key file mode traceA $
891+
defineEarlyCutoff' False newnessCheck key file old mode $
892+
second (mempty,) <$> build key file
885893

886894
defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
887895
defineNoFile f = defineNoDiagnostics $ \k file -> do
@@ -896,13 +904,15 @@ defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> d
896904
defineEarlyCutoff'
897905
:: IdeRule k v
898906
=> Bool -- ^ update diagnostics
907+
-- | compare current and previous for freshness
908+
-> (BS.ByteString -> BS.ByteString -> Bool)
899909
-> k
900910
-> NormalizedFilePath
901911
-> Maybe BS.ByteString
902912
-> RunMode
903913
-> Action (Maybe BS.ByteString, IdeResult v)
904914
-> Action (RunResult (A (RuleResult k)))
905-
defineEarlyCutoff' doDiagnostics key file old mode action = do
915+
defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
906916
extras@ShakeExtras{state, progress, logger, dirtyKeys} <- getShakeExtras
907917
options <- getIdeOptions
908918
(if optSkipProgress options key then id else inProgress progress file) $ do
@@ -947,8 +957,8 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do
947957
then updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
948958
else forM_ diags $ \d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]
949959
let eq = case (bs, fmap decodeShakeValue old) of
950-
(ShakeResult a, Just (ShakeResult b)) -> a == b
951-
(ShakeStale a, Just (ShakeStale b)) -> a == b
960+
(ShakeResult a, Just (ShakeResult b)) -> cmp a b
961+
(ShakeStale a, Just (ShakeStale b)) -> cmp a b
952962
-- If we do not have a previous result
953963
-- or we got ShakeNoCutoff we always return False.
954964
_ -> False

‎ghcide/src/Development/IDE/Plugin/Test.hs

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ import Development.IDE.Core.Service
2727
import Development.IDE.Core.Shake
2828
import Development.IDE.GHC.Compat
2929
import Development.IDE.Graph (Action)
30+
import Development.IDE.Graph.Database (shakeLastBuildKeys)
3031
import Development.IDE.Types.Action
3132
import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
3233
import Development.IDE.Types.Location (fromUri)
@@ -38,10 +39,11 @@ import System.Time.Extra
3839

3940
data TestRequest
4041
= BlockSeconds Seconds -- ^ :: Null
41-
| GetInterfaceFilesDir FilePath -- ^ :: String
42+
| GetInterfaceFilesDir Uri -- ^ :: String
4243
| GetShakeSessionQueueCount -- ^ :: Number
4344
| WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
4445
| WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult
46+
| GetLastBuildKeys -- ^ :: [String]
4547
deriving Generic
4648
deriving anyclass (FromJSON, ToJSON)
4749

@@ -70,8 +72,8 @@ testRequestHandler _ (BlockSeconds secs) = do
7072
toJSON secs
7173
liftIO $ sleep secs
7274
return (Right Null)
73-
testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do
74-
let nfp = toNormalizedFilePath fp
75+
testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do
76+
let nfp = fromUri $ toNormalizedUri file
7577
sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp
7678
let hiPath = hiDir $ hsc_dflags $ hscEnv sess
7779
return $ Right (toJSON hiPath)
@@ -88,6 +90,9 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do
8890
success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp
8991
let res = WaitForIdeRuleResult <$> success
9092
return $ bimap mkResponseError toJSON res
93+
testRequestHandler s GetLastBuildKeys = liftIO $ do
94+
keys <- shakeLastBuildKeys $ shakeDb s
95+
return $ Right $ toJSON $ map show keys
9196

9297
mkResponseError :: Text -> ResponseError
9398
mkResponseError msg = ResponseError InvalidRequest msg Nothing

‎ghcide/src/Development/IDE/Types/Diagnostics.hs

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ module Development.IDE.Types.Diagnostics (
1414
ideErrorWithSource,
1515
showDiagnostics,
1616
showDiagnosticsColored,
17-
) where
17+
IdeResultNoDiagnosticsEarlyCutoff) where
1818

1919
import Control.DeepSeq
2020
import Data.Maybe as Maybe
@@ -29,6 +29,7 @@ import Language.LSP.Types as LSP (Diagnostic (.
2929
DiagnosticSource,
3030
List (..))
3131

32+
import Data.ByteString (ByteString)
3233
import Development.IDE.Types.Location
3334

3435

@@ -44,6 +45,9 @@ import Development.IDE.Types.Location
4445
-- not propagate diagnostic errors through multiple phases.
4546
type IdeResult v = ([FileDiagnostic], Maybe v)
4647

48+
-- | an IdeResult with a fingerprint
49+
type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v)
50+
4751
ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
4852
ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)
4953

‎ghcide/test/exe/Main.hs

Lines changed: 5 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,7 @@ import Development.IDE.Test (Cursor,
5050
expectNoMoreDiagnostics,
5151
flushMessages,
5252
standardizeQuotes,
53-
waitForAction)
53+
waitForAction, getInterfaceFilesDir)
5454
import Development.IDE.Test.Runfiles
5555
import qualified Development.IDE.Types.Diagnostics as Diagnostics
5656
import Development.IDE.Types.Location
@@ -95,7 +95,7 @@ import Data.Tuple.Extra
9595
import Development.IDE.Core.FileStore (getModTime)
9696
import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports)
9797
import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
98-
import Development.IDE.Plugin.Test (TestRequest (BlockSeconds, GetInterfaceFilesDir),
98+
import Development.IDE.Plugin.Test (TestRequest (BlockSeconds),
9999
WaitForIdeRuleResult (..),
100100
blockCommandId)
101101
import Ide.PluginUtils (pluginDescToIdePlugins)
@@ -5249,14 +5249,9 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d
52495249

52505250

52515251
-- Check that we wrote the interfaces for B when we saved
5252-
let m = SCustomMethod "test"
5253-
lid <- sendRequest m $ toJSON $ GetInterfaceFilesDir bPath
5254-
res <- skipManyTill anyMessage $ responseForId m lid
5255-
liftIO $ case res of
5256-
ResponseMessage{_result=Right (A.fromJSON -> A.Success hidir)} -> do
5257-
hi_exists <- doesFileExist $ hidir </> "B.hi"
5258-
assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists
5259-
_ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res
5252+
Right hidir <- getInterfaceFilesDir bdoc
5253+
hi_exists <- liftIO $ doesFileExist $ hidir </> "B.hi"
5254+
liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists
52605255

52615256
pdoc <- createDoc pPath "haskell" pSource
52625257
changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]

‎ghcide/test/src/Development/IDE/Test.hs

Lines changed: 15 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,8 @@ module Development.IDE.Test
2020
, standardizeQuotes
2121
, flushMessages
2222
, waitForAction
23+
, getLastBuildKeys
24+
, getInterfaceFilesDir
2325
) where
2426

2527
import Control.Applicative.Combinators
@@ -169,13 +171,23 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
169171
diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
170172
diagnostic = LspTest.message STextDocumentPublishDiagnostics
171173

172-
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
173-
waitForAction key TextDocumentIdentifier{_uri} = do
174+
callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
175+
callTestPlugin cmd = do
174176
let cm = SCustomMethod "test"
175-
waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri)
177+
waitId <- sendRequest cm (A.toJSON cmd)
176178
ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
177179
return $ do
178180
e <- _result
179181
case A.fromJSON e of
180182
A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing
181183
A.Success a -> pure a
184+
185+
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
186+
waitForAction key TextDocumentIdentifier{_uri} =
187+
callTestPlugin (WaitForIdeRule key _uri)
188+
189+
getLastBuildKeys :: Session (Either ResponseError [T.Text])
190+
getLastBuildKeys = callTestPlugin GetLastBuildKeys
191+
192+
getInterfaceFilesDir :: TextDocumentIdentifier -> Session (Either ResponseError FilePath)
193+
getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)

‎haskell-language-server.cabal

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -212,7 +212,7 @@ common haddockComments
212212

213213
common eval
214214
if flag(eval) || flag(all-plugins)
215-
build-depends: hls-eval-plugin ^>=1.1.0.0
215+
build-depends: hls-eval-plugin ^>=1.2.0.0
216216
cpp-options: -Deval
217217

218218
common importLens

‎hls-graph/src/Development/IDE/Graph/Database.hs

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,13 +8,16 @@ module Development.IDE.Graph.Database(
88
shakeRunDatabase,
99
shakeRunDatabaseForKeys,
1010
shakeProfileDatabase,
11+
shakeLastBuildKeys
1112
) where
1213

1314
import Data.Dynamic
15+
import Data.IORef
1416
import Data.Maybe
15-
import Development.IDE.Graph.Classes ()
17+
import Development.IDE.Graph.Classes ()
1618
import Development.IDE.Graph.Internal.Action
1719
import Development.IDE.Graph.Internal.Database
20+
import qualified Development.IDE.Graph.Internal.Ids as Ids
1821
import Development.IDE.Graph.Internal.Options
1922
import Development.IDE.Graph.Internal.Profile (writeProfile)
2023
import Development.IDE.Graph.Internal.Rules
@@ -56,3 +59,10 @@ shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
5659
-- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run.
5760
shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
5861
shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s
62+
63+
-- | Returns the set of keys built in the most recent step
64+
shakeLastBuildKeys :: ShakeDatabase -> IO [Key]
65+
shakeLastBuildKeys (ShakeDatabase _ _ db) = do
66+
keys <- Ids.elems $ databaseValues db
67+
step <- readIORef $ databaseStep db
68+
return [ k | (k, Clean res) <- keys, resultBuilt res == step ]

‎hls-graph/src/Development/IDE/Graph/Internal/Database.hs

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -168,9 +168,9 @@ compute db@Database{..} key id mode result = do
168168
actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
169169
previousDeps= maybe UnknownDeps resultDeps result
170170
let res = Result runValue built' changed built actualDeps execution runStore
171-
case actualDeps of
172-
ResultDeps deps | not(null deps) &&
173-
runChanged /= ChangedNothing
171+
case getResultDepsDefault [] actualDeps of
172+
deps | not(null deps)
173+
&& runChanged /= ChangedNothing
174174
-> do
175175
void $ forkIO $
176176
updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps)
@@ -284,7 +284,7 @@ mapConcurrentlyAIO_ f [one] = liftIO $ justWait $ fmap f one
284284
mapConcurrentlyAIO_ f many = do
285285
ref <- AIO ask
286286
waits <- liftIO $ uninterruptibleMask $ \restore -> do
287-
waits <- liftIO $ traverse waitOrSpawn (map (fmap (restore . f)) many)
287+
waits <- liftIO $ traverse (waitOrSpawn . fmap (restore . f)) many
288288
let asyncs = rights waits
289289
liftIO $ atomicModifyIORef'_ ref (asyncs ++)
290290
return waits

0 commit comments

Comments
 (0)