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

Author: pepeiborra

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

@@ -49,6 +49,14 @@ data LinkableType = ObjectLinkable | BCOLinkable
 instance Hashable LinkableType
 instance NFData   LinkableType
 
+-- | Encode the linkable into an ordered bytestring.
+--   This is used to drive an ordered "newness" predicate in the
+--   'NeedsCompilation' build rule.
+encodeLinkableType :: Maybe LinkableType -> ByteString
+encodeLinkableType Nothing               = "0"
+encodeLinkableType (Just BCOLinkable)    = "1"
+encodeLinkableType (Just ObjectLinkable) = "2"
+
 -- NOTATION
 --   Foo+ means Foo for the dependencies
 --   Foo* means Foo for me and Foo+

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

@@ -50,6 +50,7 @@ module Development.IDE.Core.Rules(
     getHieAstsRule,
     getBindingsRule,
     needsCompilationRule,
+    computeLinkableTypeForDynFlags,
     generateCoreRule,
     getImportMapRule,
     regenerateHiFile,
@@ -987,8 +988,9 @@ usePropertyAction kn plId p = do
 getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
 getLinkableType f = use_ NeedsCompilation f
 
-needsCompilationRule :: Rules ()
-needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file -> do
+-- needsCompilationRule :: Rules ()
+needsCompilationRule :: NormalizedFilePath  -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))
+needsCompilationRule file = do
   graph <- useNoFile GetModuleGraph
   res <- case graph of
     -- Treat as False if some reverse dependency header fails to parse
@@ -1012,30 +1014,34 @@ needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation
                 (uses NeedsCompilation revdeps)
         pure $ computeLinkableType ms modsums (map join needsComps)
 
-  pure (Just $ LBS.toStrict $ B.encode $ hash res, Just res)
+  pure (Just $ encodeLinkableType res, Just res)
   where
     uses_th_qq (ms_hspp_opts -> dflags) =
       xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
 
-    unboxed_tuples_or_sums (ms_hspp_opts -> d) =
-      xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
-
     computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType
     computeLinkableType this deps xs
       | Just ObjectLinkable `elem` xs     = Just ObjectLinkable -- If any dependent needs object code, so do we
       | Just BCOLinkable    `elem` xs     = Just this_type      -- If any dependent needs bytecode, then we need to be compiled
       | any (maybe False uses_th_qq) deps = Just this_type      -- If any dependent needs TH, then we need to be compiled
       | otherwise                         = Nothing             -- If none of these conditions are satisfied, we don't need to compile
       where
-        -- How should we compile this module? (assuming we do in fact need to compile it)
-        -- Depends on whether it uses unboxed tuples or sums
-        this_type
+        this_type = computeLinkableTypeForDynFlags (ms_hspp_opts this)
+
+-- | How should we compile this module?
+-- (assuming we do in fact need to compile it).
+-- Depends on whether it uses unboxed tuples or sums
+computeLinkableTypeForDynFlags :: DynFlags -> LinkableType
+computeLinkableTypeForDynFlags d
 #if defined(GHC_PATCHED_UNBOXED_BYTECODE)
           = BCOLinkable
 #else
-          | unboxed_tuples_or_sums this = ObjectLinkable
-          | otherwise                   = BCOLinkable
+          | unboxed_tuples_or_sums = ObjectLinkable
+          | otherwise              = BCOLinkable
 #endif
+  where
+        unboxed_tuples_or_sums =
+            xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
 
 -- | Tracks which linkables are current, so we don't need to unload them
 newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) }
@@ -1074,7 +1080,14 @@ mainRule = do
     getClientSettingsRule
     getHieAstsRule
     getBindingsRule
-    needsCompilationRule
+    -- This rule uses a custom newness check that relies on the encoding
+    --  produced by 'encodeLinkable'. This works as follows:
+    --   * <previous> -> <new>
+    --   * ObjectLinkable -> BCOLinkable : the prev linkable can be reused,  signal "no change"
+    --   * Object/BCO -> NoLinkable      : the prev linkable can be ignored, signal "no change"
+    --   * otherwise                     : the prev linkable cannot be reused, signal "value has changed"
+    defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file ->
+        needsCompilationRule file
     generateCoreRule
     getImportMapRule
     getAnnotatedParsedSourceRule

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

@@ -24,7 +24,7 @@
 --   always stored as real Haskell values, whereas Shake serialises all 'A' values
 --   between runs. To deserialise a Shake value, we just consult Values.
 module Development.IDE.Core.Shake(
-    IdeState, shakeSessionInit, shakeExtras,
+    IdeState, shakeSessionInit, shakeExtras, shakeDb,
     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
     KnownTargets, Target(..), toKnownFiles,
     IdeRule, IdeResult,
@@ -871,17 +871,25 @@ usesWithStale key files = do
 data RuleBody k v
   = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
   | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v))
