Merge branch 'master' into cleanup-dirtyset

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 ]

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

@@ -168,9 +168,9 @@ compute db@Database{..} key id mode result = do
         actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
         previousDeps= maybe UnknownDeps resultDeps result
     let res = Result runValue built' changed built actualDeps execution runStore
-    case actualDeps of
-        ResultDeps deps | not(null deps) &&
-                    runChanged /= ChangedNothing
+    case getResultDepsDefault [] actualDeps of
+        deps | not(null deps)
+            && runChanged /= ChangedNothing
                     -> do
             void $ forkIO $
                 updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps)
@@ -284,7 +284,7 @@ mapConcurrentlyAIO_ f [one] = liftIO $ justWait $ fmap f one
 mapConcurrentlyAIO_ f many = do
     ref <- AIO ask
     waits <- liftIO $ uninterruptibleMask $ \restore -> do
-        waits <- liftIO $ traverse waitOrSpawn (map (fmap (restore . f)) many)
+        waits <- liftIO $ traverse (waitOrSpawn . fmap (restore . f)) many
         let asyncs = rights waits
         liftIO $ atomicModifyIORef'_ ref (asyncs ++)
         return waits