@@ -32,33 +32,29 @@ import Language.LSP.VFS hiding (line)
3232-- * 1. Mapping semantic token type to and from the LSP default token type.
3333
3434-- | map from haskell semantic token type to LSP default token type
35- toLspTokenType :: HsSemanticTokenType -> SemanticTokenTypes
36- toLspTokenType tk = case tk of
37- -- Function type variable
38- TFunction -> SemanticTokenTypes_Function
39- -- None function type variable
40- TVariable -> SemanticTokenTypes_Variable
41- TClass -> SemanticTokenTypes_Class
42- TClassMethod -> SemanticTokenTypes_Method
43- TTypeVariable -> SemanticTokenTypes_TypeParameter
44- -- normal data type is a tagged union type look like enum type
45- -- and a record is a product type like struct
46- -- but we don't distinguish them yet
47- TTypeCon -> SemanticTokenTypes_Enum
48- TDataCon -> SemanticTokenTypes_EnumMember
49- TRecField -> SemanticTokenTypes_Property
50- -- pattern syn is like a limited version of macro of constructing a term
51- TPatternSyn -> SemanticTokenTypes_Macro
52- -- saturated type
53- TTypeSyn -> SemanticTokenTypes_Type
54- -- not sure if this is correct choice
55- TTypeFamily -> SemanticTokenTypes_Interface
56-
57- lspTokenReverseMap :: Map. MapSemanticTokenTypes HsSemanticTokenType
58- lspTokenReverseMap = Map. fromList $ map (\ x -> (toLspTokenType x, x)) $ enumFrom minBound
59-
60- fromLspTokenType :: SemanticTokenTypes -> Maybe HsSemanticTokenType
61- fromLspTokenType tk = Map. lookup tk lspTokenReverseMap
35+ toLspTokenType :: SemanticTokensConfig -> HsSemanticTokenType -> SemanticTokenTypes
36+ toLspTokenType conf tk = case tk of
37+ TFunction -> stFunction conf
38+ TVariable -> stVariable conf
39+ TClassMethod -> stClassMethod conf
40+ TTypeVariable -> stTypeVariable conf
41+ TDataConstructor -> stDataConstructor conf
42+ TClass -> stClass conf
43+ TTypeConstructor -> stTypeConstructor conf
44+ TTypeSynonym -> stTypeSynonym conf
45+ TTypeFamily -> stTypeFamily conf
46+ TRecordField -> stRecordField conf
47+ TPatternSynonym -> stPatternSynonym conf
48+
49+ lspTokenReverseMap :: SemanticTokensConfig -> Map. MapSemanticTokenTypes HsSemanticTokenType
50+ lspTokenReverseMap config
51+ | length xs /= Map. size mr = error " lspTokenReverseMap: token type mapping is not bijection"
52+ | otherwise = mr
53+ where xs = enumFrom minBound
54+ mr = Map. fromList $ map (\ x -> (toLspTokenType config x, x)) xs
55+
56+ lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType
57+ lspTokenTypeHsTokenType cf tk = Map. lookup tk (lspTokenReverseMap cf)
6258
6359-- * 2. Mapping from GHC type and tyThing to semantic token type.
6460
@@ -67,19 +63,19 @@ tyThingSemantic :: TyThing -> Maybe HsSemanticTokenType
6763tyThingSemantic ty = case ty of
6864 AnId vid
6965 | isTyVar vid -> Just TTypeVariable
70- | isRecordSelector vid -> Just TRecField
66+ | isRecordSelector vid -> Just TRecordField
7167 | isClassOpId vid -> Just TClassMethod
7268 | isFunVar vid -> Just TFunction
7369 | otherwise -> Just TVariable
7470 AConLike con -> case con of
75- RealDataCon _ -> Just TDataCon
76- PatSynCon _ -> Just TPatternSyn
71+ RealDataCon _ -> Just TDataConstructor
72+ PatSynCon _ -> Just TPatternSynonym
7773 ATyCon tyCon
78- | isTypeSynonymTyCon tyCon -> Just TTypeSyn
74+ | isTypeSynonymTyCon tyCon -> Just TTypeSynonym
7975 | isTypeFamilyTyCon tyCon -> Just TTypeFamily
8076 | isClassTyCon tyCon -> Just TClass
81- -- fall back to TTypeCon the result
82- | otherwise -> Just TTypeCon
77+ -- fall back to TTypeConstructor the result
78+ | otherwise -> Just TTypeConstructor
8379 ACoAxiom _ -> Nothing
8480 where
8581 isFunVar :: Var -> Bool
@@ -143,36 +139,53 @@ infoTokenType x = case x of
143139 PatternBind {} -> Just TVariable
144140 ClassTyDecl _ -> Just TClassMethod
145141 TyVarBind _ _ -> Just TTypeVariable
146- RecField _ _ -> Just TRecField
142+ RecField _ _ -> Just TRecordField
147143 -- data constructor, type constructor, type synonym, type family
148144 Decl ClassDec _ -> Just TClass
149- Decl DataDec _ -> Just TTypeCon
150- Decl ConDec _ -> Just TDataCon
151- Decl SynDec _ -> Just TTypeSyn
145+ Decl DataDec _ -> Just TTypeConstructor
146+ Decl ConDec _ -> Just TDataConstructor
147+ Decl SynDec _ -> Just TTypeSynonym
152148 Decl FamDec _ -> Just TTypeFamily
153149 -- instance dec is class method
154150 Decl InstDec _ -> Just TClassMethod
155- Decl PatSynDec _ -> Just TPatternSyn
151+ Decl PatSynDec _ -> Just TPatternSynonym
156152 EvidenceVarUse -> Nothing
157153 EvidenceVarBind {} -> Nothing
158154
159155-- * 4. Mapping from LSP tokens to SemanticTokenOriginal.
160156
161- -- | line, startChar, len, tokenType, modifiers
162- type ActualToken = (UInt , UInt , UInt , HsSemanticTokenType , UInt )
163-
164157-- | recoverSemanticTokens
165158-- for debug and test.
166159-- this function is used to recover the original tokens(with token in haskell token type zoon)
167160-- from the lsp semantic tokens(with token in lsp token type zoon)
168- recoverSemanticTokens :: VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal ]
169- recoverSemanticTokens vsf (SemanticTokens _ xs) = do
161+ -- the `SemanticTokensConfig` used should be a map with bijection property
162+ recoverSemanticTokens :: SemanticTokensConfig -> VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsSemanticTokenType ]
163+ recoverSemanticTokens config v s = do
164+ tks <- recoverLspSemanticTokens v s
165+ return $ map (lspTokenHsToken config) tks
166+
167+ -- | lspTokenHsToken
168+ -- for debug and test.
169+ -- use the `SemanticTokensConfig` to convert lsp token type to haskell token type
170+ -- the `SemanticTokensConfig` used should be a map with bijection property
171+ lspTokenHsToken :: SemanticTokensConfig -> SemanticTokenOriginal SemanticTokenTypes -> SemanticTokenOriginal HsSemanticTokenType
172+ lspTokenHsToken config (SemanticTokenOriginal tokenType location name) =
173+ case lspTokenTypeHsTokenType config tokenType of
174+ Just t -> SemanticTokenOriginal t location name
175+ Nothing -> error " recoverSemanticTokens: unknown lsp token type"
176+
177+ -- | recoverLspSemanticTokens
178+ -- for debug and test.
179+ -- this function is used to recover the original tokens(with token in standard lsp token type zoon)
180+ -- from the lsp semantic tokens(with token in lsp token type zoon)
181+ recoverLspSemanticTokens :: VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal SemanticTokenTypes ]
182+ recoverLspSemanticTokens vsf (SemanticTokens _ xs) = do
170183 tokens <- dataActualToken xs
171184 return $ mapMaybe (tokenOrigin sourceCode) tokens
172185 where
173186 sourceCode = unpack $ virtualFileText vsf
174- tokenOrigin :: [Char -> ActualToken -> Maybe SemanticTokenOriginal
175- tokenOrigin sourceCode' (line, startChar, len, tokenType, _ ) = do
187+ tokenOrigin :: [Char -> SemanticTokenAbsolute -> Maybe ( SemanticTokenOriginal SemanticTokenTypes )
188+ tokenOrigin sourceCode' (SemanticTokenAbsolute line startChar len tokenType _tokenModifiers ) = do
176189 -- convert back to count from 1
177190 let range = mkRange line startChar len
178191 CodePointRange (CodePointPosition x y) (CodePointPosition _ y1) <- rangeToCodePointRange vsf range
@@ -183,20 +196,15 @@ recoverSemanticTokens vsf (SemanticTokens _ xs) = do
183196 let name = maybe " no source" take (fromIntegral len') . drop (fromIntegral startChar')) tLine
184197 return $ SemanticTokenOriginal tokenType (Loc (line' + 1 ) (startChar' + 1 ) len') name
185198
186- dataActualToken :: [UInt ] -> Either Text [ActualToken ]
199+ dataActualToken :: [UInt ] -> Either Text [SemanticTokenAbsolute ]
187200 dataActualToken dt =
188- maybe decodeError (Right . fmap semanticTokenAbsoluteActualToken . absolutizeTokens) $
201+ maybe decodeError (Right . absolutizeTokens) $
189202 mapM fromTuple (chunksOf 5 $ map fromIntegral dt)
190203 where
191204 decodeError = Left " recoverSemanticTokenRelative: wrong token data"
192205 fromTuple [a, b, c, d, _] = SemanticTokenRelative a b c <$> fromInt (fromIntegral d) <*> return []
193206 fromTuple _ = Nothing
194207
195- semanticTokenAbsoluteActualToken :: SemanticTokenAbsolute -> ActualToken
196- semanticTokenAbsoluteActualToken (SemanticTokenAbsolute line startChar len tokenType _tokenModifiers) =
197- case fromLspTokenType tokenType of
198- Just t -> (line, startChar, len, t, 0 )
199- Nothing -> error " semanticTokenAbsoluteActualToken: unknown token type"
200208
201209 -- legends :: SemanticTokensLegend
202210 fromInt :: Int -> Maybe SemanticTokenTypes
0 commit comments