From b862c6da14f83256544b530903bb9c15213bc216 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 12 Feb 2024 18:41:37 +0800 Subject: [PATCH 01/33] cache semantic lookup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 41 +++++++++++++------ 1 file changed, 28 insertions(+), 13 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs index 2ed11be333..19b8759b50 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs @@ -7,7 +7,8 @@ import Control.Lens (Identity (runIdentity)) import Control.Monad (foldM, guard) import Control.Monad.State.Strict (MonadState (get), MonadTrans (lift), - evalStateT, modify, put) + evalStateT, gets, modify', + put) import Control.Monad.Trans.State.Strict (StateT, runStateT) import Data.Char (isAlphaNum) import Data.DList (DList) @@ -31,13 +32,27 @@ import Prelude hiding (length, span) type Tokenizer m a = StateT PTokenState m a type HsSemanticLookup = Identifier -> Maybe HsSemanticTokenType +type CachedHsSemanticLookup m = Identifier -> Tokenizer m (Maybe HsSemanticTokenType) + +cacheLookup :: (Monad m) => HsSemanticLookup -> CachedHsSemanticLookup m +cacheLookup _ (Left _) = return $ Just TModule +cacheLookup lk idt@(Right n) = do + ne <- gets semanticLookupCache + case lookupNameEnv ne n of + Nothing -> do + let hsSemanticTy = lk idt + modify' (\x -> x{ semanticLookupCache= extendNameEnv ne n hsSemanticTy }) + return hsSemanticTy + Just x -> return x + data PTokenState = PTokenState { - rope :: !Rope -- the remains of rope we are working on - , cursor :: !Char.Position -- the cursor position of the current rope to the start of the original file in code point position - , columnsInUtf16 :: !UInt -- the column of the start of the current rope in utf16 + rope :: !Rope -- the remains of rope we are working on + , cursor :: !Char.Position -- the cursor position of the current rope to the start of the original file in code point position + , columnsInUtf16 :: !UInt -- the column of the start of the current rope in utf16 + , semanticLookupCache :: !(NameEnv (Maybe HsSemanticTokenType)) -- the cache for semantic lookup result of the current file } data SplitResult @@ -56,7 +71,8 @@ mkPTokenState vf = { rope = vf._file_text, cursor = Char.Position 0 0, - columnsInUtf16 = 0 + columnsInUtf16 = 0, + semanticLookupCache = emptyNameEnv } -- lift a Tokenizer Maybe a to Tokenizer m a, @@ -77,10 +93,10 @@ computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast = -- visit every leaf node in the ast in depth first order foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) foldAst lookupHsTokenType ast = if null (nodeChildren ast) - then liftMaybeM (visitLeafIds lookupHsTokenType ast) + then visitLeafIds lookupHsTokenType ast else foldMapM (foldAst lookupHsTokenType) $ nodeChildren ast -visitLeafIds :: HsSemanticLookup -> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType)) +visitLeafIds :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do let span = nodeSpan leaf (ran, token) <- focusTokenAt leaf @@ -93,16 +109,15 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do foldMapM (combineNodeIds lookupHsTokenType ran splitResult) $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf where combineNodeIds :: (Monad m) => HsSemanticLookup -> Range -> SplitResult -> NodeInfo a -> Tokenizer m (DList (Range, HsSemanticTokenType)) - combineNodeIds lookupHsTokenType ran ranSplit (NodeInfo _ _ bd) = + combineNodeIds lookupHsTokenType ran ranSplit (NodeInfo _ _ bd) = do + maybeTokenType <- foldMapM (cacheLookup $ lookupIdentifier lookupHsTokenType ranSplit) (M.keys bd) case (maybeTokenType, ranSplit) of (Nothing, _) -> return mempty (Just TModule, _) -> return $ DL.singleton (ran, TModule) (Just tokenType, NoSplit (_, tokenRan)) -> return $ DL.singleton (tokenRan, tokenType) (Just tokenType, Split (_, ranPrefix, tokenRan)) -> return $ DL.fromList [(ranPrefix, TModule),(tokenRan, tokenType)] - where maybeTokenType = foldMap (getIdentifier lookupHsTokenType ranSplit) (M.keys bd) - - getIdentifier :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType - getIdentifier lookupHsTokenType ranSplit idt = do + lookupIdentifier :: HsSemanticLookup -> SplitResult -> HsSemanticLookup + lookupIdentifier lookupHsTokenType ranSplit idt = do case idt of Left _moduleName -> Just TModule Right name -> do @@ -138,7 +153,7 @@ focusTokenAt leaf = do let nce = newColumn ncs token -- compute the new range for utf16, tuning the columns is enough let ran = codePointRangeToRangeWith ncs nce $ realSrcSpanToCodePointRange span - modify $ \s -> s {columnsInUtf16 = nce, rope = remains, cursor = tokenEndPos} + modify' $ \s -> s {columnsInUtf16 = nce, rope = remains, cursor = tokenEndPos} return (ran, token) where srcSpanCharPositions :: RealSrcSpan -> (Char.Position, Char.Position) From f4458a747849cd24fc6a82f5d50335d880e0e321 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 12 Feb 2024 19:56:13 +0800 Subject: [PATCH 02/33] stop propagate failure on visible generated name --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 32 +++++++++++-------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs index 19b8759b50..29b77d3952 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs @@ -1,14 +1,16 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Avoid restricted function" #-} module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where -import Control.Lens (Identity (runIdentity)) +import Control.Lens (Identity (Identity, runIdentity)) import Control.Monad (foldM, guard) import Control.Monad.State.Strict (MonadState (get), MonadTrans (lift), - evalStateT, gets, modify', - put) + evalStateT, gets, mapStateT, + modify', put) import Control.Monad.Trans.State.Strict (StateT, runStateT) import Data.Char (isAlphaNum) import Data.DList (DList) @@ -83,20 +85,21 @@ liftMaybeM p = do st <- get maybe (return mempty) (\(ans, st') -> put st' >> return ans) $ runStateT p st + foldMapM :: (Monad m, Monoid b, Foldable t) => (a -> m b) -> t a -> m b foldMapM f ta = foldM (\b a -> mappend b <$> f a) mempty ta computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast = - RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ evalStateT (foldAst lookupHsTokenType ast) (mkPTokenState vf) + RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ evalStateT (foldAst (cacheLookup lookupHsTokenType) ast) (mkPTokenState vf) -- | foldAst -- visit every leaf node in the ast in depth first order -foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) +foldAst :: (Monad m) => CachedHsSemanticLookup Identity -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) foldAst lookupHsTokenType ast = if null (nodeChildren ast) then visitLeafIds lookupHsTokenType ast else foldMapM (foldAst lookupHsTokenType) $ nodeChildren ast -visitLeafIds :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) +visitLeafIds :: (Monad m) => CachedHsSemanticLookup Identity -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do let span = nodeSpan leaf (ran, token) <- focusTokenAt leaf @@ -106,20 +109,23 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do -- only handle the leaf node with single column token guard $ srcSpanStartLine span == srcSpanEndLine span splitResult <- lift $ splitRangeByText token ran - foldMapM (combineNodeIds lookupHsTokenType ran splitResult) $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf + mapStateT hoistIdMaybe + $ foldMapM (combineNodeIds lookupHsTokenType ran splitResult) + $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf where - combineNodeIds :: (Monad m) => HsSemanticLookup -> Range -> SplitResult -> NodeInfo a -> Tokenizer m (DList (Range, HsSemanticTokenType)) + hoistIdMaybe :: Identity (a, s) -> Maybe (a, s) + hoistIdMaybe (Identity x) = Just x + combineNodeIds :: CachedHsSemanticLookup Identity -> Range -> SplitResult -> NodeInfo a -> Tokenizer Identity (DList (Range, HsSemanticTokenType)) combineNodeIds lookupHsTokenType ran ranSplit (NodeInfo _ _ bd) = do - maybeTokenType <- foldMapM (cacheLookup $ lookupIdentifier lookupHsTokenType ranSplit) (M.keys bd) + maybeTokenType <- foldMapM (maybe (return Nothing) lookupHsTokenType . getIdentifier ranSplit) (M.keys bd) case (maybeTokenType, ranSplit) of (Nothing, _) -> return mempty (Just TModule, _) -> return $ DL.singleton (ran, TModule) (Just tokenType, NoSplit (_, tokenRan)) -> return $ DL.singleton (tokenRan, tokenType) (Just tokenType, Split (_, ranPrefix, tokenRan)) -> return $ DL.fromList [(ranPrefix, TModule),(tokenRan, tokenType)] - lookupIdentifier :: HsSemanticLookup -> SplitResult -> HsSemanticLookup - lookupIdentifier lookupHsTokenType ranSplit idt = do + getIdentifier ranSplit idt = do case idt of - Left _moduleName -> Just TModule + Left _moduleName -> Just idt Right name -> do occStr <- T.pack <$> case (occNameString . nameOccName) name of -- the generated selector name with {-# LANGUAGE DuplicateRecordFields #-} @@ -129,7 +135,7 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do c : ':' : _ | isAlphaNum c -> Nothing ns -> Just ns guard $ getSplitTokenText ranSplit == occStr - lookupHsTokenType idt + return idt focusTokenAt :: From 03dac25f658419412ebb10bc6271cfa1ba9ed2a2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 12 Feb 2024 20:03:03 +0800 Subject: [PATCH 03/33] add test case --- plugins/hls-semantic-tokens-plugin/test/Main.hs | 1 + .../test/testdata/TRecordWildCards.expected | 12 ++++++++++++ .../test/testdata/TRecordWildCards.hs | 7 +++++++ 3 files changed, 20 insertions(+) create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/Main.hs b/plugins/hls-semantic-tokens-plugin/test/Main.hs index a2d7fde20a..d431e54c61 100644 --- a/plugins/hls-semantic-tokens-plugin/test/Main.hs +++ b/plugins/hls-semantic-tokens-plugin/test/Main.hs @@ -203,6 +203,7 @@ semanticTokensDataTypeTests = "get semantic Tokens" [ goldenWithSemanticTokensWithDefaultConfig "simple datatype" "TDataType", goldenWithSemanticTokensWithDefaultConfig "record" "TRecord", + goldenWithSemanticTokensWithDefaultConfig "TRecordWildCards" "TRecordWildCards", goldenWithSemanticTokensWithDefaultConfig "record With DuplicateRecordFields" "TRecordDuplicateRecordFields", goldenWithSemanticTokensWithDefaultConfig "datatype import" "TDatatypeImported", goldenWithSemanticTokensWithDefaultConfig "datatype family" "TDataFamily", diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.expected new file mode 100644 index 0000000000..4853159c44 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.expected @@ -0,0 +1,12 @@ +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:18-21 TRecordField "foo" +4:25-28 TTypeConstructor "Int" +5:1-5 TVariable "foo1" +5:8-11 TDataConstructor "Foo" +6:1-10 TFunction "unpackFoo" +6:14-17 TTypeConstructor "Foo" +6:21-24 TTypeConstructor "Int" +7:1-10 TFunction "unpackFoo" +7:11-14 TDataConstructor "Foo" +7:21-24 TVariable "foo" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.hs new file mode 100644 index 0000000000..f2a68a44aa --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RecordWildCards #-} +module TRecordWildCards where + +data Foo = Foo { foo :: Int } +foo1 = Foo 1 +unpackFoo :: Foo -> Int +unpackFoo Foo{..} = foo From 4614d824d9b860e26abe00b56df88a1d4f8b0d19 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 02:19:44 +0800 Subject: [PATCH 04/33] cleanup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs index 29b77d3952..568c2c00b9 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs @@ -1,7 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Avoid restricted function" #-} module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where @@ -47,8 +45,6 @@ cacheLookup lk idt@(Right n) = do return hsSemanticTy Just x -> return x - - data PTokenState = PTokenState { rope :: !Rope -- the remains of rope we are working on @@ -66,7 +62,6 @@ getSplitTokenText :: SplitResult -> Text getSplitTokenText (NoSplit (t, _)) = t getSplitTokenText (Split (t, _, _)) = t - mkPTokenState :: VirtualFile -> PTokenState mkPTokenState vf = PTokenState @@ -85,7 +80,6 @@ liftMaybeM p = do st <- get maybe (return mempty) (\(ans, st') -> put st' >> return ans) $ runStateT p st - foldMapM :: (Monad m, Monoid b, Foldable t) => (a -> m b) -> t a -> m b foldMapM f ta = foldM (\b a -> mappend b <$> f a) mempty ta From b4bf796bfd85a7b0e132a1d517bc87180e0d71f0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 16 Feb 2024 01:35:38 +0800 Subject: [PATCH 05/33] configure bench to run semantic tokens --- bench/config.yaml | 41 ++++++++++--------- ghcide-bench/src/Experiments.hs | 20 ++++++--- .../src/Development/Benchmark/Rules.hs | 2 +- 3 files changed, 38 insertions(+), 25 deletions(-) diff --git a/bench/config.yaml b/bench/config.yaml index f8a062dc3d..14d40ea0bd 100644 --- a/bench/config.yaml +++ b/bench/config.yaml @@ -1,6 +1,6 @@ # The number of samples to run per experiment. # At least 100 is recommended in order to observe space leaks -samples: 50 +samples: 1 buildTool: cabal @@ -23,8 +23,9 @@ examples: package: Cabal version: 3.6.3.0 modules: - - src/Distribution/Simple.hs - - src/Distribution/Types/Module.hs + # - src/Distribution/Simple.hs + # - src/Distribution/Types/Module.hs + - src/Distribution/Simple/Configure.hs extra-args: [] # extra HLS command line args # Small-sized project with TH - name: lsp-types @@ -91,20 +92,21 @@ examples: # The set of experiments to execute experiments: - - "edit-header" - - "edit" - - "hover" - - "hover after edit" + # - "edit-header" + # - "edit" + # - "hover" + - "semanticTokens" + # - "hover after edit" # - "hover after cradle edit" - - "getDefinition" - - "getDefinition after edit" - - "completions" - - "completions after edit" - - "code actions" - - "code actions after edit" - - "code actions after cradle edit" - - "documentSymbols after edit" - - "hole fit suggestions" + # - "getDefinition" + # - "getDefinition after edit" + # - "completions" + # - "completions after edit" + # - "code actions" + # - "code actions after edit" + # - "code actions after cradle edit" + # - "documentSymbols after edit" + # - "hole fit suggestions" # An ordered list of versions to analyze versions: @@ -121,15 +123,15 @@ versions: # - 1.8.0.0 -- upstream: origin/master +- upstream: upstream/master # - HEAD~1 -- HEAD +- cache-semantic-lookup # A list of plugin configurations to analyze # WARNING: Currently bench versions later than e4234a3a5e347db249fccefb8e3fb36f89e8eafb # will be unable to send plugin configurations to earlier HLS versions. This causes # all plugins in those versions to always be enabled. -# In addition bench proactively disables all plugins it knows about besides the +# In addition bench proactively disables all plugins it knows about besides the # ones in the following list. However because it can only disable plugins it # knows about, any plugins that are in old versions but were removed from HLS # before the current bench will not be disabled. @@ -194,6 +196,7 @@ configurations: - qualifyImportedNames - rename - stylish-haskell + - semanticTokens # - alternateNumberFormat # - callHierarchy # - changeTypeSignature diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 587f27781b..a4839ccd8f 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -26,7 +26,8 @@ import Control.Applicative.Combinators (skipManyTill) import Control.Concurrent.Async (withAsync) import Control.Exception.Safe (IOException, handleAny, try) -import Control.Lens (_Just, (&), (.~), (^.)) +import Control.Lens (_Just, (&), (.~), (^.), + (^?)) import Control.Lens.Extras (is) import Control.Monad.Extra (allM, forM, forM_, forever, unless, void, when, @@ -100,7 +101,16 @@ allWithIdentifierPos f docs = case applicableDocs of experiments :: HasConfig => [Bench] experiments = - [ --------------------------------------------------------------------------------------- + [ + bench "semanticTokens" $ \docs -> do + liftIO $ putStrLn "Starting semanticTokens" + r <- forM docs $ \DocumentPositions{..} -> do + tks <- getSemanticTokens doc + case tks ^? LSP._L of + Just _ -> return True + Nothing -> return True + return $ and r, + --------------------------------------------------------------------------------------- bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP), --------------------------------------------------------------------------------------- @@ -316,7 +326,7 @@ versionP = maybeReader $ extract . readP_to_S parseVersion extract parses = listToMaybe [ res | (res,"") <- parses] output :: (MonadIO m, HasConfig) => String -> m () -output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn +output = if quiet ?config then (\_ -> pure ()) else liftIO . putStrLn --------------------------------------------------------------------------------------- @@ -597,7 +607,7 @@ callCommandLogging cmd = do setup :: HasConfig => IO SetupResult setup = do -- when alreadyExists $ removeDirectoryRecursive examplesPath - benchDir <- case exampleDetails(example ?config) of + benchDir <- case exampleDetails (example ?config) of ExamplePath examplePath -> do let hieYamlPath = examplePath "hie.yaml" alreadyExists <- doesFileExist hieYamlPath @@ -661,7 +671,7 @@ setup = do whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True - let cleanUp = case exampleDetails(example ?config) of + let cleanUp = case exampleDetails (example ?config) of ExampleHackage _ -> removeDirectoryRecursive examplesPath ExampleScript _ _ -> removeDirectoryRecursive examplesPath ExamplePath _ -> return () diff --git a/shake-bench/src/Development/Benchmark/Rules.hs b/shake-bench/src/Development/Benchmark/Rules.hs index 5993229217..9c8675d03c 100644 --- a/shake-bench/src/Development/Benchmark/Rules.hs +++ b/shake-bench/src/Development/Benchmark/Rules.hs @@ -333,7 +333,7 @@ benchRules build MkBenchRules{..} = do ++ concat [[ "-h" , "-i" <> show i - , "-po" <> outHp + , "-po" <> dropExtension outHp , "-qg"] | CheapHeapProfiling i <- [prof]] ++ ["-RTS"] From 89a263e01195fb518fc88347f267f61044c61712 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 16 Feb 2024 02:07:35 +0800 Subject: [PATCH 06/33] try to edit the file and then get result --- bench/config.yaml | 2 +- ghcide-bench/src/Experiments.hs | 17 +++++++++++++++-- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/bench/config.yaml b/bench/config.yaml index 14d40ea0bd..a12799f542 100644 --- a/bench/config.yaml +++ b/bench/config.yaml @@ -1,6 +1,6 @@ # The number of samples to run per experiment. # At least 100 is recommended in order to observe space leaks -samples: 1 +samples: 50 buildTool: cabal diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index a4839ccd8f..ae82b12809 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -82,6 +82,15 @@ headerEdit = .+ #rangeLength .== Nothing .+ #text .== "-- header comment \n" +tailEdit :: UInt -> Text -> TextDocumentContentChangeEvent +tailEdit end i = + TextDocumentContentChangeEvent $ InL $ #range .== Range (Position end 0) (Position end (fromIntegral $ T.length txt)) + .+ #rangeLength .== Nothing + .+ #text .== (txt <> "\n") + where + txt :: Text + txt = "x" <> i <> "=" <> i + data DocumentPositions = DocumentPositions { -- | A position that can be used to generate non null goto-def and completion responses identifierP :: Maybe Position, @@ -104,11 +113,15 @@ experiments = [ bench "semanticTokens" $ \docs -> do liftIO $ putStrLn "Starting semanticTokens" - r <- forM docs $ \DocumentPositions{..} -> do + r <- forM (zip [T.pack $ show i | i :: Int <- [0..]] docs) $ \(i, DocumentPositions{..}) -> do + bottom <- fromIntegral . length . T.lines <$> documentContents doc + changeDoc doc [tailEdit bottom i] + -- wait for a fresh build start + waitForProgressStart tks <- getSemanticTokens doc case tks ^? LSP._L of Just _ -> return True - Nothing -> return True + Nothing -> return False return $ and r, --------------------------------------------------------------------------------------- bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} -> From d09cc33e1a7e365b38fde474bce7ef659267ffc1 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 16 Feb 2024 22:40:28 +0800 Subject: [PATCH 07/33] update bench config --- bench/config.yaml | 25 +++++++++++++------------ ghcide-bench/src/Experiments.hs | 14 ++------------ 2 files changed, 15 insertions(+), 24 deletions(-) diff --git a/bench/config.yaml b/bench/config.yaml index a12799f542..4dd46fa169 100644 --- a/bench/config.yaml +++ b/bench/config.yaml @@ -26,6 +26,7 @@ examples: # - src/Distribution/Simple.hs # - src/Distribution/Types/Module.hs - src/Distribution/Simple/Configure.hs + - src/Distribution/Simple/BuildTarget.hs extra-args: [] # extra HLS command line args # Small-sized project with TH - name: lsp-types @@ -92,21 +93,21 @@ examples: # The set of experiments to execute experiments: - # - "edit-header" - # - "edit" - # - "hover" + - "edit-header" + - "edit" + - "hover" - "semanticTokens" # - "hover after edit" # - "hover after cradle edit" - # - "getDefinition" - # - "getDefinition after edit" - # - "completions" - # - "completions after edit" - # - "code actions" - # - "code actions after edit" - # - "code actions after cradle edit" - # - "documentSymbols after edit" - # - "hole fit suggestions" + - "getDefinition" + - "getDefinition after edit" + - "completions" + - "completions after edit" + - "code actions" + - "code actions after edit" + - "code actions after cradle edit" + - "documentSymbols after edit" + - "hole fit suggestions" # An ordered list of versions to analyze versions: diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index ae82b12809..b9b7613e6d 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -82,15 +82,6 @@ headerEdit = .+ #rangeLength .== Nothing .+ #text .== "-- header comment \n" -tailEdit :: UInt -> Text -> TextDocumentContentChangeEvent -tailEdit end i = - TextDocumentContentChangeEvent $ InL $ #range .== Range (Position end 0) (Position end (fromIntegral $ T.length txt)) - .+ #rangeLength .== Nothing - .+ #text .== (txt <> "\n") - where - txt :: Text - txt = "x" <> i <> "=" <> i - data DocumentPositions = DocumentPositions { -- | A position that can be used to generate non null goto-def and completion responses identifierP :: Maybe Position, @@ -114,10 +105,9 @@ experiments = bench "semanticTokens" $ \docs -> do liftIO $ putStrLn "Starting semanticTokens" r <- forM (zip [T.pack $ show i | i :: Int <- [0..]] docs) $ \(i, DocumentPositions{..}) -> do - bottom <- fromIntegral . length . T.lines <$> documentContents doc - changeDoc doc [tailEdit bottom i] - -- wait for a fresh build start + changeDoc doc [charEdit stringLiteralP] waitForProgressStart + waitForProgressDone tks <- getSemanticTokens doc case tks ^? LSP._L of Just _ -> return True From b4a527cb3ce7097170ae1752206f50a14a31dfd1 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 16 Feb 2024 22:44:31 +0800 Subject: [PATCH 08/33] fix config --- bench/config.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/bench/config.yaml b/bench/config.yaml index 4dd46fa169..9d97929a50 100644 --- a/bench/config.yaml +++ b/bench/config.yaml @@ -124,9 +124,9 @@ versions: # - 1.8.0.0 -- upstream: upstream/master +- upstream: origin/master # - HEAD~1 -- cache-semantic-lookup +- HEAD # A list of plugin configurations to analyze # WARNING: Currently bench versions later than e4234a3a5e347db249fccefb8e3fb36f89e8eafb From c8b286a27c236361d84204aa36725b280db21fe6 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 16 Feb 2024 23:59:57 +0800 Subject: [PATCH 09/33] add back test --- bench/config.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bench/config.yaml b/bench/config.yaml index 9d97929a50..34ce8710e5 100644 --- a/bench/config.yaml +++ b/bench/config.yaml @@ -97,7 +97,7 @@ experiments: - "edit" - "hover" - "semanticTokens" - # - "hover after edit" + - "hover after edit" # - "hover after cradle edit" - "getDefinition" - "getDefinition after edit" From fd4ab4d1edee2e901c1396a73730bd1577dca114 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 21 Feb 2024 20:20:25 +0800 Subject: [PATCH 10/33] linearlize the refreshing of dependencies --- .../src/Development/IDE/Graph/Database.hs | 3 +- .../Development/IDE/Graph/Internal/Action.hs | 3 +- .../IDE/Graph/Internal/Database.hs | 44 ++++++++++++------- .../Development/IDE/Graph/Internal/Profile.hs | 5 ++- .../Development/IDE/Graph/Internal/Types.hs | 10 ++--- 5 files changed, 39 insertions(+), 26 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index bd8601cd16..fc30052f84 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -12,6 +12,7 @@ module Development.IDE.Graph.Database( ,shakeGetBuildEdges) where import Control.Concurrent.STM.Stats (readTVarIO) import Data.Dynamic +import Data.Foldable (fold) import Data.Maybe import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action @@ -77,7 +78,7 @@ shakeGetBuildEdges :: ShakeDatabase -> IO Int shakeGetBuildEdges (ShakeDatabase _ _ db) = do keys <- getDatabaseValues db let ress = mapMaybe (getResult . snd) keys - return $ sum $ map (lengthKeySet . getResultDepsDefault mempty . resultDeps) ress + return $ sum $ map (lengthKeySet . fold . getResultDepsDefault mempty . resultDeps) ress -- | Returns an approximation of the database keys, -- annotated with how long ago (in # builds) they were visited diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 14d8f38b2c..c855ac78a2 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -114,13 +114,14 @@ actionFinally a b = do apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value apply1 k = runIdentity <$> apply (Identity k) +-- todo make the result ordered apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value) apply ks = do db <- Action $ asks actionDatabase stack <- Action $ asks actionStack (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps - liftIO $ modifyIORef ref (ResultDeps (fromListKeySet $ toList is) <>) + liftIO $ modifyIORef ref (ResultDeps [fromListKeySet $ toList is] <>) pure vs -- | Evaluate a list of keys without recording any dependencies. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index d8fc096639..f12eb5c2de 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -3,9 +3,9 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where @@ -25,7 +25,7 @@ import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Strict as State import Data.Dynamic import Data.Either -import Data.Foldable (for_, traverse_) +import Data.Foldable (fold, for_, traverse_) import Data.IORef.Extra import Data.List.NonEmpty (unzip) import Data.Maybe @@ -133,6 +133,27 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do waitAll pure results +isDirty :: Foldable t => Result -> t (a, Result) -> Bool +isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) + +refreshDeps :: Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result) +refreshDeps db stack key result = \case + -- no more deps to refresh + [] -> pure $ compute db stack key RunDependenciesSame (Just result) + (dep:deps) -> do + res <- builder db stack (toListKeySet dep) + case res of + Left res -> if isDirty result res + -- restart the computation if any of the deps are dirty + then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged (Just result) + -- else kick the rest of the deps + else refreshDeps db stack key result deps + Right iores -> asyncWithCleanUp $ liftIO $ do + res <- iores + if isDirty result res + then compute db stack key RunDependenciesChanged (Just result) + else join $ runAIO $ refreshDeps db stack key result deps + -- | Refresh a key: -- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. -- This assumes that the implementation will be a lookup @@ -141,18 +162,7 @@ refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result) -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined refresh db stack key result = case (addStack key stack, result) of (Left e, _) -> throw e - (Right stack, Just me@Result{resultDeps = ResultDeps (toListKeySet -> deps)}) -> do - res <- builder db stack deps - let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) - case res of - Left res -> - if isDirty res - then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result - else pure $ compute db stack key RunDependenciesSame result - Right iores -> asyncWithCleanUp $ liftIO $ do - res <- iores - let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame - compute db stack key mode result + (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps db stack key me (reverse deps) (Right stack, _) -> asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result @@ -172,8 +182,8 @@ compute db@Database{..} stack key 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 getResultDepsDefault mempty actualDeps of - deps | not(nullKeySet deps) + case fold $ getResultDepsDefault mempty actualDeps of + deps | not (nullKeySet deps) && runChanged /= ChangedNothing -> do -- IMPORTANT: record the reverse deps **before** marking the key Clean. @@ -182,7 +192,7 @@ compute db@Database{..} stack key mode result = do -- on the next build. void $ updateReverseDeps key db - (getResultDepsDefault mempty previousDeps) + (fold $ getResultDepsDefault mempty previousDeps) deps _ -> pure () atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 408e3d2f12..b657f002fd 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -12,6 +12,7 @@ import Data.Bifunctor import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char import Data.Dynamic (toDyn) +import Data.Foldable (fold) import qualified Data.HashMap.Strict as Map import Data.List (dropWhileEnd, foldl', intercalate, @@ -108,7 +109,7 @@ toReport :: Database -> IO ([ProfileEntry], KeyMap Int) toReport db = do status <- prepareForDependencyOrder db let order = dependencyOrder show - $ map (second (toListKeySet . getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") . resultDeps)) + $ map (second (toListKeySet . fold . getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") . resultDeps)) $ toListKeyMap status ids = fromListKeyMap $ zip order [0..] @@ -121,7 +122,7 @@ toReport db = do ,prfBuilt = fromStep resultBuilt ,prfVisited = fromStep resultVisited ,prfChanged = fromStep resultChanged - ,prfDepends = map pure $ elemsKeyMap $ restrictKeysKeyMap ids $ getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") resultDeps + ,prfDepends = map pure $ elemsKeyMap $ restrictKeysKeyMap ids $ fold $ getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") resultDeps ,prfExecution = resultExecution } where fromStep i = fromJust $ Map.lookup i steps diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index d780b5c921..c95fe5319a 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -144,17 +144,17 @@ data Result = Result { resultData :: !BS.ByteString } -data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet +data ResultDeps = UnknownDeps | AlwaysRerunDeps ![KeySet] | ResultDeps ![KeySet] deriving (Eq, Show) -getResultDepsDefault :: KeySet -> ResultDeps -> KeySet +getResultDepsDefault :: KeySet -> ResultDeps -> [KeySet] getResultDepsDefault _ (ResultDeps ids) = ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids -getResultDepsDefault def UnknownDeps = def +getResultDepsDefault def UnknownDeps = [def] mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps -mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids -mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids +mapResultDeps f (ResultDeps ids) = ResultDeps $ fmap f ids +mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ fmap f ids mapResultDeps _ UnknownDeps = UnknownDeps instance Semigroup ResultDeps where From 0e73a5cf787e8464cb37e69c200770de2e9e574d Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 21 Feb 2024 22:28:29 +0800 Subject: [PATCH 11/33] fix up hls-graph test --- hls-graph/test/ActionSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index cfa7a5eeef..d2f1fe577f 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -40,7 +40,7 @@ spec = do apply1 theKey res `shouldBe` [True] Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb - resultDeps res `shouldBe` ResultDeps (singletonKeySet $ newKey (Rule @())) + resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (Rule @())] it "tracks reverse dependencies" $ do db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase shakeOptions $ do ruleUnit From e08f07073d32fb6f7a37ecf6e4027c47d5c4307c Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 22 Feb 2024 02:20:25 +0800 Subject: [PATCH 12/33] keep track of visited keys in `refreshDeps` --- .../src/Development/IDE/Graph/Internal/Database.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index f12eb5c2de..1dd1e887c2 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -136,23 +136,24 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do isDirty :: Foldable t => Result -> t (a, Result) -> Bool isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) -refreshDeps :: Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result) -refreshDeps db stack key result = \case +refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result) +refreshDeps visited db stack key result = \case -- no more deps to refresh [] -> pure $ compute db stack key RunDependenciesSame (Just result) (dep:deps) -> do - res <- builder db stack (toListKeySet dep) + let newVisited = dep <> visited + res <- builder db stack (toListKeySet (dep `differenceKeySet` visited)) case res of Left res -> if isDirty result res -- restart the computation if any of the deps are dirty then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged (Just result) -- else kick the rest of the deps - else refreshDeps db stack key result deps + else refreshDeps newVisited db stack key result deps Right iores -> asyncWithCleanUp $ liftIO $ do res <- iores if isDirty result res then compute db stack key RunDependenciesChanged (Just result) - else join $ runAIO $ refreshDeps db stack key result deps + else join $ runAIO $ refreshDeps newVisited db stack key result deps -- | Refresh a key: -- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. @@ -162,7 +163,7 @@ refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result) -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined refresh db stack key result = case (addStack key stack, result) of (Left e, _) -> throw e - (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps db stack key me (reverse deps) + (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps) (Right stack, _) -> asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result From cb4a527700251b6b9d6c5cb853d063a5ae7099f2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 22 Feb 2024 02:20:57 +0800 Subject: [PATCH 13/33] through error on `LogTypecheckedFOI` --- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 81345fdb80..5d7b2526ce 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -664,7 +664,7 @@ typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck fi -- Keeping typechecked modules in memory for other files is -- very expensive. when (foi == NotFOI) $ - logWith recorder Logger.Warning $ LogTypecheckedFOI file + error $ show $ pretty $ LogTypecheckedFOI file typeCheckRuleDefinition hsc pm knownFilesRule :: Recorder (WithPriority Log) -> Rules () From 90ebb96a4f0eafc2bdbd514c0ad0b5b7e948329a Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 22 Feb 2024 21:23:21 +0800 Subject: [PATCH 14/33] Revert "through error on `LogTypecheckedFOI`" This reverts commit cb4a527700251b6b9d6c5cb853d063a5ae7099f2. --- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 5d7b2526ce..81345fdb80 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -664,7 +664,7 @@ typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck fi -- Keeping typechecked modules in memory for other files is -- very expensive. when (foi == NotFOI) $ - error $ show $ pretty $ LogTypecheckedFOI file + logWith recorder Logger.Warning $ LogTypecheckedFOI file typeCheckRuleDefinition hsc pm knownFilesRule :: Recorder (WithPriority Log) -> Rules () From 37560e93854fc797d9fe1fd08df12eb37cf23d91 Mon Sep 17 00:00:00 2001 From: Jan Hrcek <2716069+jhrcek@users.noreply.github.com> Date: Sat, 17 Feb 2024 07:27:37 +0100 Subject: [PATCH 15/33] refactor plugin: fix regex for extracting import suggestions (#4080) --- .../src/Development/IDE/Plugin/CodeAction.hs | 4 ++-- plugins/hls-refactor-plugin/test/Main.hs | 18 ++++++++++++++++++ 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index f969ac1fdf..20a67ad747 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -931,9 +931,9 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_ | Just [binding, mod, srcspan] <- matchRegexUnifySpaces _message #if MIN_VERSION_ghc(9,7,0) - "Add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\(at (.*)\\)." + "Add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\(at (.*)\\)\\." #else - "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\)." + "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\)\\." #endif = suggestions hsmodImports binding mod srcspan | Just (binding, mod_srcspan) <- diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 7ab1d80c76..58926b0ab0 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -1275,6 +1275,21 @@ extendImportTests = testGroup "extend import actions" , "b :: A" , "b = ConstructorFoo" ]) + , brokenForGHC92 "On GHC 9.2, the error doesn't contain \"perhaps you want ...\" part from which import suggestion can be extracted." $ + testSession "extend single line import in presence of extra parens" $ template + [] + ("Main.hs", T.unlines + [ "import Data.Monoid (First)" + , "f = (First Nothing) <> mempty" -- parens tripped up the regex extracting import suggestions + ]) + (Range (Position 1 6) (Position 1 7)) + [ "Add First(..) to the import list of Data.Monoid" + , "Add First(First) to the import list of Data.Monoid" + ] + (T.unlines + [ "import Data.Monoid (First (..))" + , "f = (First Nothing) <> mempty" + ]) , brokenForGHC94 "On GHC 9.4, the error messages with -fdefer-type-errors don't have necessary imported target srcspan info." $ testSession "extend single line qualified import with value" $ template [("ModuleA.hs", T.unlines @@ -3735,3 +3750,6 @@ withTempDir f = System.IO.Extra.withTempDir $ \dir -> brokenForGHC94 :: String -> TestTree -> TestTree brokenForGHC94 = knownBrokenForGhcVersions [GHC94] + +brokenForGHC92 :: String -> TestTree -> TestTree +brokenForGHC92 = knownBrokenForGhcVersions [GHC92] From 8459019432f0e4b83e24650eff5f82a16df8ae5c Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 19 Feb 2024 10:56:14 +0000 Subject: [PATCH 16/33] Bump pre-commit/action from 3.0.0 to 3.0.1 (#4066) Bumps [pre-commit/action](https://github.com/pre-commit/action) from 3.0.0 to 3.0.1. - [Release notes](https://github.com/pre-commit/action/releases) - [Commits](https://github.com/pre-commit/action/compare/v3.0.0...v3.0.1) --- updated-dependencies: - dependency-name: pre-commit/action dependency-type: direct:production update-type: version-update:semver-patch ... Signed-off-by: dependabot[bot] Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com> Co-authored-by: Michael Peyton Jones --- .github/workflows/pre-commit.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/pre-commit.yml b/.github/workflows/pre-commit.yml index 9d721734d9..2775ca37ad 100644 --- a/.github/workflows/pre-commit.yml +++ b/.github/workflows/pre-commit.yml @@ -54,6 +54,6 @@ jobs: ${{ inputs.cache-prefix }}${{ env.cache-name }}-${{ inputs.os }}- - uses: actions/setup-python@v5 - - uses: pre-commit/action@v3.0.0 + - uses: pre-commit/action@v3.0.1 with: extra_args: --files ${{ needs.file-diff.outputs.git-diff }} From 9d33b5ab05b5e1739969a101bec024fc825ba7ce Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Tue, 20 Feb 2024 06:55:44 -0800 Subject: [PATCH 17/33] Add support for fourmolu 0.15 (#4086) --- haskell-language-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 92465afcd5..d84c369f2a 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1304,7 +1304,7 @@ library hls-fourmolu-plugin build-depends: , base >=4.12 && <5 , filepath - , fourmolu ^>= 0.14 + , fourmolu ^>= 0.14 || ^>= 0.15 , ghc-boot-th , ghcide == 2.6.0.0 , hls-plugin-api == 2.6.0.0 From 1ede74165608f43643035cdca102d0dc3e36dfea Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 22 Feb 2024 05:54:52 +0800 Subject: [PATCH 18/33] Add Method_TextDocumentSemanticTokensFullDelta (#4073) * add Method_TextDocumentSemanticTokensFullDelta * remove persistentGetSemanticTokensRule * add doc about semanticTokensCache location * add Note [Semantic Tokens Cache Location] --------- Co-authored-by: fendor --- ghcide/src/Development/IDE/Core/Shake.hs | 18 ++++ haskell-language-server.cabal | 5 +- hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 2 + hls-plugin-api/src/Ide/Types.hs | 6 ++ .../src/Ide/Plugin/SemanticTokens.hs | 8 +- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 73 ++++++++++++--- .../src/Ide/Plugin/SemanticTokens/Mappings.hs | 2 +- .../src/Ide/Plugin/SemanticTokens/Query.hs | 31 ++++--- .../src/Ide/Plugin/SemanticTokens/Types.hs | 7 ++ .../src/Ide/Plugin/SemanticTokens/Utils.hs | 5 +- .../test/{Main.hs => SemanticTokensTest.hs} | 88 ++++++++++++++++--- 11 files changed, 204 insertions(+), 41 deletions(-) rename plugins/hls-semantic-tokens-plugin/test/{Main.hs => SemanticTokensTest.hs} (72%) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 74747e66d6..2791dcfc2d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -164,6 +164,7 @@ import Language.LSP.Diagnostics import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Types (SemanticTokens) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Language.LSP.VFS hiding (start) @@ -243,6 +244,13 @@ data HieDbWriter -- with (currently) retry functionality type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +-- Note [Semantic Tokens Cache Location] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- storing semantic tokens cache for each file in shakeExtras might +-- not be ideal, since it most used in LSP request handlers +-- instead of rules. We should consider moving it to a more +-- appropriate place in the future if we find one, store it for now. + -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras { --eventer :: LSP.FromServerMessage -> IO () @@ -259,6 +267,14 @@ data ShakeExtras = ShakeExtras ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. + + ,semanticTokensCache:: STM.Map NormalizedFilePath SemanticTokens + -- ^ Cache of last response of semantic tokens for each file, + -- so we can compute deltas for semantic tokens(SMethod_TextDocumentSemanticTokensFullDelta). + -- putting semantic tokens cache and id in shakeExtras might not be ideal + -- see Note [Semantic Tokens Cache Location] + ,semanticTokensId :: TVar Int + -- ^ semanticTokensId is used to generate unique ids for each lsp response of semantic tokens. ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping)) -- ^ Map from a text document version to a PositionMapping that describes how to map -- positions in a version of that document to positions in the latest version @@ -616,12 +632,14 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer diagnostics <- STM.newIO hiddenDiagnostics <- STM.newIO publishedDiagnostics <- STM.newIO + semanticTokensCache <- STM.newIO positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed HMap.empty let restartShakeSession = shakeRestart recorder ideState persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 + semanticTokensId <- newTVarIO 0 indexProgressToken <- newVar Nothing let hiedbWriter = HieDbWriter{..} exportsMap <- newTVarIO mempty diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d84c369f2a..f505dc26e1 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1574,6 +1574,8 @@ library hls-semantic-tokens-plugin , hls-graph == 2.6.0.0 , template-haskell , data-default + , stm + , stm-containers default-extensions: DataKinds @@ -1581,7 +1583,7 @@ test-suite hls-semantic-tokens-plugin-tests import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-semantic-tokens-plugin/test - main-is: Main.hs + main-is: SemanticTokensTest.hs build-depends: , aeson @@ -1601,6 +1603,7 @@ test-suite hls-semantic-tokens-plugin-tests , ghcide == 2.6.0.0 , hls-plugin-api == 2.6.0.0 , data-default + , row-types ----------------------------- -- HLS diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index 9c1c592fd2..1dbc97a202 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -94,6 +94,7 @@ pluginsToDefaultConfig IdePlugins {..} = SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn] SMethod_TextDocumentSemanticTokensFull -> ["semanticTokensOn" A..= plcSemanticTokensOn] + SMethod_TextDocumentSemanticTokensFullDelta -> ["semanticTokensOn" A..= plcSemanticTokensOn] _ -> [] -- | Generates json schema used in haskell vscode extension @@ -125,6 +126,7 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions" plcCompletionOn] SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy" plcCallHierarchyOn] SMethod_TextDocumentSemanticTokensFull -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens" plcSemanticTokensOn] + SMethod_TextDocumentSemanticTokensFullDelta -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens" plcSemanticTokensOn] _ -> [] schemaEntry desc defaultVal = A.object diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 62552e7e05..c6fd8741a3 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -511,6 +511,9 @@ instance PluginMethod Request Method_TextDocumentRangeFormatting where instance PluginMethod Request Method_TextDocumentSemanticTokensFull where handlesRequest = pluginEnabledWithFeature plcSemanticTokensOn +instance PluginMethod Request Method_TextDocumentSemanticTokensFullDelta where + handlesRequest = pluginEnabledWithFeature plcSemanticTokensOn + instance PluginMethod Request Method_TextDocumentPrepareCallHierarchy where handlesRequest = pluginEnabledWithFeature plcCallHierarchyOn @@ -751,6 +754,9 @@ instance PluginRequestMethod (Method_CustomMethod m) where instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where combineResponses _ _ _ _ (x :| _) = x +instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where + combineResponses _ _ _ _ (x :| _) = x + takeLefts :: [a |? b] -> [a] takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x]) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs index 41708d30c2..28e05f5e8c 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} + module Ide.Plugin.SemanticTokens (descriptor) where @@ -12,8 +12,10 @@ import Language.LSP.Protocol.Message descriptor :: Recorder (WithPriority SemanticLog) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId "Provides semantic tokens") - { Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder), - Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder <> Internal.persistentGetSemanticTokensRule, + { Ide.Types.pluginHandlers = + mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder) + <> mkPluginHandler SMethod_TextDocumentSemanticTokensFullDelta (Internal.semanticTokensFullDelta recorder), + Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder, pluginConfigDescriptor = defaultConfigDescriptor { configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False} diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index 3b87c0f336..1be1b523b6 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -10,14 +10,19 @@ -- | -- This module provides the core functionality of the plugin. -module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule, semanticConfigProperties) where +module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where +import Control.Concurrent.STM (stateTVar) +import Control.Concurrent.STM.Stats (atomically) import Control.Lens ((^.)) import Control.Monad.Except (ExceptT, liftEither, withExceptT) +import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans (lift) import Control.Monad.Trans.Except (runExceptT) import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T import Development.IDE (Action, GetDocMap (GetDocMap), GetHieAst (GetHieAst), @@ -31,10 +36,10 @@ import Development.IDE (Action, hieKind, use_) import Development.IDE.Core.PluginUtils (runActionE, useWithStaleE) -import Development.IDE.Core.PositionMapping (idDelta) import Development.IDE.Core.Rules (toIdeResult) import Development.IDE.Core.RuleTypes (DocAndTyThingMap (..)) -import Development.IDE.Core.Shake (addPersistentRule, +import Development.IDE.Core.Shake (ShakeExtras (..), + getShakeExtras, getVirtualFile, useWithStale_) import Development.IDE.GHC.Compat hiding (Warning) @@ -51,11 +56,13 @@ import Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanti import Ide.Plugin.SemanticTokens.Types import Ide.Types import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message (Method (Method_TextDocumentSemanticTokensFull)) +import Language.LSP.Protocol.Message (MessageResult, + Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta)) import Language.LSP.Protocol.Types (NormalizedFilePath, SemanticTokens, - type (|?) (InL)) + type (|?) (InL, InR)) import Prelude hiding (span) +import qualified StmContainers.Map as STM $mkSemanticConfigFunctions @@ -68,14 +75,40 @@ computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeS computeSemanticTokens recorder pid _ nfp = do config <- lift $ useSemanticConfigAction pid logWith recorder Debug (LogConfig config) + semanticId <- lift getAndIncreaseSemanticTokensId (RangeHsSemanticTokenTypes {rangeSemanticList}, mapping) <- useWithStaleE GetSemanticTokens nfp - withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens config mapping rangeSemanticList + withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping rangeSemanticList semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull -semanticTokensFull recorder state pid param = do +semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull + where + computeSemanticTokensFull :: ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFull) + computeSemanticTokensFull = do + nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) + items <- computeSemanticTokens recorder pid state nfp + lift $ setSemanticTokens nfp items + return $ InL items + + +semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFullDelta +semanticTokensFullDelta recorder state pid param = do nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) - items <- runActionE "SemanticTokens.semanticTokensFull" state $ computeSemanticTokens recorder pid state nfp - return $ InL items + let previousVersionFromParam = param ^. L.previousResultId + runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp + where + computeSemanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> Text -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) + computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp = do + semanticTokens <- computeSemanticTokens recorder pid state nfp + previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens nfp + lift $ setSemanticTokens nfp semanticTokens + case previousSemanticTokensMaybe of + Nothing -> return $ InL semanticTokens + Just previousSemanticTokens -> + if Just previousVersionFromParam == previousSemanticTokens^.L.resultId + then return $ InR $ InL $ makeSemanticTokensDeltaWithId (semanticTokens^.L.resultId) previousSemanticTokens semanticTokens + else do + logWith recorder Warning (LogSemanticTokensDeltaMisMatch previousVersionFromParam (previousSemanticTokens^.L.resultId)) + return $ InL semanticTokens -- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file. -- @@ -98,9 +131,6 @@ getSemanticTokensRule recorder = let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast --- | Persistent rule to ensure that semantic tokens doesn't block on startup -persistentGetSemanticTokensRule :: Rules () -persistentGetSemanticTokensRule = addPersistentRule GetSemanticTokens $ \_ -> pure $ Just (RangeHsSemanticTokenTypes mempty, idDelta, Nothing) -- taken from /haskell-language-server/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -113,3 +143,22 @@ handleError recorder action' = do logWith recorder Warning msg pure $ toIdeResult (Left []) Right value -> pure $ toIdeResult (Right value) + +----------------------- +-- helper functions +----------------------- + +-- keep track of the semantic tokens response id +-- so that we can compute the delta between two versions +getAndIncreaseSemanticTokensId :: Action SemanticTokenId +getAndIncreaseSemanticTokensId = do + ShakeExtras{semanticTokensId} <- getShakeExtras + liftIO $ atomically $ do + i <- stateTVar semanticTokensId (\val -> (val, val+1)) + return $ T.pack $ show i + +getPreviousSemanticTokens :: NormalizedFilePath -> Action (Maybe SemanticTokens) +getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup uri . semanticTokensCache + +setSemanticTokens :: NormalizedFilePath -> SemanticTokens -> Action () +setSemanticTokens uri tokens = getShakeExtras >>= liftIO . atomically . STM.insert tokens uri . semanticTokensCache diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs index 1d7c51fd47..d9bfc4449d 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} + -- | -- This module provides mappings to convert token type information in the Haskell IDE plugin. It includes functions for: diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs index b0d26c5e87..fb7fdd9e71 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} - -- | -- The query module is used to query the semantic tokens from the AST module Ide.Plugin.SemanticTokens.Query where @@ -18,13 +15,16 @@ import Ide.Plugin.SemanticTokens.Mappings import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind, HsSemanticTokenType (TModule), RangeSemanticTokenTypeList, + SemanticTokenId, SemanticTokensConfig) import Language.LSP.Protocol.Types (Position (Position), Range (Range), SemanticTokenAbsolute (SemanticTokenAbsolute), - SemanticTokens, + SemanticTokens (SemanticTokens), + SemanticTokensDelta (SemanticTokensDelta), defaultSemanticTokensLegend, - makeSemanticTokens) + makeSemanticTokens, + makeSemanticTokensDelta) import Prelude hiding (length, span) --------------------------------------------------------- @@ -47,8 +47,7 @@ idSemantic tyThingMap hieKind rm (Right n) = --------------------------------------------------------- nameSemanticFromHie :: forall a. HieFunMaskKind a -> RefMap a -> Name -> Maybe HsSemanticTokenType -nameSemanticFromHie hieKind rm n = do - idSemanticFromRefMap rm (Right n) +nameSemanticFromHie hieKind rm n = idSemanticFromRefMap rm (Right n) where idSemanticFromRefMap :: RefMap a -> Identifier -> Maybe HsSemanticTokenType idSemanticFromRefMap rm' name' = do @@ -67,10 +66,9 @@ nameSemanticFromHie hieKind rm n = do ------------------------------------------------- -rangeSemanticsSemanticTokens :: SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens -rangeSemanticsSemanticTokens stc mapping = - makeSemanticTokens defaultSemanticTokensLegend - . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk) +rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens +rangeSemanticsSemanticTokens sid stc mapping = + makeSemanticTokensWithId (Just sid) . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk) where toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType = @@ -81,3 +79,14 @@ rangeSemanticsSemanticTokens stc mapping = (fromIntegral len) (toLspTokenType stc tokenType) [] + +makeSemanticTokensWithId :: Maybe SemanticTokenId -> [SemanticTokenAbsolute] -> Either Text SemanticTokens +makeSemanticTokensWithId sid tokens = do + (SemanticTokens _ tokens) <- makeSemanticTokens defaultSemanticTokensLegend tokens + return $ SemanticTokens sid tokens + +makeSemanticTokensDeltaWithId :: Maybe SemanticTokenId -> SemanticTokens -> SemanticTokens -> SemanticTokensDelta +makeSemanticTokensDeltaWithId sid previousTokens currentTokens = + let (SemanticTokensDelta _ stEdits) = makeSemanticTokensDelta previousTokens currentTokens + in SemanticTokensDelta sid stEdits + diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs index 601956bee9..d7cf2a2b50 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs @@ -18,6 +18,7 @@ import Development.IDE.Graph.Classes (Hashable) import GHC.Generics (Generic) import Language.LSP.Protocol.Types -- import template haskell +import Data.Text (Text) import Language.Haskell.TH.Syntax (Lift) @@ -140,6 +141,7 @@ data SemanticLog | LogConfig SemanticTokensConfig | LogMsg String | LogNoVF + | LogSemanticTokensDeltaMisMatch Text (Maybe Text) deriving (Show) instance Pretty SemanticLog where @@ -149,4 +151,9 @@ instance Pretty SemanticLog where LogNoVF -> "no VirtualSourceFile exist for file" LogConfig config -> "SemanticTokensConfig_: " <> pretty (show config) LogMsg msg -> "SemanticLog Debug Message: " <> pretty msg + LogSemanticTokensDeltaMisMatch previousIdFromRequest previousIdFromCache + -> "SemanticTokensDeltaMisMatch: previousIdFromRequest: " <> pretty previousIdFromRequest + <> " previousIdFromCache: " <> pretty previousIdFromCache + +type SemanticTokenId = Text diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs index d88f5054cc..52cd56a21f 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/plugins/hls-semantic-tokens-plugin/test/Main.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs similarity index 72% rename from plugins/hls-semantic-tokens-plugin/test/Main.hs rename to plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index d431e54c61..c3862023dd 100644 --- a/plugins/hls-semantic-tokens-plugin/test/Main.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Lens ((^?)) +import Control.Lens ((^.), (^?)) import Control.Monad.IO.Class (liftIO) import Data.Aeson (KeyValue (..), Object) import qualified Data.Aeson.KeyMap as KV @@ -14,6 +15,9 @@ import Data.Text hiding (length, map, import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (Pretty) + +import Data.Row ((.==)) +import Data.Row.Records ((.+)) import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) @@ -22,17 +26,19 @@ import Ide.Plugin.SemanticTokens import Ide.Plugin.SemanticTokens.Mappings import Ide.Plugin.SemanticTokens.Types import Ide.Types -import Language.LSP.Protocol.Types (SemanticTokenTypes (..), - _L) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types import Language.LSP.Test (Session, SessionConfig (ignoreConfigurationRequests), - openDoc) + openDoc, request) import qualified Language.LSP.Test as Test import Language.LSP.VFS (VirtualFile (..)) import System.FilePath -import Test.Hls (PluginTestDescriptor, +import Test.Hls (HasCallStack, + PluginTestDescriptor, + SMethod (SMethod_TextDocumentSemanticTokensFullDelta), TestName, TestTree, - TextDocumentIdentifier, + changeDoc, defaultTestRunner, documentContents, fullCaps, goldenGitDiff, @@ -91,7 +97,7 @@ docSemanticTokensString cf doc = do xs <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc return $ unlines . map show $ xs -docLspSemanticTokensString :: TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes] +docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes] docLspSemanticTokensString doc = do res <- Test.getSemanticTokens doc textContent <- documentContents doc @@ -101,6 +107,18 @@ docLspSemanticTokensString doc = do either (error . show) pure $ recoverLspSemanticTokens vfs tokens _noTokens -> error "No tokens found" + +-- | Pass a param and return the response from `semanticTokensFull` +-- getSemanticTokensFullDelta :: TextDocumentIdentifier -> Session _ +getSemanticTokensFullDelta :: TextDocumentIdentifier -> Text -> Session (SemanticTokens |? (SemanticTokensDelta |? Null)) +getSemanticTokensFullDelta doc lastResultId = do + let params = SemanticTokensDeltaParams Nothing Nothing doc lastResultId + rsp <- request SMethod_TextDocumentSemanticTokensFullDelta params + case rsp ^. L.result of + Right x -> return x + _ -> error "No tokens found" + + semanticTokensClassTests :: TestTree semanticTokensClassTests = testGroup @@ -156,6 +174,57 @@ semanticTokensConfigTest = testGroup "semantic token config test" [ liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" ] +semanticTokensFullDeltaTests :: TestTree +semanticTokensFullDeltaTests = + testGroup "semanticTokensFullDeltaTests" $ + [ testCase "null delta since unchanged" $ do + let file1 = "TModula𐐀bA.hs" + let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [])) + Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do + doc1 <- openDoc file1 "haskell" + _ <- waitForAction "TypeCheck" doc1 + _ <- Test.getSemanticTokens doc1 + delta <- getSemanticTokensFullDelta doc1 "0" + liftIO $ delta @?= expectDelta + + , testCase "add tokens" $ do + let file1 = "TModula𐐀bA.hs" + let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2,0,3,8,0])])) + -- r c l t m + -- where r = row, c = column, l = length, t = token, m = modifier + Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do + doc1 <- openDoc file1 "haskell" + _ <- waitForAction "TypeCheck" doc1 + _ <- Test.getSemanticTokens doc1 + -- open the file and append a line to it + let change = TextDocumentContentChangeEvent + $ InL $ #range .== Range (Position 4 0) (Position 4 6) + .+ #rangeLength .== Nothing + .+ #text .== "foo = 1" + changeDoc doc1 [change] + _ <- waitForAction "TypeCheck" doc1 + delta <- getSemanticTokensFullDelta doc1 "0" + liftIO $ delta @?= expectDelta + + , testCase "remove tokens" $ do + let file1 = "TModula𐐀bA.hs" + let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])])) + -- delete all tokens + Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do + doc1 <- openDoc file1 "haskell" + _ <- waitForAction "TypeCheck" doc1 + _ <- Test.getSemanticTokens doc1 + -- open the file and append a line to it + let change = TextDocumentContentChangeEvent + $ InL $ #range .== Range (Position 2 0) (Position 2 28) + .+ #rangeLength .== Nothing + .+ #text .== Text.replicate 28 " " + changeDoc doc1 [change] + _ <- waitForAction "TypeCheck" doc1 + delta <- getSemanticTokensFullDelta doc1 "0" + liftIO $ delta @?= expectDelta + ] + semanticTokensTests :: TestTree semanticTokensTests = testGroup "other semantic Token test" $ @@ -174,8 +243,6 @@ semanticTokensTests = Right (WaitForIdeRuleResult _) -> return () Left _ -> error "TypeCheck2 failed" - - result <- docSemanticTokensString def doc2 let expect = unlines [ "3:8-18 TModule \"TModula\\66560bA\"" @@ -232,5 +299,6 @@ main = semanticTokensDataTypeTests, semanticTokensValuePatternTests, semanticTokensFunctionTests, - semanticTokensConfigTest + semanticTokensConfigTest, + semanticTokensFullDeltaTests ] From 5126c75610f2cde350a1f906443bccefe19d9c7d Mon Sep 17 00:00:00 2001 From: ktf Date: Wed, 21 Feb 2024 15:05:00 -0800 Subject: [PATCH 19/33] Redundant imports/exports: use range only to determine which code actions are in scope (#4063) * Use *only* incoming range to determine which code actions are in scope Rather than doing a full compare with incoming `Diagnostic` objects from the client. This brings the "remove redundant imports/exports" code actions more in line with behavior described in #4056, and has the pleasant side-effect of fixing broken code actions in neovim (#3857). * Remove redundant imports ;) * Rename param for clarity --------- Co-authored-by: fendor --- .../src/Development/IDE/Plugin/CodeAction.hs | 34 +++++++++++-------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 20a67ad747..b2ed67722f 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -79,14 +79,14 @@ import GHC.Exts (fromList) import qualified GHC.LanguageExtensions as Lang import Ide.Logger hiding (group) -import Ide.PluginUtils (extractTextInRange, +import Ide.PluginUtils (extendToFullLines, + extractTextInRange, subRange) import Ide.Types import Language.LSP.Protocol.Message (Method (..), SMethod (..)) import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (..), CodeAction (..), - CodeActionContext (CodeActionContext, _diagnostics), CodeActionKind (CodeActionKind_QuickFix), CodeActionParams (CodeActionParams), Command, @@ -110,16 +110,16 @@ import Text.Regex.TDFA ((=~), (=~~)) -- | Generate code actions. codeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics= xs}) = do +codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri liftIO $ do let text = virtualFileText <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri - diag <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state + allDiags <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile let - actions = caRemoveRedundantImports parsedModule text diag xs uri - <> caRemoveInvalidExports parsedModule text diag xs uri + actions = caRemoveRedundantImports parsedModule text allDiags range uri + <> caRemoveInvalidExports parsedModule text allDiags range uri pure $ InL actions ------------------------------------------------------------------------------------------------- @@ -438,19 +438,25 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmod = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] | otherwise = [] +diagInRange :: Diagnostic -> Range -> Bool +diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange + where + -- Ensures the range captures full lines. Makes it easier to trigger the correct + -- "remove redundant" code actions from anywhere on the offending line. + extendedRange = extendToFullLines r -- Note [Removing imports is preferred] -- It's good to prefer the remove imports code action because an unused import -- is likely to be removed and less likely the warning will be disabled. -- Therefore actions to remove a single or all redundant imports should be -- preferred, so that the client can prioritize them higher. -caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] -caRemoveRedundantImports m contents digs ctxDigs uri +caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction] +caRemoveRedundantImports m contents allDiags contextRange uri | Just pm <- m, - r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs, + r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) allDiags, allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], caRemoveAll <- removeAll allEdits, - ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs], + ctxEdits <- [ x | x@(d, _) <- r, d `diagInRange` contextRange], not $ null ctxEdits, caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits = caRemoveCtx ++ [caRemoveAll] @@ -474,18 +480,18 @@ caRemoveRedundantImports m contents digs ctxDigs uri _data_ = Nothing _changeAnnotations = Nothing -caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] -caRemoveInvalidExports m contents digs ctxDigs uri +caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction] +caRemoveInvalidExports m contents allDiags contextRange uri | Just pm <- m, Just txt <- contents, txt' <- indexedByPosition $ T.unpack txt, - r <- mapMaybe (groupDiag pm) digs, + r <- mapMaybe (groupDiag pm) allDiags, r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r, caRemoveCtx <- mapMaybe removeSingle r', allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges], allRanges' <- extend txt' allRanges, Just caRemoveAll <- removeAll allRanges', - ctxEdits <- [ x | x@(_, d, _) <- r, d `elem` ctxDigs], + ctxEdits <- [ x | x@(_, d, _) <- r, d `diagInRange` contextRange], not $ null ctxEdits = caRemoveCtx ++ [caRemoveAll] | otherwise = [] From 1fd122e4e43d449d9b21f6299a9e460b9de57e5a Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 23 Feb 2024 14:54:25 +0800 Subject: [PATCH 20/33] revert cacheLookup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 59 +++++++------------ .../test/SemanticTokensTest.hs | 1 - .../test/testdata/TRecordWildCards.expected | 12 ---- .../test/testdata/TRecordWildCards.hs | 7 --- 4 files changed, 22 insertions(+), 57 deletions(-) delete mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.expected delete mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.hs diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs index 568c2c00b9..2ed11be333 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Tokenize.hs @@ -3,12 +3,11 @@ module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where -import Control.Lens (Identity (Identity, runIdentity)) +import Control.Lens (Identity (runIdentity)) import Control.Monad (foldM, guard) import Control.Monad.State.Strict (MonadState (get), MonadTrans (lift), - evalStateT, gets, mapStateT, - modify', put) + evalStateT, modify, put) import Control.Monad.Trans.State.Strict (StateT, runStateT) import Data.Char (isAlphaNum) import Data.DList (DList) @@ -32,25 +31,13 @@ import Prelude hiding (length, span) type Tokenizer m a = StateT PTokenState m a type HsSemanticLookup = Identifier -> Maybe HsSemanticTokenType -type CachedHsSemanticLookup m = Identifier -> Tokenizer m (Maybe HsSemanticTokenType) - -cacheLookup :: (Monad m) => HsSemanticLookup -> CachedHsSemanticLookup m -cacheLookup _ (Left _) = return $ Just TModule -cacheLookup lk idt@(Right n) = do - ne <- gets semanticLookupCache - case lookupNameEnv ne n of - Nothing -> do - let hsSemanticTy = lk idt - modify' (\x -> x{ semanticLookupCache= extendNameEnv ne n hsSemanticTy }) - return hsSemanticTy - Just x -> return x + data PTokenState = PTokenState { - rope :: !Rope -- the remains of rope we are working on - , cursor :: !Char.Position -- the cursor position of the current rope to the start of the original file in code point position - , columnsInUtf16 :: !UInt -- the column of the start of the current rope in utf16 - , semanticLookupCache :: !(NameEnv (Maybe HsSemanticTokenType)) -- the cache for semantic lookup result of the current file + rope :: !Rope -- the remains of rope we are working on + , cursor :: !Char.Position -- the cursor position of the current rope to the start of the original file in code point position + , columnsInUtf16 :: !UInt -- the column of the start of the current rope in utf16 } data SplitResult @@ -62,14 +49,14 @@ getSplitTokenText :: SplitResult -> Text getSplitTokenText (NoSplit (t, _)) = t getSplitTokenText (Split (t, _, _)) = t + mkPTokenState :: VirtualFile -> PTokenState mkPTokenState vf = PTokenState { rope = vf._file_text, cursor = Char.Position 0 0, - columnsInUtf16 = 0, - semanticLookupCache = emptyNameEnv + columnsInUtf16 = 0 } -- lift a Tokenizer Maybe a to Tokenizer m a, @@ -85,15 +72,15 @@ foldMapM f ta = foldM (\b a -> mappend b <$> f a) mempty ta computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast = - RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ evalStateT (foldAst (cacheLookup lookupHsTokenType) ast) (mkPTokenState vf) + RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ evalStateT (foldAst lookupHsTokenType ast) (mkPTokenState vf) -- | foldAst -- visit every leaf node in the ast in depth first order -foldAst :: (Monad m) => CachedHsSemanticLookup Identity -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) +foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) foldAst lookupHsTokenType ast = if null (nodeChildren ast) - then visitLeafIds lookupHsTokenType ast + then liftMaybeM (visitLeafIds lookupHsTokenType ast) else foldMapM (foldAst lookupHsTokenType) $ nodeChildren ast -visitLeafIds :: (Monad m) => CachedHsSemanticLookup Identity -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) +visitLeafIds :: HsSemanticLookup -> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType)) visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do let span = nodeSpan leaf (ran, token) <- focusTokenAt leaf @@ -103,23 +90,21 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do -- only handle the leaf node with single column token guard $ srcSpanStartLine span == srcSpanEndLine span splitResult <- lift $ splitRangeByText token ran - mapStateT hoistIdMaybe - $ foldMapM (combineNodeIds lookupHsTokenType ran splitResult) - $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf + foldMapM (combineNodeIds lookupHsTokenType ran splitResult) $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf where - hoistIdMaybe :: Identity (a, s) -> Maybe (a, s) - hoistIdMaybe (Identity x) = Just x - combineNodeIds :: CachedHsSemanticLookup Identity -> Range -> SplitResult -> NodeInfo a -> Tokenizer Identity (DList (Range, HsSemanticTokenType)) - combineNodeIds lookupHsTokenType ran ranSplit (NodeInfo _ _ bd) = do - maybeTokenType <- foldMapM (maybe (return Nothing) lookupHsTokenType . getIdentifier ranSplit) (M.keys bd) + combineNodeIds :: (Monad m) => HsSemanticLookup -> Range -> SplitResult -> NodeInfo a -> Tokenizer m (DList (Range, HsSemanticTokenType)) + combineNodeIds lookupHsTokenType ran ranSplit (NodeInfo _ _ bd) = case (maybeTokenType, ranSplit) of (Nothing, _) -> return mempty (Just TModule, _) -> return $ DL.singleton (ran, TModule) (Just tokenType, NoSplit (_, tokenRan)) -> return $ DL.singleton (tokenRan, tokenType) (Just tokenType, Split (_, ranPrefix, tokenRan)) -> return $ DL.fromList [(ranPrefix, TModule),(tokenRan, tokenType)] - getIdentifier ranSplit idt = do + where maybeTokenType = foldMap (getIdentifier lookupHsTokenType ranSplit) (M.keys bd) + + getIdentifier :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType + getIdentifier lookupHsTokenType ranSplit idt = do case idt of - Left _moduleName -> Just idt + Left _moduleName -> Just TModule Right name -> do occStr <- T.pack <$> case (occNameString . nameOccName) name of -- the generated selector name with {-# LANGUAGE DuplicateRecordFields #-} @@ -129,7 +114,7 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do c : ':' : _ | isAlphaNum c -> Nothing ns -> Just ns guard $ getSplitTokenText ranSplit == occStr - return idt + lookupHsTokenType idt focusTokenAt :: @@ -153,7 +138,7 @@ focusTokenAt leaf = do let nce = newColumn ncs token -- compute the new range for utf16, tuning the columns is enough let ran = codePointRangeToRangeWith ncs nce $ realSrcSpanToCodePointRange span - modify' $ \s -> s {columnsInUtf16 = nce, rope = remains, cursor = tokenEndPos} + modify $ \s -> s {columnsInUtf16 = nce, rope = remains, cursor = tokenEndPos} return (ran, token) where srcSpanCharPositions :: RealSrcSpan -> (Char.Position, Char.Position) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index c3862023dd..0917b19a2d 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -270,7 +270,6 @@ semanticTokensDataTypeTests = "get semantic Tokens" [ goldenWithSemanticTokensWithDefaultConfig "simple datatype" "TDataType", goldenWithSemanticTokensWithDefaultConfig "record" "TRecord", - goldenWithSemanticTokensWithDefaultConfig "TRecordWildCards" "TRecordWildCards", goldenWithSemanticTokensWithDefaultConfig "record With DuplicateRecordFields" "TRecordDuplicateRecordFields", goldenWithSemanticTokensWithDefaultConfig "datatype import" "TDatatypeImported", goldenWithSemanticTokensWithDefaultConfig "datatype family" "TDataFamily", diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.expected deleted file mode 100644 index 4853159c44..0000000000 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.expected +++ /dev/null @@ -1,12 +0,0 @@ -4:6-9 TTypeConstructor "Foo" -4:12-15 TDataConstructor "Foo" -4:18-21 TRecordField "foo" -4:25-28 TTypeConstructor "Int" -5:1-5 TVariable "foo1" -5:8-11 TDataConstructor "Foo" -6:1-10 TFunction "unpackFoo" -6:14-17 TTypeConstructor "Foo" -6:21-24 TTypeConstructor "Int" -7:1-10 TFunction "unpackFoo" -7:11-14 TDataConstructor "Foo" -7:21-24 TVariable "foo" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.hs deleted file mode 100644 index f2a68a44aa..0000000000 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordWildCards.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module TRecordWildCards where - -data Foo = Foo { foo :: Int } -foo1 = Foo 1 -unpackFoo :: Foo -> Int -unpackFoo Foo{..} = foo From fd812cfb3b6fe09f6fee69d762d985207a458231 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 23 Feb 2024 14:54:58 +0800 Subject: [PATCH 21/33] cleanup --- hls-graph/src/Development/IDE/Graph/Internal/Action.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index c855ac78a2..ad9d0e711f 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -114,7 +114,6 @@ actionFinally a b = do apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value apply1 k = runIdentity <$> apply (Identity k) --- todo make the result ordered apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value) apply ks = do db <- Action $ asks actionDatabase From bbe1be6fb8931d49aa0989fe45e6050a6987b1b8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 23 Feb 2024 15:05:33 +0800 Subject: [PATCH 22/33] update doc --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 1dd1e887c2..b9233ede88 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -136,6 +136,12 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do isDirty :: Foldable t => Result -> t (a, Result) -> Bool isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) +-- | Refresh dependencies for a key: +-- The deps refresh is kicking up linearly. If any of the deps are dirty in the process, +-- we jump to the actual computation of the key and shortcut the refreshing the rest of the deps. +-- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. +-- This assumes that the implementation will be a lookup +-- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result) refreshDeps visited db stack key result = \case -- no more deps to refresh @@ -156,9 +162,6 @@ refreshDeps visited db stack key result = \case else join $ runAIO $ refreshDeps newVisited db stack key result deps -- | Refresh a key: --- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. --- This assumes that the implementation will be a lookup --- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result) -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined refresh db stack key result = case (addStack key stack, result) of From 0bd4a20feda32259874b7e0776005664ff5dbd42 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 23 Feb 2024 17:12:26 +0800 Subject: [PATCH 23/33] use strict modifyIORef' --- hls-graph/src/Development/IDE/Graph/Internal/Action.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index ad9d0e711f..56cc4755c8 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -38,7 +38,7 @@ type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a) alwaysRerun :: Action () alwaysRerun = do ref <- Action $ asks actionDeps - liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>) + liftIO $ modifyIORef' ref (AlwaysRerunDeps mempty <>) -- No-op for now reschedule :: Double -> Action () @@ -120,7 +120,7 @@ apply ks = do stack <- Action $ asks actionStack (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps - liftIO $ modifyIORef ref (ResultDeps [fromListKeySet $ toList is] <>) + liftIO $ modifyIORef' ref (ResultDeps [fromListKeySet $ toList is] <>) pure vs -- | Evaluate a list of keys without recording any dependencies. From c580ff540b574067b93e81b660b6640f0451e636 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 23 Feb 2024 17:24:22 +0800 Subject: [PATCH 24/33] fix doc --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index b9233ede88..cb573672fc 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -136,7 +136,7 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do isDirty :: Foldable t => Result -> t (a, Result) -> Bool isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) --- | Refresh dependencies for a key: +-- | Refresh dependencies for a key and compute the key: -- The deps refresh is kicking up linearly. If any of the deps are dirty in the process, -- we jump to the actual computation of the key and shortcut the refreshing the rest of the deps. -- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. From 888e249ae4ebf504d6ae183e2a95d3a5cc5981ce Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 23 Feb 2024 18:51:41 +0800 Subject: [PATCH 25/33] add test to prevent phantom dependencies --- hls-graph/test/ActionSpec.hs | 32 ++++++++++++++++++++++++++++---- hls-graph/test/Example.hs | 35 +++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 4 deletions(-) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index d2f1fe577f..6218427797 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -3,15 +3,17 @@ module ActionSpec where +import qualified Control.Concurrent as C import Control.Concurrent.STM -import Development.IDE.Graph (shakeOptions) -import Development.IDE.Graph.Database (shakeNewDatabase, - shakeRunDatabase) +import Development.IDE.Graph (shakeOptions) +import Development.IDE.Graph.Database (shakeNewDatabase, + shakeRunDatabase) +import Development.IDE.Graph.Internal.Database (build, incDatabase) import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule import Example -import qualified StmContainers.Map as STM +import qualified StmContainers.Map as STM import Test.Hspec spec :: Spec @@ -57,6 +59,28 @@ spec = do addRule $ \(Rule :: Rule ()) _old _mode -> error "boom" let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) res `shouldThrow` anyErrorCall + it "computes a rule with branching dependencies does not invoke phantom dependencies #3423" $ do + cond <- C.newMVar True + count <- C.newMVar 0 + (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + ruleUnit + ruleCond cond + ruleSubBranch count + ruleWithCond + -- build the one with the condition True + -- This should call the SubBranchRule once + -- cond rule would return different results each time + res0 <- build theDb emptyStack [BranchedRule] + snd res0 `shouldBe` [1 :: Int] + incDatabase theDb Nothing + -- build the one with the condition False + -- This should not call the SubBranchRule + res1 <- build theDb emptyStack [BranchedRule] + snd res1 `shouldBe` [2 :: Int] + -- SubBranchRule should be recomputed one before this (when the condition was True) + countRes <- build theDb emptyStack [SubBranchRule] + snd countRes `shouldBe` [1 :: Int] + describe "applyWithoutDependency" $ do it "does not track dependencies" $ do db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index 1a897fc174..2845b60e6c 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -4,6 +4,8 @@ {-# LANGUAGE TypeFamilies #-} module Example where +import qualified Control.Concurrent as C +import Control.Monad.IO.Class (liftIO) import Development.IDE.Graph import Development.IDE.Graph.Classes import Development.IDE.Graph.Rule @@ -27,3 +29,36 @@ ruleBool :: Rules () ruleBool = addRule $ \Rule _old _mode -> do () <- apply1 Rule return $ RunResult ChangedRecomputeDiff "" True + + +data CondRule = CondRule + deriving (Eq, Generic, Hashable, NFData, Show, Typeable) +type instance RuleResult CondRule = Bool + + +ruleCond :: C.MVar Bool -> Rules () +ruleCond mv = addRule $ \CondRule _old _mode -> do + r <- liftIO $ C.modifyMVar mv $ \x -> return (not x, x) + return $ RunResult ChangedRecomputeDiff "" r + +data BranchedRule = BranchedRule + deriving (Eq, Generic, Hashable, NFData, Show, Typeable) +type instance RuleResult BranchedRule = Int + +ruleWithCond :: Rules () +ruleWithCond = addRule $ \BranchedRule _old _mode -> do + r <- apply1 CondRule + if r then do + _ <- apply1 SubBranchRule + return $ RunResult ChangedRecomputeDiff "" (1 :: Int) + else + return $ RunResult ChangedRecomputeDiff "" (2 :: Int) + +data SubBranchRule = SubBranchRule + deriving (Eq, Generic, Hashable, NFData, Show, Typeable) +type instance RuleResult SubBranchRule = Int + +ruleSubBranch :: C.MVar Int -> Rules () +ruleSubBranch mv = addRule $ \SubBranchRule _old _mode -> do + r <- liftIO $ C.modifyMVar mv $ \x -> return (x+1, x) + return $ RunResult ChangedRecomputeDiff "" r From aeeb1beea6f8866cb1aef1bfc2040f6d517f94e3 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 24 Feb 2024 16:36:56 +0800 Subject: [PATCH 26/33] Update ActionSpec.hs Co-authored-by: Jan Hrcek <2716069+jhrcek@users.noreply.github.com> --- hls-graph/test/ActionSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 6218427797..ffb319c614 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -77,7 +77,7 @@ spec = do -- This should not call the SubBranchRule res1 <- build theDb emptyStack [BranchedRule] snd res1 `shouldBe` [2 :: Int] - -- SubBranchRule should be recomputed one before this (when the condition was True) + -- SubBranchRule should be recomputed once before this (when the condition was True) countRes <- build theDb emptyStack [SubBranchRule] snd countRes `shouldBe` [1 :: Int] From 451e7ce364e82adcf0c306cfcc72df679095f647 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 24 Feb 2024 16:37:27 +0800 Subject: [PATCH 27/33] Update Experiments.hs Co-authored-by: Jan Hrcek <2716069+jhrcek@users.noreply.github.com> --- ghcide-bench/src/Experiments.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index b9b7613e6d..8a4062aaf1 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -104,7 +104,7 @@ experiments = [ bench "semanticTokens" $ \docs -> do liftIO $ putStrLn "Starting semanticTokens" - r <- forM (zip [T.pack $ show i | i :: Int <- [0..]] docs) $ \(i, DocumentPositions{..}) -> do + r <- forM docs $ \DocumentPositions{..} -> do changeDoc doc [charEdit stringLiteralP] waitForProgressStart waitForProgressDone From cf3725397c836477b8dcb4c95ef56c41a2799150 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 26 Feb 2024 04:08:28 +0800 Subject: [PATCH 28/33] rephrase comment --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index cb573672fc..106f4002e8 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -137,8 +137,9 @@ isDirty :: Foldable t => Result -> t (a, Result) -> Bool isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) -- | Refresh dependencies for a key and compute the key: --- The deps refresh is kicking up linearly. If any of the deps are dirty in the process, --- we jump to the actual computation of the key and shortcut the refreshing the rest of the deps. +-- The refresh the deps linearly(last computed order of the deps for the key). +-- If any of the deps is dirty in the process, we jump to the actual computation of the key +-- and shortcut the refreshing of the rest of the deps. -- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. -- This assumes that the implementation will be a lookup -- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself From 69d1dade4497e6af50b071f9173d4575885540b2 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 26 Feb 2024 05:11:02 +0800 Subject: [PATCH 29/33] Update config.yaml --- bench/config.yaml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/bench/config.yaml b/bench/config.yaml index 34ce8710e5..6f2f5543d2 100644 --- a/bench/config.yaml +++ b/bench/config.yaml @@ -23,10 +23,10 @@ examples: package: Cabal version: 3.6.3.0 modules: - # - src/Distribution/Simple.hs - # - src/Distribution/Types/Module.hs - - src/Distribution/Simple/Configure.hs - - src/Distribution/Simple/BuildTarget.hs + - src/Distribution/Simple.hs + - src/Distribution/Types/Module.hs + #- src/Distribution/Simple/Configure.hs + #- src/Distribution/Simple/BuildTarget.hs extra-args: [] # extra HLS command line args # Small-sized project with TH - name: lsp-types From 95a42f0b0367c7ffad4af5a28ee1c0d924d65f44 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 26 Feb 2024 18:28:26 +0800 Subject: [PATCH 30/33] recover AlwaysRerunDeps --- hls-graph/src/Development/IDE/Graph/Database.hs | 2 +- .../src/Development/IDE/Graph/Internal/Database.hs | 4 ++-- .../src/Development/IDE/Graph/Internal/Profile.hs | 4 ++-- .../src/Development/IDE/Graph/Internal/Types.hs | 14 +++++++++----- 4 files changed, 14 insertions(+), 10 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index fc30052f84..6eb67bacc2 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -78,7 +78,7 @@ shakeGetBuildEdges :: ShakeDatabase -> IO Int shakeGetBuildEdges (ShakeDatabase _ _ db) = do keys <- getDatabaseValues db let ress = mapMaybe (getResult . snd) keys - return $ sum $ map (lengthKeySet . fold . getResultDepsDefault mempty . resultDeps) ress + return $ sum $ map (lengthKeySet . getResultDepsDefault mempty . resultDeps) ress -- | Returns an approximation of the database keys, -- annotated with how long ago (in # builds) they were visited diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 106f4002e8..76004c0e7f 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -187,7 +187,7 @@ compute db@Database{..} stack key 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 fold $ getResultDepsDefault mempty actualDeps of + case getResultDepsDefault mempty actualDeps of deps | not (nullKeySet deps) && runChanged /= ChangedNothing -> do @@ -197,7 +197,7 @@ compute db@Database{..} stack key mode result = do -- on the next build. void $ updateReverseDeps key db - (fold $ getResultDepsDefault mempty previousDeps) + (getResultDepsDefault mempty previousDeps) deps _ -> pure () atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index b657f002fd..01a6d803fc 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -109,7 +109,7 @@ toReport :: Database -> IO ([ProfileEntry], KeyMap Int) toReport db = do status <- prepareForDependencyOrder db let order = dependencyOrder show - $ map (second (toListKeySet . fold . getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") . resultDeps)) + $ map (second (toListKeySet . getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") . resultDeps)) $ toListKeyMap status ids = fromListKeyMap $ zip order [0..] @@ -122,7 +122,7 @@ toReport db = do ,prfBuilt = fromStep resultBuilt ,prfVisited = fromStep resultVisited ,prfChanged = fromStep resultChanged - ,prfDepends = map pure $ elemsKeyMap $ restrictKeysKeyMap ids $ fold $ getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") resultDeps + ,prfDepends = map pure $ elemsKeyMap $ restrictKeysKeyMap ids $ getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") resultDeps ,prfExecution = resultExecution } where fromStep i = fromJust $ Map.lookup i steps diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index c95fe5319a..a6d9d3f81c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -12,6 +12,7 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Bifunctor (second) import qualified Data.ByteString as BS import Data.Dynamic +import Data.Foldable (fold) import qualified Data.HashMap.Strict as Map import Data.IORef import Data.List (intercalate) @@ -144,17 +145,20 @@ data Result = Result { resultData :: !BS.ByteString } -data ResultDeps = UnknownDeps | AlwaysRerunDeps ![KeySet] | ResultDeps ![KeySet] +-- some invariant to maintain: +-- the ResultDeps need to be stored in reverse order, +-- so that we can append to it efficiently +data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps ![KeySet] deriving (Eq, Show) -getResultDepsDefault :: KeySet -> ResultDeps -> [KeySet] -getResultDepsDefault _ (ResultDeps ids) = ids +getResultDepsDefault :: KeySet -> ResultDeps -> KeySet +getResultDepsDefault _ (ResultDeps ids) = fold ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids -getResultDepsDefault def UnknownDeps = [def] +getResultDepsDefault def UnknownDeps = def mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps mapResultDeps f (ResultDeps ids) = ResultDeps $ fmap f ids -mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ fmap f ids +mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids mapResultDeps _ UnknownDeps = UnknownDeps instance Semigroup ResultDeps where From 4a1a52e13ecaa75903cfc06010ae67047017dc58 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 26 Feb 2024 18:37:32 +0800 Subject: [PATCH 31/33] rephrase comment --- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index a6d9d3f81c..02b5ccd4b0 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -145,9 +145,10 @@ data Result = Result { resultData :: !BS.ByteString } --- some invariant to maintain: --- the ResultDeps need to be stored in reverse order, --- so that we can append to it efficiently +-- Notice, invariant to maintain: +-- the ![KeySet] in ResultDeps need to be stored in reverse order, +-- so that we can append to it efficiently, and we need the ordering +-- so we can do a linear dependency refreshing in refreshDeps. data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps ![KeySet] deriving (Eq, Show) From af2bdfb775d7f571c164dce8569777ee6771882c Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 26 Feb 2024 19:31:58 +0800 Subject: [PATCH 32/33] force KeySet before adding to the ResultDeps --- hls-graph/src/Development/IDE/Graph/Internal/Action.hs | 3 ++- hls-graph/src/Development/IDE/Graph/Internal/Key.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 56cc4755c8..9abb2999fd 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -18,6 +18,7 @@ module Development.IDE.Graph.Internal.Action ) where import Control.Concurrent.Async +import Control.DeepSeq (force) import Control.Exception import Control.Monad.IO.Class import Control.Monad.Trans.Class @@ -120,7 +121,7 @@ apply ks = do stack <- Action $ asks actionStack (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps - liftIO $ modifyIORef' ref (ResultDeps [fromListKeySet $ toList is] <>) + liftIO $ modifyIORef' ref (ResultDeps [force $ fromListKeySet $ toList is] <>) pure vs -- | Evaluate a list of keys without recording any dependencies. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs index 1d9010d53b..ba303cdb99 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs @@ -101,7 +101,7 @@ renderKey :: Key -> Text renderKey (lookupKeyValue -> KeyValue _ t) = t newtype KeySet = KeySet IntSet - deriving newtype (Eq, Ord, Semigroup, Monoid) + deriving newtype (Eq, Ord, Semigroup, Monoid, NFData) instance Show KeySet where showsPrec p (KeySet is)= showParen (p > 10) $ From 9b72bf0c6b06794f29f38376d20d79f7aea6c933 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 26 Feb 2024 19:51:10 +0800 Subject: [PATCH 33/33] use bang pattern to force --- hls-graph/src/Development/IDE/Graph/Internal/Action.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 9abb2999fd..6c26e9c024 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -121,7 +121,8 @@ apply ks = do stack <- Action $ asks actionStack (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps - liftIO $ modifyIORef' ref (ResultDeps [force $ fromListKeySet $ toList is] <>) + let !ks = force $ fromListKeySet $ toList is + liftIO $ modifyIORef' ref (ResultDeps [ks] <>) pure vs -- | Evaluate a list of keys without recording any dependencies.