-
+  | RuleWithCustomNewnessCheck
+    { newnessCheck :: BS.ByteString -> BS.ByteString -> Bool
+    , build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)
+    }
 
 -- | Define a new Rule with early cutoff
 defineEarlyCutoff
     :: IdeRule k v
     => RuleBody k v
     -> Rules ()
 defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ do
-    defineEarlyCutoff' True key file old mode $ op key file
+    defineEarlyCutoff' True (==) key file old mode $ op key file
 defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ do
-    defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file
+    defineEarlyCutoff' False (==) key file old mode $ second (mempty,) <$> op key file
+defineEarlyCutoff RuleWithCustomNewnessCheck{..} =
+    addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode ->
+        otTracedAction key file mode traceA $
+            defineEarlyCutoff' False newnessCheck key file old mode $
+                second (mempty,) <$> build key file
 
 defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
 defineNoFile f = defineNoDiagnostics $ \k file -> do
@@ -896,13 +904,15 @@ defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> d
 defineEarlyCutoff'
     :: IdeRule k v
     => Bool  -- ^ update diagnostics
+    -- | compare current and previous for freshness
+    -> (BS.ByteString -> BS.ByteString -> Bool)
     -> k
     -> NormalizedFilePath
     -> Maybe BS.ByteString
     -> RunMode
     -> Action (Maybe BS.ByteString, IdeResult v)
     -> Action (RunResult (A (RuleResult k)))
-defineEarlyCutoff' doDiagnostics key file old mode action = do
+defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
     extras@ShakeExtras{state, progress, logger, dirtyKeys} <- getShakeExtras
     options <- getIdeOptions
     (if optSkipProgress options key then id else inProgress progress file) $ do
@@ -947,8 +957,8 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do
                     then updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
                     else forM_ diags $ \d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]
                 let eq = case (bs, fmap decodeShakeValue old) of
-                        (ShakeResult a, Just (ShakeResult b)) -> a == b
-                        (ShakeStale a, Just (ShakeStale b))   -> a == b
+                        (ShakeResult a, Just (ShakeResult b)) -> cmp a b
+                        (ShakeStale a, Just (ShakeStale b))   -> cmp a b
                         -- If we do not have a previous result
                         -- or we got ShakeNoCutoff we always return False.
                         _                                     -> False

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

@@ -27,6 +27,7 @@ import           Development.IDE.Core.Service
 import           Development.IDE.Core.Shake
 import           Development.IDE.GHC.Compat
 import           Development.IDE.Graph          (Action)
+import           Development.IDE.Graph.Database (shakeLastBuildKeys)
 import           Development.IDE.Types.Action
 import           Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
 import           Development.IDE.Types.Location (fromUri)
@@ -38,10 +39,11 @@ import           System.Time.Extra
 
 data TestRequest
     = BlockSeconds Seconds           -- ^ :: Null
-    | GetInterfaceFilesDir FilePath  -- ^ :: String
+    | GetInterfaceFilesDir Uri       -- ^ :: String
     | GetShakeSessionQueueCount      -- ^ :: Number
     | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
     | WaitForIdeRule String Uri      -- ^ :: WaitForIdeRuleResult
+    | GetLastBuildKeys               -- ^ :: [String]
     deriving Generic
     deriving anyclass (FromJSON, ToJSON)
 
@@ -70,8 +72,8 @@ testRequestHandler _ (BlockSeconds secs) = do
       toJSON secs
     liftIO $ sleep secs
     return (Right Null)
-testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do
-    let nfp = toNormalizedFilePath fp
+testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do
+    let nfp = fromUri $ toNormalizedUri file
     sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp
     let hiPath = hiDir $ hsc_dflags $ hscEnv sess
     return $ Right (toJSON hiPath)
@@ -88,6 +90,9 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do
     success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp
     let res = WaitForIdeRuleResult <$> success
     return $ bimap mkResponseError toJSON res
+testRequestHandler s GetLastBuildKeys = liftIO $ do
+    keys <- shakeLastBuildKeys $ shakeDb s
+    return $ Right $ toJSON $ map show keys
 
 mkResponseError :: Text -> ResponseError
 mkResponseError msg = ResponseError InvalidRequest msg Nothing

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

@@ -14,7 +14,7 @@ module Development.IDE.Types.Diagnostics (
   ideErrorWithSource,
   showDiagnostics,
   showDiagnosticsColored,
-  ) where
+  IdeResultNoDiagnosticsEarlyCutoff) where
 
 import           Control.DeepSeq
 import           Data.Maybe                                as Maybe
@@ -29,6 +29,7 @@ import           Language.LSP.Types                        as LSP (Diagnostic (.
                                                                    DiagnosticSource,
                                                                    List (..))
 
+import           Data.ByteString                           (ByteString)
 import           Development.IDE.Types.Location
 
 
@@ -44,6 +45,9 @@ import           Development.IDE.Types.Location
 --   not propagate diagnostic errors through multiple phases.
 type IdeResult v = ([FileDiagnostic], Maybe v)
 
+-- | an IdeResult with a fingerprint
+type IdeResultNoDiagnosticsEarlyCutoff  v = (Maybe ByteString, Maybe v)
+
 ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
 ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)
 

