From d24e86971f7e442ec2500aca1c816167cf6c656f Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 5 Feb 2024 01:34:56 +0800 Subject: [PATCH 01/13] optimize extraction logic --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 28 ++---- .../src/Ide/Plugin/SemanticTokens/Query.hs | 41 +++++---- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 89 +++++++++++-------- .../src/Ide/Plugin/SemanticTokens/Types.hs | 12 ++- 4 files changed, 88 insertions(+), 82 deletions(-) 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 7d2f37adac..980040c77f 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 @@ -48,7 +48,7 @@ import Ide.Plugin.Error (PluginError (PluginIn import Ide.Plugin.SemanticTokens.Mappings import Ide.Plugin.SemanticTokens.Query import Ide.Plugin.SemanticTokens.SemanticConfig (mkSemanticConfigFunctions) -import Ide.Plugin.SemanticTokens.Tokenize (hieAstSpanIdentifiers) +import Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) import Ide.Plugin.SemanticTokens.Types import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -69,8 +69,8 @@ computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeS computeSemanticTokens recorder pid _ nfp = do config <- lift $ useSemanticConfigAction pid logWith recorder Debug (LogConfig config) - (RangeHsSemanticTokenTypes {rangeSemanticMap}, mapping) <- useWithStaleE GetSemanticTokens nfp - withExceptT PluginInternalError $ liftEither $ rangeSemanticMapSemanticTokens config mapping rangeSemanticMap + (RangeHsSemanticTokenTypes {rangeSemantic}, mapping) <- useWithStaleE GetSemanticTokens nfp + withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens config mapping rangeSemantic semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull semanticTokensFull recorder state pid param = do @@ -96,26 +96,8 @@ getSemanticTokensRule recorder = (DKMap {getTyThingMap}, _) <- lift $ useWithStale_ GetDocMap nfp ast <- handleMaybe (LogNoAST $ show nfp) $ getAsts hieAst M.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp virtualFile <- handleMaybeM LogNoVF $ getVirtualFile nfp - -- get current location from the old ones - let spanIdMap = M.filter (not . null) $ hieAstSpanIdentifiers virtualFile ast - let names = S.unions $ M.elems spanIdMap - let localSemanticMap = mkLocalIdSemanticFromAst names (hieKindFunMasksKind hieKind) refMap - -- get imported name semantic map - let importedIdSemanticMap = M.mapMaybe id - $ M.fromSet (getTypeThing getTyThingMap) (names `S.difference` M.keysSet localSemanticMap) - let sMap = M.unionWith (<>) importedIdSemanticMap localSemanticMap - let rangeTokenType = extractSemanticTokensFromNames sMap spanIdMap - return $ RangeHsSemanticTokenTypes rangeTokenType - where - getTypeThing :: - NameEnv TyThing -> - Identifier -> - Maybe HsSemanticTokenType - getTypeThing tyThingMap n - | (Right name) <- n = - let tyThing = lookupNameEnv tyThingMap name - in (tyThing >>= tyThingSemantic) - | otherwise = Nothing + 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 () 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 c9d1d060d0..e5301260a1 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 @@ -5,10 +5,10 @@ -- The query module is used to query the semantic tokens from the AST module Ide.Plugin.SemanticTokens.Query where +import Control.Applicative ((<|>)) import Data.Foldable (fold) import qualified Data.Map.Strict as M import Data.Maybe (listToMaybe, mapMaybe) -import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import Development.IDE.Core.PositionMapping (PositionMapping, @@ -17,8 +17,7 @@ import Development.IDE.GHC.Compat import Ide.Plugin.SemanticTokens.Mappings import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind, HsSemanticTokenType (TModule), - IdSemanticMap, - RangeIdSetMap, + RangeSemanticTokenTypeList, SemanticTokensConfig) import Language.LSP.Protocol.Types (Position (Position), Range (Range), @@ -30,24 +29,33 @@ import Prelude hiding (length, span) --------------------------------------------------------- --- * extract semantic map from HieAst for local variables +-- * extract semantic --------------------------------------------------------- -mkLocalIdSemanticFromAst :: Set Identifier -> HieFunMaskKind a -> RefMap a -> IdSemanticMap -mkLocalIdSemanticFromAst names hieKind rm = M.mapMaybe (idIdSemanticFromHie hieKind rm) $ M.fromSet id names +idSemantic :: forall a. NameEnv TyThing -> HieFunMaskKind a -> RefMap a -> Identifier -> Maybe HsSemanticTokenType +idSemantic _ _ _ (Left _) = Just TModule +idSemantic tyThingMap hieKind rm (Right n) = + nameSemanticFromHie hieKind rm n -- local name + <|> (lookupNameEnv tyThingMap n >>= tyThingSemantic) -- global name -idIdSemanticFromHie :: forall a. HieFunMaskKind a -> RefMap a -> Identifier -> Maybe HsSemanticTokenType -idIdSemanticFromHie _ _ (Left _) = Just TModule -idIdSemanticFromHie hieKind rm ns = do - idSemanticFromRefMap rm ns + +--------------------------------------------------------- + +-- * extract semantic from HieAst for local variables + +--------------------------------------------------------- + +nameSemanticFromHie :: forall a. HieFunMaskKind a -> RefMap a -> Name -> Maybe HsSemanticTokenType +nameSemanticFromHie hieKind rm n = do + idSemanticFromRefMap rm (Right n) where idSemanticFromRefMap :: RefMap a -> Identifier -> Maybe HsSemanticTokenType idSemanticFromRefMap rm' name' = do spanInfos <- M.lookup name' rm' let typeTokenType = foldMap (typeSemantic hieKind) $ listToMaybe $ mapMaybe (identType . snd) spanInfos contextInfoTokenType <- foldMap (contextInfosMaybeTokenType . identInfo . snd) spanInfos - fold [typeTokenType, Just contextInfoTokenType, idInfixOperator ns] + fold [typeTokenType, Just contextInfoTokenType, nameInfixOperator n] contextInfosMaybeTokenType :: Set.Set ContextInfo -> Maybe HsSemanticTokenType contextInfosMaybeTokenType details = foldMap infoTokenType (Set.toList details) @@ -59,15 +67,10 @@ idIdSemanticFromHie hieKind rm ns = do ------------------------------------------------- -extractSemanticTokensFromNames :: IdSemanticMap -> RangeIdSetMap -> M.Map Range HsSemanticTokenType -extractSemanticTokensFromNames nsm = M.mapMaybe (foldMap (`M.lookup` nsm)) - -rangeSemanticMapSemanticTokens :: SemanticTokensConfig -> PositionMapping -> M.Map Range HsSemanticTokenType -> Either Text SemanticTokens -rangeSemanticMapSemanticTokens stc mapping = +rangeSemanticsSemanticTokens :: SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens +rangeSemanticsSemanticTokens stc mapping = makeSemanticTokens defaultSemanticTokensLegend - . mapMaybe (\(range, ty) -> flip toAbsSemanticToken ty <$> range) - . M.toAscList - . M.mapKeys (toCurrentRange mapping) + . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk) where toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType = 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 4718fd6458..4f7237cadf 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,18 +1,17 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -module Ide.Plugin.SemanticTokens.Tokenize (hieAstSpanIdentifiers) where +module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where import Control.Lens (Identity (runIdentity)) import Control.Monad (forM_, guard) import Control.Monad.State.Strict (MonadState (get), MonadTrans (lift), execStateT, modify, put) -import Control.Monad.Trans.State.Strict (StateT) +import Control.Monad.Trans.State.Strict (StateT, modify') import Data.Char (isAlphaNum) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map -import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Rope as Char @@ -22,42 +21,50 @@ import Data.Text.Utf16.Rope.Mixed (Rope) import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (realSrcSpanToCodePointRange) -import Ide.Plugin.SemanticTokens.Types (RangeIdSetMap) +import Ide.Plugin.SemanticTokens.Types (HsSemanticTokenType (TModule), + RangeHsSemanticTokenTypes (..)) import Language.LSP.Protocol.Types (Position (Position), Range (Range), UInt, mkRange) import Language.LSP.VFS hiding (line) import Prelude hiding (length, span) type Tokenizer m a = StateT PTokenState m a +type HsSemanticLookup = Identifier -> Maybe HsSemanticTokenType data PTokenState = PTokenState - { rangeIdSetMap :: !RangeIdSetMap, - 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 + , rangeHsSemanticList :: [(Range, HsSemanticTokenType)] -- (range, token type) in reverse order } -runTokenizer :: (Monad m) => Tokenizer m a -> PTokenState -> m RangeIdSetMap -runTokenizer p st = rangeIdSetMap <$> execStateT p st +runTokenizer :: (Monad m) => Tokenizer m a -> PTokenState -> m [(Range, HsSemanticTokenType)] +runTokenizer p st = reverse . rangeHsSemanticList <$> execStateT p st data SplitResult = NoSplit (Text, Range) -- does not need to split, token text, token range | Split (Text, Range, Range) -- token text, prefix range(module range), token range deriving (Show) +getSplitTokenText :: SplitResult -> Text +getSplitTokenText (NoSplit (t, _)) = t +getSplitTokenText (Split (t, _, _)) = t + mkPTokenState :: VirtualFile -> PTokenState mkPTokenState vf = PTokenState - { rangeIdSetMap = mempty, + { rope = Rope.fromText $ toText vf._file_text, cursor = Char.Position 0 0, - columnsInUtf16 = 0 + columnsInUtf16 = 0, + rangeHsSemanticList = [] } -addRangeIdSetMap :: (Monad m) => Range -> Identifier -> Tokenizer m () -addRangeIdSetMap r i = modify $ \s -> s {rangeIdSetMap = Map.insertWith (<>) r (S.singleton i) $ rangeIdSetMap s} +addRangeHsSemanticList :: (Monad m) => (Range, HsSemanticTokenType) -> Tokenizer m () +addRangeHsSemanticList r = modify' $ \s -> s {rangeHsSemanticList = r : rangeHsSemanticList s} -- lift a Tokenizer Maybe () to Tokenizer m (), -- if the Maybe is Nothing, do nothing, recover the state @@ -67,18 +74,19 @@ liftMaybeM p = do st <- get forM_ (execStateT p st) put -hieAstSpanIdentifiers :: VirtualFile -> HieAST a -> RangeIdSetMap -hieAstSpanIdentifiers vf ast = runIdentity $ runTokenizer (foldAst ast) (mkPTokenState vf) +computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes +computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast = + RangeHsSemanticTokenTypes $ runIdentity $ runTokenizer (foldAst lookupHsTokenType ast) (mkPTokenState vf) -- | foldAst -- visit every leaf node in the ast in depth first order -foldAst :: (Monad m) => HieAST t -> Tokenizer m () -foldAst ast = if null (nodeChildren ast) - then liftMaybeM (visitLeafIds ast) - else mapM_ foldAst $ nodeChildren ast +foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m () +foldAst lookupHsTokenType ast = if null (nodeChildren ast) + then liftMaybeM (visitLeafIds lookupHsTokenType ast) + else mapM_ (foldAst lookupHsTokenType) $ nodeChildren ast -visitLeafIds :: HieAST t -> Tokenizer Maybe () -visitLeafIds leaf = liftMaybeM $ do +visitLeafIds :: HsSemanticLookup -> HieAST t -> Tokenizer Maybe () +visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do let span = nodeSpan leaf (ran, token) <- focusTokenAt leaf -- if `focusTokenAt` succeed, we can safely assume we have shift the cursor correctly @@ -87,30 +95,37 @@ visitLeafIds leaf = liftMaybeM $ do -- only handle the leaf node with single column token guard $ srcSpanStartLine span == srcSpanEndLine span splitResult <- lift $ splitRangeByText token ran - mapM_ (combineNodeIds ran splitResult) $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf + mapM_ (combineNodeIds lookupHsTokenType ran splitResult) $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf where - combineNodeIds :: (Monad m) => Range -> SplitResult -> NodeInfo a -> Tokenizer m () - combineNodeIds ran ranSplit (NodeInfo _ _ bd) = mapM_ (getIdentifier ran ranSplit) (M.keys bd) - getIdentifier :: (Monad m) => Range -> SplitResult -> Identifier -> Tokenizer m () - getIdentifier ran ranSplit idt = liftMaybeM $ do + combineNodeIds :: (Monad m) => HsSemanticLookup -> Range -> SplitResult -> NodeInfo a -> Tokenizer m () + combineNodeIds lookupHsTokenType ran ranSplit (NodeInfo _ _ bd) = + case (maybeTokenType, ranSplit) of + (Nothing, _) -> return () + (Just TModule, _) -> addRangeHsSemanticList (ran, TModule) + (Just tokenType, NoSplit (_, tokenRan)) -> addRangeHsSemanticList (tokenRan, tokenType) + (Just tokenType, Split (_, ranPrefix, tokenRan)) -> do + addRangeHsSemanticList (ranPrefix, TModule) + addRangeHsSemanticList (tokenRan, tokenType) + where + maybeTokenType = foldMap (getIdentifier lookupHsTokenType ranSplit) (M.keys bd) + + -- takeHsSemanticType :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType + + getIdentifier :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType + getIdentifier lookupHsTokenType ranSplit idt = do case idt of - Left _moduleName -> addRangeIdSetMap ran idt + Left _moduleName -> Just TModule Right name -> do - occStr <- lift $ T.pack <$> case (occNameString . nameOccName) name of + occStr <- T.pack <$> case (occNameString . nameOccName) name of -- the generated selector name with {-# LANGUAGE DuplicateRecordFields #-} '$' : 's' : 'e' : 'l' : ':' : xs -> Just $ takeWhile (/= ':') xs -- other generated names that should not be visible '$' : c : _ | isAlphaNum c -> Nothing c : ':' : _ | isAlphaNum c -> Nothing ns -> Just ns - case ranSplit of - (NoSplit (tk, r)) -> do - guard $ tk == occStr - addRangeIdSetMap r idt - (Split (tk, r1, r2)) -> do - guard $ tk == occStr - addRangeIdSetMap r1 (Left $ mkModuleName "") - addRangeIdSetMap r2 idt + guard $ getSplitTokenText ranSplit == occStr + lookupHsTokenType idt + focusTokenAt :: -- | leaf node we want to focus on 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 bf4b6f4add..90e839c4bd 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 @@ -11,7 +11,6 @@ import Control.DeepSeq (NFData (rnf), rwhnf) import qualified Data.Array as A import Data.Default (Default (def)) import Data.Generics (Typeable) -import qualified Data.Map.Strict as M import Development.IDE (Pretty (pretty), RuleResult) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (loc) @@ -119,14 +118,21 @@ instance Hashable GetSemanticTokens instance NFData GetSemanticTokens -newtype RangeHsSemanticTokenTypes = RangeHsSemanticTokenTypes {rangeSemanticMap :: M.Map Range HsSemanticTokenType} +type RangeSemanticTokenTypeList = [(Range, HsSemanticTokenType)] + +newtype RangeHsSemanticTokenTypes = RangeHsSemanticTokenTypes {rangeSemantic :: RangeSemanticTokenTypeList} instance NFData RangeHsSemanticTokenTypes where rnf :: RangeHsSemanticTokenTypes -> () rnf (RangeHsSemanticTokenTypes a) = rwhnf a instance Show RangeHsSemanticTokenTypes where - show = const "RangeHsSemanticTokenTypes" + show (RangeHsSemanticTokenTypes xs) = unlines $ map showRangeToken xs + +showRangeToken :: (Range, HsSemanticTokenType) -> String +showRangeToken (ran, tk) = showRange ran <> " " <> show tk +showRange :: Range -> String +showRange (Range (Position l1 c1) (Position l2 c2)) = show l1 <> ":" <> show c1 <> "-" <> show l2 <> ":" <> show c2 type instance RuleResult GetSemanticTokens = RangeHsSemanticTokenTypes From 034341c099b0e210f6117d92af2cacdc0dcffb21 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 5 Feb 2024 01:43:17 +0800 Subject: [PATCH 02/13] rename --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 4 ++-- .../src/Ide/Plugin/SemanticTokens/Types.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) 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 980040c77f..6289482714 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 @@ -69,8 +69,8 @@ computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeS computeSemanticTokens recorder pid _ nfp = do config <- lift $ useSemanticConfigAction pid logWith recorder Debug (LogConfig config) - (RangeHsSemanticTokenTypes {rangeSemantic}, mapping) <- useWithStaleE GetSemanticTokens nfp - withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens config mapping rangeSemantic + (RangeHsSemanticTokenTypes {rangeSemanticList}, mapping) <- useWithStaleE GetSemanticTokens nfp + withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens config mapping rangeSemanticList semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull semanticTokensFull recorder state pid param = do 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 90e839c4bd..e78923adb2 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 @@ -120,7 +120,7 @@ instance NFData GetSemanticTokens type RangeSemanticTokenTypeList = [(Range, HsSemanticTokenType)] -newtype RangeHsSemanticTokenTypes = RangeHsSemanticTokenTypes {rangeSemantic :: RangeSemanticTokenTypeList} +newtype RangeHsSemanticTokenTypes = RangeHsSemanticTokenTypes {rangeSemanticList :: RangeSemanticTokenTypeList} instance NFData RangeHsSemanticTokenTypes where rnf :: RangeHsSemanticTokenTypes -> () From ec75e8db97298261c695ad028ef97b546f079dc2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 5 Feb 2024 02:10:37 +0800 Subject: [PATCH 03/13] cleanup --- .../src/Ide/Plugin/SemanticTokens/Query.hs | 2 +- .../src/Ide/Plugin/SemanticTokens/Types.hs | 4 ---- 2 files changed, 1 insertion(+), 5 deletions(-) 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 e5301260a1..b0d26c5e87 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 @@ -63,7 +63,7 @@ nameSemanticFromHie hieKind rm n = do ------------------------------------------------- --- * extract semantic tokens from IdSemanticMap +-- * extract lsp semantic tokens from RangeSemanticTokenTypeList ------------------------------------------------- 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 e78923adb2..a479646990 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 @@ -107,10 +107,6 @@ data Loc = Loc instance Show Loc where show (Loc line startChar len) = show line <> ":" <> show startChar <> "-" <> show (startChar + len) -type RangeIdSetMap = Map Range (Set Identifier) - -type IdSemanticMap = Map Identifier HsSemanticTokenType - data GetSemanticTokens = GetSemanticTokens deriving (Eq, Show, Typeable, Generic) From 8c8e327e8f2da71ed7c15bc45c55179b30a0cea0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 5 Feb 2024 02:36:33 +0800 Subject: [PATCH 04/13] cleanup --- .../src/Ide/Plugin/SemanticTokens/Mappings.hs | 4 ---- 1 file changed, 4 deletions(-) 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 56452b7c94..1d7c51fd47 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 @@ -32,10 +32,6 @@ import Language.LSP.VFS hiding (line) -- * 0. Mapping name to Hs semantic token type. -idInfixOperator :: Identifier -> Maybe HsSemanticTokenType -idInfixOperator (Right name) = nameInfixOperator name -idInfixOperator _ = Nothing - nameInfixOperator :: Name -> Maybe HsSemanticTokenType nameInfixOperator name | isSymOcc (nameOccName name) = Just TOperator nameInfixOperator _ = Nothing From 60d3f643f2b909b1b37cc68130ac11587ae8a80b Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 6 Feb 2024 01:21:50 +0800 Subject: [PATCH 05/13] use dlist to accumulate token result and remove result in the state of tokenizor --- haskell-language-server.cabal | 1 + .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 70 ++++++++++--------- 2 files changed, 37 insertions(+), 34 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 492d14e3ef..b1ded23e1e 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1592,6 +1592,7 @@ library hls-semantic-tokens-plugin , syb , array , deepseq + , dlist , hls-graph == 2.6.0.0 , template-haskell , data-default 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 4f7237cadf..8ee491eaa8 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 @@ -4,12 +4,15 @@ module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where import Control.Lens (Identity (runIdentity)) -import Control.Monad (forM_, guard) +import Control.Monad (foldM, forM, forM_, guard) import Control.Monad.State.Strict (MonadState (get), MonadTrans (lift), - execStateT, modify, put) -import Control.Monad.Trans.State.Strict (StateT, modify') + evalStateT, execStateT, + modify, put) +import Control.Monad.Trans.State.Strict (StateT, modify', runStateT) import Data.Char (isAlphaNum) +import Data.DList (DList) +import qualified Data.DList as DL import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import Data.Text (Text) @@ -34,14 +37,13 @@ type HsSemanticLookup = Identifier -> Maybe HsSemanticTokenType 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 - , rangeHsSemanticList :: [(Range, HsSemanticTokenType)] -- (range, token type) in reverse order + 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 } -runTokenizer :: (Monad m) => Tokenizer m a -> PTokenState -> m [(Range, HsSemanticTokenType)] -runTokenizer p st = reverse . rangeHsSemanticList <$> execStateT p st +runTokenizer :: (Monad m) => Tokenizer m a -> PTokenState -> m a +runTokenizer p st = evalStateT p st data SplitResult = NoSplit (Text, Range) -- does not need to split, token text, token range @@ -59,53 +61,53 @@ mkPTokenState vf = { rope = Rope.fromText $ toText vf._file_text, cursor = Char.Position 0 0, - columnsInUtf16 = 0, - rangeHsSemanticList = [] + columnsInUtf16 = 0 } +-- instance Monoid (DList a) where +-- mempty = DL.empty +-- mappend = (DL.++) -addRangeHsSemanticList :: (Monad m) => (Range, HsSemanticTokenType) -> Tokenizer m () -addRangeHsSemanticList r = modify' $ \s -> s {rangeHsSemanticList = r : rangeHsSemanticList s} - --- lift a Tokenizer Maybe () to Tokenizer m (), +-- lift a Tokenizer Maybe a to Tokenizer m a, -- if the Maybe is Nothing, do nothing, recover the state --- if the Maybe is Just (), do the action, and keep the state -liftMaybeM :: (Monad m) => Tokenizer Maybe () -> Tokenizer m () -liftMaybeM p = do +-- if the Maybe is Just a, do the action, and keep the state +liftMaybeM :: (Monad m) => a -> Tokenizer Maybe a -> Tokenizer m a +liftMaybeM a p = do st <- get - forM_ (execStateT p st) put + maybe (return a) (\(a, st') -> put st' >> return a) $ runStateT p st computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast = - RangeHsSemanticTokenTypes $ runIdentity $ runTokenizer (foldAst lookupHsTokenType ast) (mkPTokenState vf) + RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ runTokenizer (foldAst lookupHsTokenType ast) (mkPTokenState vf) +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 +-- (a -> m b) -> (a -> b -> m b) -> t a -> m b -- | foldAst -- visit every leaf node in the ast in depth first order -foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m () +foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) foldAst lookupHsTokenType ast = if null (nodeChildren ast) - then liftMaybeM (visitLeafIds lookupHsTokenType ast) - else mapM_ (foldAst lookupHsTokenType) $ nodeChildren ast + then liftMaybeM mempty (visitLeafIds lookupHsTokenType ast) + else foldMapM (foldAst lookupHsTokenType) $ nodeChildren ast -visitLeafIds :: HsSemanticLookup -> HieAST t -> Tokenizer Maybe () -visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do +visitLeafIds :: HsSemanticLookup -> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType)) +visitLeafIds lookupHsTokenType leaf = liftMaybeM mempty $ do let span = nodeSpan leaf (ran, token) <- focusTokenAt leaf -- if `focusTokenAt` succeed, we can safely assume we have shift the cursor correctly -- we do not need to recover the cursor state, even if the following computation failed - liftMaybeM $ do + liftMaybeM mempty $ do -- only handle the leaf node with single column token guard $ srcSpanStartLine span == srcSpanEndLine span splitResult <- lift $ splitRangeByText token ran - mapM_ (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 - combineNodeIds :: (Monad m) => HsSemanticLookup -> Range -> SplitResult -> NodeInfo a -> Tokenizer m () + 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 () - (Just TModule, _) -> addRangeHsSemanticList (ran, TModule) - (Just tokenType, NoSplit (_, tokenRan)) -> addRangeHsSemanticList (tokenRan, tokenType) - (Just tokenType, Split (_, ranPrefix, tokenRan)) -> do - addRangeHsSemanticList (ranPrefix, TModule) - addRangeHsSemanticList (tokenRan, tokenType) + (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) From fbcce3f6d4b547ffc4e92ba73026e9d94b505edf Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 6 Feb 2024 01:22:06 +0800 Subject: [PATCH 06/13] cleanup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 3 --- 1 file changed, 3 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 8ee491eaa8..1e8c271df6 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 @@ -63,9 +63,6 @@ mkPTokenState vf = cursor = Char.Position 0 0, columnsInUtf16 = 0 } --- instance Monoid (DList a) where --- mempty = DL.empty --- mappend = (DL.++) -- lift a Tokenizer Maybe a to Tokenizer m a, -- if the Maybe is Nothing, do nothing, recover the state From 281c5424d0219bd55ac3871d5dfadc416f0cd932 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 6 Feb 2024 01:23:36 +0800 Subject: [PATCH 07/13] cleanup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 1e8c271df6..73d72d13b8 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 @@ -95,7 +95,7 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM mempty $ do liftMaybeM mempty $ do -- only handle the leaf node with single column token guard $ srcSpanStartLine span == srcSpanEndLine span - splitResult <- lift $ splitRangeByText token ran + splitResult <- lift $ splitRangeByText token ran 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)) From f173b6084ea44326214eec3bae36af086177294f Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 6 Feb 2024 01:28:41 +0800 Subject: [PATCH 08/13] cleanup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 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 73d72d13b8..398483dee8 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 @@ -4,12 +4,11 @@ module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where import Control.Lens (Identity (runIdentity)) -import Control.Monad (foldM, forM, forM_, guard) +import Control.Monad (foldM, guard) import Control.Monad.State.Strict (MonadState (get), MonadTrans (lift), - evalStateT, execStateT, - modify, put) -import Control.Monad.Trans.State.Strict (StateT, modify', runStateT) + evalStateT, modify, put) +import Control.Monad.Trans.State.Strict (StateT, runStateT) import Data.Char (isAlphaNum) import Data.DList (DList) import qualified Data.DList as DL @@ -78,7 +77,7 @@ computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast = 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 --- (a -> m b) -> (a -> b -> m b) -> t a -> m b + -- | foldAst -- visit every leaf node in the ast in depth first order foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)) From 6fcf211072fb8e075c5bb7a25a202f2d955f5517 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 6 Feb 2024 01:29:42 +0800 Subject: [PATCH 09/13] cleanup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 398483dee8..63a88d305b 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 @@ -98,7 +98,7 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM mempty $ 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) = case (maybeTokenType, ranSplit) of (Nothing, _) -> return mempty (Just TModule, _) -> return $ DL.singleton (ran, TModule) From 9c06f4a4bc0eb5a099fe7440eeab931ccc29e777 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 6 Feb 2024 01:33:00 +0800 Subject: [PATCH 10/13] cleanup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 2 -- 1 file changed, 2 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 63a88d305b..324e859eda 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 @@ -107,8 +107,6 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM mempty $ do where maybeTokenType = foldMap (getIdentifier lookupHsTokenType ranSplit) (M.keys bd) - -- takeHsSemanticType :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType - getIdentifier :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType getIdentifier lookupHsTokenType ranSplit idt = do case idt of From ba0bb65985b757e692117e9ea4f7172d64367907 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 6 Feb 2024 01:48:49 +0800 Subject: [PATCH 11/13] cleanup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 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 324e859eda..ad80a3d11a 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 @@ -64,8 +64,8 @@ mkPTokenState vf = } -- lift a Tokenizer Maybe a to Tokenizer m a, --- if the Maybe is Nothing, do nothing, recover the state --- if the Maybe is Just a, do the action, and keep the state +-- if the Maybe is Nothing, do nothing, recover the state, and return the default value +-- if the Maybe is Just a, do the action, and keep the state, and return a liftMaybeM :: (Monad m) => a -> Tokenizer Maybe a -> Tokenizer m a liftMaybeM a p = do st <- get From 84775d9f53408881fa75f912427e68e4b1ff4175 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 6 Feb 2024 21:38:48 +0800 Subject: [PATCH 12/13] cleanup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 ad80a3d11a..44f0628e2c 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 @@ -69,7 +69,7 @@ mkPTokenState vf = liftMaybeM :: (Monad m) => a -> Tokenizer Maybe a -> Tokenizer m a liftMaybeM a p = do st <- get - maybe (return a) (\(a, st') -> put st' >> return a) $ runStateT p st + maybe (return a) (\(ans, st') -> put st' >> return ans) $ runStateT p st computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast = From 5da84623c1bce3ad963fbc99442ede96714e5b93 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 7 Feb 2024 23:19:39 +0800 Subject: [PATCH 13/13] cleanup --- .../src/Ide/Plugin/SemanticTokens/Tokenize.hs | 29 ++++++++----------- 1 file changed, 12 insertions(+), 17 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 44f0628e2c..388137cbc2 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 @@ -41,9 +41,6 @@ data PTokenState = PTokenState , columnsInUtf16 :: !UInt -- the column of the start of the current rope in utf16 } -runTokenizer :: (Monad m) => Tokenizer m a -> PTokenState -> m a -runTokenizer p st = evalStateT p st - data SplitResult = NoSplit (Text, Range) -- does not need to split, token text, token range | Split (Text, Range, Range) -- token text, prefix range(module range), token range @@ -64,34 +61,33 @@ mkPTokenState vf = } -- lift a Tokenizer Maybe a to Tokenizer m a, --- if the Maybe is Nothing, do nothing, recover the state, and return the default value --- if the Maybe is Just a, do the action, and keep the state, and return a -liftMaybeM :: (Monad m) => a -> Tokenizer Maybe a -> Tokenizer m a -liftMaybeM a p = do +-- if the Maybe is Nothing, do nothing, recover the state, and return the mempty value +-- if the Maybe is Just x, do the action, and keep the state, and return x +liftMaybeM :: (Monad m, Monoid a) => Tokenizer Maybe a -> Tokenizer m a +liftMaybeM p = do st <- get - maybe (return a) (\(ans, st') -> put st' >> return ans) $ runStateT p st - -computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes -computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast = - RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ runTokenizer (foldAst lookupHsTokenType ast) (mkPTokenState vf) + 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) -- | foldAst -- 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 mempty (visitLeafIds lookupHsTokenType ast) + then liftMaybeM (visitLeafIds lookupHsTokenType ast) else foldMapM (foldAst lookupHsTokenType) $ nodeChildren ast visitLeafIds :: HsSemanticLookup -> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType)) -visitLeafIds lookupHsTokenType leaf = liftMaybeM mempty $ do +visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do let span = nodeSpan leaf (ran, token) <- focusTokenAt leaf -- if `focusTokenAt` succeed, we can safely assume we have shift the cursor correctly -- we do not need to recover the cursor state, even if the following computation failed - liftMaybeM mempty $ do + liftMaybeM $ do -- only handle the leaf node with single column token guard $ srcSpanStartLine span == srcSpanEndLine span splitResult <- lift $ splitRangeByText token ran @@ -104,8 +100,7 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM mempty $ do (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) + where maybeTokenType = foldMap (getIdentifier lookupHsTokenType ranSplit) (M.keys bd) getIdentifier :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType getIdentifier lookupHsTokenType ranSplit idt = do