Skip to content

Commit 71e6532

Browse files
soulomoonsoulomoon
committed
cleanup
1 parent 83c56e4 commit 71e6532

File tree

3 files changed

+43
-40
lines changed

3 files changed

+43
-40
lines changed

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs

+3-4
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@
1111
{-# LANGUAGE OverloadedStrings #-}
1212
{-# LANGUAGE RecordWildCards #-}
1313
{-# LANGUAGE ScopedTypeVariables #-}
14-
{-# LANGUAGE TupleSections #-}
1514
{-# LANGUAGE TypeFamilies #-}
1615
{-# LANGUAGE UnicodeSyntax #-}
1716

@@ -25,6 +24,7 @@ import Control.Monad.Except (ExceptT, liftEither,
2524
import Control.Monad.IO.Class (MonadIO, liftIO)
2625
import Control.Monad.Trans (lift)
2726
import Control.Monad.Trans.Except (runExceptT)
27+
import qualified Data.Map as M
2828
import qualified Data.Map as Map
2929
import Data.Maybe (listToMaybe, mapMaybe)
3030
import qualified Data.Text as T
@@ -74,9 +74,8 @@ computeSemanticTokens :: IdeState -> NormalizedFilePath -> ExceptT PluginError A
7474
computeSemanticTokens state nfp = do
7575
let dbg = logActionWith state Debug
7676
dbg $ "Computing semantic tokens for: " <> show nfp
77-
(RangeHsSemanticTokenTypes {tokens}, mapping) <- useWithStaleE GetSemanticTokens nfp
78-
let rangeTokens = mapMaybe (\(span, name) -> (,name) <$> toCurrentRange mapping span) tokens
79-
withExceptT PluginInternalError $ liftEither $ semanticTokenAbsoluteSemanticTokens rangeTokens
77+
(RangeHsSemanticTokenTypes {rangeSemanticMap}, mapping) <- useWithStaleE GetSemanticTokens nfp
78+
withExceptT PluginInternalError $ liftEither $ rangeSemanticMapSemanticTokens mapping rangeSemanticMap
8079

8180
semanticTokensFull :: PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull
8281
semanticTokensFull state _ param = do

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs

+36-35
Original file line numberDiff line numberDiff line change
@@ -5,31 +5,29 @@
55
{-# LANGUAGE RankNTypes #-}
66
{-# LANGUAGE ScopedTypeVariables #-}
77

8-
98
module Ide.Plugin.SemanticTokens.Query where
109

11-
import Data.Either (rights)
12-
import Data.Foldable (fold)
13-
import qualified Data.List as List
14-
import qualified Data.Map as M
15-
import qualified Data.Map as Map
16-
import Data.Maybe (fromMaybe, listToMaybe,
17-
mapMaybe)
18-
import qualified Data.Set as S
19-
import qualified Data.Set as Set
20-
import Data.Text (Text)
21-
import Development.IDE (realSrcSpanToRange)
10+
import Data.Either (rights)
11+
import Data.Foldable (fold)
12+
import qualified Data.Map as M
13+
import qualified Data.Map as Map
14+
import Data.Maybe (fromMaybe, listToMaybe,
15+
mapMaybe)
16+
import qualified Data.Set as S
17+
import qualified Data.Set as Set
18+
import Data.Text (Text)
19+
import Development.IDE.Core.PositionMapping (PositionMapping,
20+
toCurrentRange)
2221
import Development.IDE.GHC.Compat
2322
import Ide.Plugin.SemanticTokens.Mappings
24-
import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind,
25-
HsSemanticTokenType,
26-
NameSemanticMap)
27-
import Ide.Plugin.SemanticTokens.Utils (realSrcSpanToCodePointRange)
23+
import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind,
24+
HsSemanticTokenType,
25+
NameSemanticMap)
26+
import Ide.Plugin.SemanticTokens.Utils (realSrcSpanToCodePointRange)
2827
import Language.LSP.Protocol.Types
29-
import Language.LSP.VFS (CodePointRange,
30-
VirtualFile,
31-
codePointRangeToRange)
32-
import Prelude hiding (span)
28+
import Language.LSP.VFS (VirtualFile,
29+
codePointRangeToRange)
30+
import Prelude hiding (span)
3331

3432
---------------------------------------------------------
3533

@@ -74,9 +72,9 @@ hieAstSpanNames vf ast =
7472
then getIds ast
7573
else M.unionsWith unionNameSet $ map (hieAstSpanNames vf) (nodeChildren ast)
7674
where
77-
getIds ast' = fromMaybe mempty $ do
78-
range <- codePointRangeToRange vf $ realSrcSpanToCodePointRange $ nodeSpan ast'
79-
return $ M.singleton range (getNodeIds' ast')
75+
getIds ast' = fromMaybe mempty $ do
76+
range <- codePointRangeToRange vf $ realSrcSpanToCodePointRange $ nodeSpan ast'
77+
return $ M.singleton range (getNodeIds' ast')
8078
getNodeIds' =
8179
Map.foldl' combineNodeIds mempty
8280
. Map.filterWithKey (\k _ -> k == SourceInfo)
@@ -85,25 +83,32 @@ hieAstSpanNames vf ast =
8583
combineNodeIds :: NameSet -> NodeInfo a -> NameSet
8684
ad `combineNodeIds` (NodeInfo _ _ bd) = ad `unionNameSet` xs
8785
where
88-
xs = mkNameSet $ rights $ M.keys $ M.filterWithKey inclusion bd
86+
xs = mkNameSet $ rights $ M.keys $ M.filterWithKey inclusion bd
8987
inclusion :: Identifier -> IdentifierDetails a -> Bool
9088
inclusion a b = not $ exclusion a b
9189
exclusion :: Identifier -> IdentifierDetails a -> Bool
9290
exclusion idt IdentifierDetails {identInfo = infos} = case idt of
93-
Left _ -> True
94-
Right name ->
95-
isDerivedOccName (nameOccName name)
96-
|| any isEvidenceContext (S.toList infos)
97-
91+
Left _ -> True
92+
Right name ->
93+
isDerivedOccName (nameOccName name)
94+
|| any isEvidenceContext (S.toList infos)
9895

9996
-------------------------------------------------
10097

10198
-- * extract semantic tokens from NameSemanticMap
10299

103100
-------------------------------------------------
104101

105-
semanticTokenAbsoluteSemanticTokens :: [(Range, HsSemanticTokenType)] -> Either Text SemanticTokens
106-
semanticTokenAbsoluteSemanticTokens = makeSemanticTokens defaultSemanticTokensLegend . List.sort . map (uncurry toAbsSemanticToken)
102+
extractSemanticTokensFromNames :: NameSemanticMap -> M.Map Range NameSet -> M.Map Range HsSemanticTokenType
103+
extractSemanticTokensFromNames nsm rnMap = Map.mapMaybe (foldMap (lookupNameEnv nsm) . nameSetElemsStable) rnMap
104+
105+
106+
rangeSemanticMapSemanticTokens :: PositionMapping -> M.Map Range HsSemanticTokenType -> Either Text SemanticTokens
107+
rangeSemanticMapSemanticTokens mapping =
108+
makeSemanticTokens defaultSemanticTokensLegend
109+
. mapMaybe (\(range, ty) -> flip toAbsSemanticToken ty <$> range)
110+
. Map.toAscList
111+
. M.mapKeys (\r -> toCurrentRange mapping r)
107112
where
108113
toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute
109114
toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType =
@@ -114,7 +119,3 @@ semanticTokenAbsoluteSemanticTokens = makeSemanticTokens defaultSemanticTokensLe
114119
(fromIntegral len)
115120
(toLspTokenType tokenType)
116121
[]
117-
118-
extractSemanticTokensFromNames :: NameSemanticMap -> M.Map Range NameSet -> [(Range, HsSemanticTokenType)]
119-
extractSemanticTokensFromNames nsm rnMap = xs
120-
where xs = mapMaybe sequence (Map.toList $ Map.map (foldMap (lookupNameEnv nsm) . nameSetElemsStable) rnMap)

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs

+4-1
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE DeriveGeneric #-}
22
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE InstanceSigs #-}
34
{-# LANGUAGE OverloadedStrings #-}
45
{-# LANGUAGE StrictData #-}
56
{-# LANGUAGE TypeFamilies #-}
@@ -9,6 +10,7 @@ module Ide.Plugin.SemanticTokens.Types where
910
import Control.DeepSeq (NFData (rnf), rwhnf)
1011
import qualified Data.Array as A
1112
import Data.Generics (Typeable)
13+
import qualified Data.Map as M
1214
import Development.IDE (Pretty (pretty), RuleResult)
1315
import qualified Development.IDE.Core.Shake as Shake
1416
import Development.IDE.GHC.Compat hiding (loc)
@@ -67,9 +69,10 @@ instance Hashable GetSemanticTokens
6769

6870
instance NFData GetSemanticTokens
6971

70-
data RangeHsSemanticTokenTypes = RangeHsSemanticTokenTypes {tokens :: [(Range, HsSemanticTokenType)]}
72+
data RangeHsSemanticTokenTypes = RangeHsSemanticTokenTypes {rangeSemanticMap :: M.Map Range HsSemanticTokenType}
7173

7274
instance NFData RangeHsSemanticTokenTypes where
75+
rnf :: RangeHsSemanticTokenTypes -> ()
7376
rnf (RangeHsSemanticTokenTypes a) = rwhnf a
7477

7578
instance Show RangeHsSemanticTokenTypes where

0 commit comments

Comments
 (0)