@@ -101,6 +101,8 @@ data ShakeExtras = ShakeExtras
101101 ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))
102102 -- ^ Map from a text document version to a PositionMapping that describes how to map
103103 -- positions in a version of that document to positions in the latest version
104+ ,inProgress :: Var (Map NormalizedFilePath Int)
105+ -- ^ How many rules are running for each file
104106 }
105107
106108getShakeExtras :: Action ShakeExtras
@@ -298,6 +300,7 @@ shakeOpen :: IO LSP.LspId
298300 -> Rules ()
299301 -> IO IdeState
300302shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
303+ inProgress <- newVar Map.empty
301304 shakeExtras <- do
302305 globals <- newVar HMap.empty
303306 state <- newVar HMap.empty
@@ -311,15 +314,17 @@ shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgr
311314 shakeOpenDatabase
312315 opts
313316 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
314− , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())
317+ -- we don't actually use the progress value, but Shake conveniently spawns/kills this thread whenever
318+ -- we call into Shake, so abuse it for that purpose
319+ , shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure ()
315320 }
316321 rules
317322 shakeAbort <- newMVar $ return ()
318323 shakeDb <- shakeDb
319324 return IdeState{..}
320325
321−lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()
322−lspShakeProgress getLspId sendMsg prog = do
326+lspShakeProgress :: Show a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (Map a Int) -> IO ()
327+lspShakeProgress getLspId sendMsg inProgress = do
323328 lspId <- getLspId
324329 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
325330 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
@@ -347,9 +352,9 @@ lspShakeProgress getLspId sendMsg prog = do
347352 sample = 0.1
348353 loop id prev = do
349354 sleep sample
350− p <- prog
351− let done = countSkipped p + countBuilt p
352− let todo = done + countUnknown p + countTodo p
355+ current <- readVar inProgress
356+ let done = length $ filter (== 0) $ Map.elems current
357+ let todo = Map.size current
353358 let next = Just $ T.pack $ show done <> "/" <> show todo
354359 when (next /= prev) $
355360 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
@@ -525,50 +530,58 @@ usesWithStale key files = do
525530 values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
526531 mapM (uncurry lastValue) (zip files values)
527532
533+
534+withProgress :: Ord a => Var (Map a Int) -> a -> Action b -> Action b
535+withProgress var file = actionBracket (f succ) (const $ f pred) . const
536+ where f shift = modifyVar_ var $ return . Map.alter (Just . shift . fromMaybe 0) file
537+
538+
528539defineEarlyCutoff
529540 :: IdeRule k v
530541 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
531542 -> Rules ()
532543defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
533− extras@ShakeExtras{state} <- getShakeExtras
534− val <- case old of
535− Just old | mode == RunDependenciesSame -> do
536− v <- liftIO $ getValues state key file
537− case v of
538− -- No changes in the dependencies and we have
539− -- an existing result.
540− Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)
541− _ -> return Nothing
542− _ -> return Nothing
543− case val of
544− Just res -> return res
545− Nothing -> do
546− (bs, (diags, res)) <- actionCatch
547− (do v <- op key file; liftIO $ evaluate $ force $ v) $
548− \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
549− modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
550− (bs, res) <- case res of
551− Nothing -> do
552− staleV <- liftIO $ getValues state key file
553− pure $ case staleV of
554− Nothing -> (toShakeValue ShakeResult bs, Failed)
555− Just v -> case v of
556− Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
557− Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
558− Failed -> (toShakeValue ShakeResult bs, Failed)
559− Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
560− liftIO $ setValues state key file res
561− updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
562− let eq = case (bs, fmap decodeShakeValue old) of
563− (ShakeResult a, Just (ShakeResult b)) -> a == b
564− (ShakeStale a, Just (ShakeStale b)) -> a == b
565− -- If we do not have a previous result
566− -- or we got ShakeNoCutoff we always return False.
567− _ -> False
568− return $ RunResult
569− (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
570− (encodeShakeValue bs) $
571− A res bs
544+ extras@ShakeExtras{state, inProgress} <- getShakeExtras
545+ -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key
546+ (if show key == "GetFileExists" then id else withProgress inProgress file) $ do
547+ val <- case old of
548+ Just old | mode == RunDependenciesSame -> do
549+ v <- liftIO $ getValues state key file
550+ case v of
551+ -- No changes in the dependencies and we have
552+ -- an existing result.
553+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)
554+ _ -> return Nothing
555+ _ -> return Nothing
556+ case val of
557+ Just res -> return res
558+ Nothing -> do
559+ (bs, (diags, res)) <- actionCatch
560+ (do v <- op key file; liftIO $ evaluate $ force $ v) $
561+ \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
562+ modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
563+ (bs, res) <- case res of
564+ Nothing -> do
565+ staleV <- liftIO $ getValues state key file
566+ pure $ case staleV of
567+ Nothing -> (toShakeValue ShakeResult bs, Failed)
568+ Just v -> case v of
569+ Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
570+ Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
571+ Failed -> (toShakeValue ShakeResult bs, Failed)
572+ Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
573+ liftIO $ setValues state key file res
574+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
575+ let eq = case (bs, fmap decodeShakeValue old) of
576+ (ShakeResult a, Just (ShakeResult b)) -> a == b
577+ (ShakeStale a, Just (ShakeStale b)) -> a == b
578+ -- If we do not have a previous result
579+ -- or we got ShakeNoCutoff we always return False.
580+ _ -> False
581+ return $ RunResult
582+ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
583+ (encodeShakeValue bs) $
584+ A res bs
572585
573586
574587-- | Rule type, input file