ghcide/test/exe/Main.hs

@@ -50,7 +50,7 @@ import           Development.IDE.Test                     (Cursor,
                                                            expectNoMoreDiagnostics,
                                                            flushMessages,
                                                            standardizeQuotes,
-                                                           waitForAction)
+                                                           waitForAction, getInterfaceFilesDir)
 import           Development.IDE.Test.Runfiles
 import qualified Development.IDE.Types.Diagnostics        as Diagnostics
 import           Development.IDE.Types.Location
@@ -95,7 +95,7 @@ import           Data.Tuple.Extra
 import           Development.IDE.Core.FileStore           (getModTime)
 import           Development.IDE.Plugin.CodeAction        (matchRegExMultipleImports)
 import qualified Development.IDE.Plugin.HLS.GhcIde        as Ghcide
-import           Development.IDE.Plugin.Test              (TestRequest (BlockSeconds, GetInterfaceFilesDir),
+import           Development.IDE.Plugin.Test              (TestRequest (BlockSeconds),
                                                            WaitForIdeRuleResult (..),
                                                            blockCommandId)
 import           Ide.PluginUtils                          (pluginDescToIdePlugins)
@@ -5249,14 +5249,9 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d
 
 
     -- Check that we wrote the interfaces for B when we saved
-    let m = SCustomMethod "test"
-    lid <- sendRequest m $ toJSON $ GetInterfaceFilesDir bPath
-    res <- skipManyTill anyMessage $ responseForId m lid
-    liftIO $ case res of
-      ResponseMessage{_result=Right (A.fromJSON -> A.Success hidir)} -> do
-        hi_exists <- doesFileExist $ hidir </> "B.hi"
-        assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists
-      _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res
+    Right hidir <- getInterfaceFilesDir bdoc
+    hi_exists <- liftIO $ doesFileExist $ hidir </> "B.hi"
+    liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists
 
     pdoc <- createDoc pPath "haskell" pSource
     changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]

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

@@ -20,6 +20,8 @@ module Development.IDE.Test
   , standardizeQuotes
   , flushMessages
   , waitForAction
+  , getLastBuildKeys
+  , getInterfaceFilesDir
   ) where
 
 import           Control.Applicative.Combinators
@@ -169,13 +171,23 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
 diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
 diagnostic = LspTest.message STextDocumentPublishDiagnostics
 
-waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
-waitForAction key TextDocumentIdentifier{_uri} = do
+callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
+callTestPlugin cmd = do
     let cm = SCustomMethod "test"
-    waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri)
+    waitId <- sendRequest cm (A.toJSON cmd)
     ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
     return $ do
       e <- _result
       case A.fromJSON e of
         A.Error e   -> Left $ ResponseError InternalError (T.pack e) Nothing
         A.Success a -> pure a
+
+waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
+waitForAction key TextDocumentIdentifier{_uri} =
+    callTestPlugin (WaitForIdeRule key _uri)
+
+getLastBuildKeys :: Session (Either ResponseError [T.Text])
+getLastBuildKeys = callTestPlugin GetLastBuildKeys
+
+getInterfaceFilesDir :: TextDocumentIdentifier -> Session (Either ResponseError FilePath)
+getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)

haskell-language-server.cabal

@@ -212,7 +212,7 @@ common haddockComments
 
 common eval
   if flag(eval) || flag(all-plugins)
-    build-depends: hls-eval-plugin ^>=1.1.0.0
+    build-depends: hls-eval-plugin ^>=1.2.0.0
     cpp-options: -Deval
 
 common importLens

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

@@ -8,13 +8,16 @@ module Development.IDE.Graph.Database(
     shakeRunDatabase,
     shakeRunDatabaseForKeys,
     shakeProfileDatabase,
+    shakeLastBuildKeys
     ) where
 
 import           Data.Dynamic
+import           Data.IORef
 import           Data.Maybe
-import           Development.IDE.Graph.Classes ()
+import           Development.IDE.Graph.Classes           ()
 import           Development.IDE.Graph.Internal.Action
 import           Development.IDE.Graph.Internal.Database
+import qualified Development.IDE.Graph.Internal.Ids      as Ids
 import           Development.IDE.Graph.Internal.Options
 import           Development.IDE.Graph.Internal.Profile  (writeProfile)
 import           Development.IDE.Graph.Internal.Rules
@@ -56,3 +59,10 @@ shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
 -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run.
 shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
 shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s
+
+-- | Returns the set of keys built in the most recent step
+shakeLastBuildKeys :: ShakeDatabase -> IO [Key]
+shakeLastBuildKeys (ShakeDatabase _ _ db) = do
+    keys <- Ids.elems $ databaseValues db
+    step <- readIORef $ databaseStep db
+    return [ k | (k, Clean res) <- keys, resultBuilt res == step ]