Skip to content

Commit 229faac

Browse files
pepeiborrapepeiborra
authored
Generate linkables in the Eval plugin (#2295)
* [hls-graph] clean up databaseDirtySet When I ported https://github.com/ndmitchell/shake/pull/802/files to hls-graph, I changed the encoding of the dirty set. Instead, Dirty became a constructor in the Status union. But the databaseDirtySet stayed around accidentally, leading to some confusion. * extract GetEvalComments rule * override NeedsCompilation rule in eval plugin to generate linkables when Evaluating In addition, we tune the newness check of the redefined NeedsCompilation rule so that the generated linkables are not thrown away unnecessarily, as described in: ndmitchell/shake#794 * getLastBuildKeys * Test that the linkables are being produced * honor LSP_TEST_LOG_STDERR * add comments and use custom newness check in ghcide too * fix build * fix 9.0 build
1 parent 9233be8 commit 229faac

File tree

19 files changed

+428
-230
lines changed

19 files changed

+428
-230
lines changed

Diff for: ‎ghcide/src/Development/IDE/Core/RuleTypes.hs

+8
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+

Diff for: ‎ghcide/src/Development/IDE/Core/Rules.hs

+25-12
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

Diff for: ‎ghcide/src/Development/IDE/Core/Shake.hs

+17-7
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

Diff for: ‎ghcide/src/Development/IDE/Plugin/Test.hs

+8-3
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

Diff for: ‎ghcide/src/Development/IDE/Types/Diagnostics.hs

+5-1
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

Diff for: ‎ghcide/test/exe/Main.hs

+5-10
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" ]

Diff for: ‎ghcide/test/src/Development/IDE/Test.hs

+15-3
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)

Diff for: ‎haskell-language-server.cabal

+1-1
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

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

+11-1
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 ]

0 commit comments

Comments
 (0)