hls-semantic-tokens-plugin (empty) → 2.6.0.0
raw patch · 33 files changed
+1576/−0 lines, 33 filesdep +aesondep +arraydep +base
Dependencies added: aeson, array, base, bytestring, containers, data-default, deepseq, extra, filepath, ghc, ghcide, ghcide-test-utils, hiedb, hls-graph, hls-plugin-api, hls-semantic-tokens-plugin, hls-test-utils, lens, lsp, lsp-test, mtl, sqlite-simple, syb, template-haskell, text, text-rope, transformers, unordered-containers
Files
- LICENSE +201/−0
- hls-semantic-tokens-plugin.cabal +91/−0
- src/Ide/Plugin/SemanticTokens.hs +22/−0
- src/Ide/Plugin/SemanticTokens/Internal.hs +140/−0
- src/Ide/Plugin/SemanticTokens/Mappings.hs +228/−0
- src/Ide/Plugin/SemanticTokens/Query.hs +114/−0
- src/Ide/Plugin/SemanticTokens/SemanticConfig.hs +109/−0
- src/Ide/Plugin/SemanticTokens/Types.hs +150/−0
- src/Ide/Plugin/SemanticTokens/Utils.hs +101/−0
- test/Main.hs +233/−0
- test/testdata/T1.hs +48/−0
- test/testdata/TClass.hs +6/−0
- test/testdata/TClassImportedDeriving.hs +10/−0
- test/testdata/TDataFamily.hs +11/−0
- test/testdata/TDataType.hs +3/−0
- test/testdata/TDatatypeImported.hs +6/−0
- test/testdata/TFunction.hs +7/−0
- test/testdata/TFunctionLet.hs +4/−0
- test/testdata/TFunctionLocal.hs +8/−0
- test/testdata/TGADT.hs +7/−0
- test/testdata/TInstanceClassMethodBind.hs +6/−0
- test/testdata/TInstanceClassMethodUse.hs +5/−0
- test/testdata/TModuleA.hs +3/−0
- test/testdata/TModuleB.hs +5/−0
- test/testdata/TNoneFunctionWithConstraint.hs +5/−0
- test/testdata/TPatternMatch.hs +6/−0
- test/testdata/TPatternSynonym.hs +7/−0
- test/testdata/TPatternbind.hs +9/−0
- test/testdata/TRecord.hs +7/−0
- test/testdata/TRecordDuplicateRecordFields.hs +5/−0
- test/testdata/TTypefamily.hs +6/−0
- test/testdata/TUnicodeSyntax.hs +5/−0
- test/testdata/TValBind.hs +8/−0
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ hls-semantic-tokens-plugin.cabal view
@@ -0,0 +1,91 @@+cabal-version: 2.4+name: hls-semantic-tokens-plugin+version: 2.6.0.0+synopsis: Call hierarchy plugin for Haskell Language Server+description:+ Please see the README on GitHub at <https://github.com/haskell/haskell-language-server/tree/master/plugins/hls-call-hierarchy-plugin#readme>++license: Apache-2.0+license-file: LICENSE+author: Patrick Wales+maintainer: patrickwalesss@gmail.com+category: Development+build-type: Simple+extra-source-files:+ LICENSE+ test/testdata/*.hs++source-repository head+ type: git+ location: https://github.com/haskell/haskell-language-server.git++library+ ghc-options: -Wall+ buildable: True+ exposed-modules:+ Ide.Plugin.SemanticTokens+ Ide.Plugin.SemanticTokens.Types+ Ide.Plugin.SemanticTokens.Mappings+ other-modules:+ Ide.Plugin.SemanticTokens.Query+ Ide.Plugin.SemanticTokens.SemanticConfig+ Ide.Plugin.SemanticTokens.Utils+ Ide.Plugin.SemanticTokens.Internal++ hs-source-dirs: src+ build-depends:+ , aeson+ , base >=4.12 && <5+ , containers+ , extra+ , hiedb+ , mtl >= 2.2+ , ghcide == 2.6.0.0+ , hls-plugin-api == 2.6.0.0+ , lens+ , lsp >=2.3+ , sqlite-simple+ , text+ , unordered-containers+ , transformers+ , bytestring+ , syb+ , array+ , deepseq+ , hls-graph == 2.6.0.0+ , template-haskell+ , data-default++ default-language: Haskell2010+ default-extensions: DataKinds++test-suite tests+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N++ build-depends:+ , aeson+ , base+ , containers+ , extra+ , filepath+ , hls-semantic-tokens-plugin+ , hls-test-utils == 2.6.0.0+ , ghcide-test-utils+ , hls-plugin-api+ , lens+ , lsp+ , ghc+ , text-rope+ , lsp-test+ , text+ , data-default+ , bytestring+ , ghcide == 2.6.0.0+ , hls-plugin-api == 2.6.0.0+ , template-haskell+ , data-default
+ src/Ide/Plugin/SemanticTokens.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Ide.Plugin.SemanticTokens (descriptor) where++import Development.IDE+import qualified Ide.Plugin.SemanticTokens.Internal as Internal+import Ide.Plugin.SemanticTokens.Types+import Ide.Types+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,+ pluginConfigDescriptor =+ defaultConfigDescriptor+ { configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False}+ , configCustomConfig = mkCustomConfig Internal.semanticConfigProperties+ }+ }
+ src/Ide/Plugin/SemanticTokens/Internal.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- This module provides the core functionality of the plugin.+module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule, semanticConfigProperties) where++import Control.Lens ((^.))+import Control.Monad.Except (ExceptT, liftEither,+ withExceptT)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Except (runExceptT)+import Data.Aeson (ToJSON (toJSON))+import qualified Data.Map as Map+import Development.IDE (Action,+ GetDocMap (GetDocMap),+ GetHieAst (GetHieAst),+ HieAstResult (HAR, hieAst, hieModule, refMap),+ IdeResult, IdeState,+ Priority (..),+ Recorder, Rules,+ WithPriority,+ cmapWithPrio, define,+ fromNormalizedFilePath,+ hieKind, logPriority,+ usePropertyAction,+ 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,+ getVirtualFile,+ useWithStale_)+import Development.IDE.GHC.Compat hiding (Warning)+import Development.IDE.GHC.Compat.Util (mkFastString)+import Ide.Logger (logWith)+import Ide.Plugin.Error (PluginError (PluginInternalError),+ getNormalizedFilePathE,+ handleMaybe,+ handleMaybeM)+import Ide.Plugin.SemanticTokens.Mappings+import Ide.Plugin.SemanticTokens.Query+import Ide.Plugin.SemanticTokens.SemanticConfig (mkSemanticConfigFunctions)+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.Types (NormalizedFilePath,+ SemanticTokens,+ type (|?) (InL))+import Prelude hiding (span)+++$mkSemanticConfigFunctions++-----------------------+---- the api+-----------------------++computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action SemanticTokens+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++semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull+semanticTokensFull 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++-- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file.+--+-- This Rule collects information from various sources, including:+--+-- Imported name token type from Rule 'GetDocMap'+-- Local names token type from 'hieAst'+-- Name locations from 'hieAst'+-- Visible names from 'tmrRenamed'+--+-- It then combines this information to compute the semantic tokens for the file.+getSemanticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules ()+getSemanticTokensRule recorder =+ define (cmapWithPrio LogShake recorder) $ \GetSemanticTokens nfp -> handleError recorder $ do+ (HAR {..}) <- lift $ use_ GetHieAst nfp+ (DKMap {getTyThingMap}, _) <- lift $ useWithStale_ GetDocMap nfp+ ast <- handleMaybe (LogNoAST $ show nfp) $ getAsts hieAst Map.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp+ virtualFile <- handleMaybeM LogNoVF $ getVirtualFile nfp+ -- get current location from the old ones+ let spanNamesMap = hieAstSpanNames virtualFile ast+ let names = nameSetElemsStable $ unionNameSets $ Map.elems spanNamesMap+ let localSemanticMap = mkLocalNameSemanticFromAst names (hieKindFunMasksKind hieKind) refMap+ -- get imported name semantic map+ let importedNameSemanticMap = foldr (getTypeExclude localSemanticMap getTyThingMap) emptyNameEnv names+ let sMap = plusNameEnv_C (<>) importedNameSemanticMap localSemanticMap+ let rangeTokenType = extractSemanticTokensFromNames sMap spanNamesMap+ return $ RangeHsSemanticTokenTypes rangeTokenType+ where+ -- ignore one already in discovered in local+ getTypeExclude ::+ NameEnv a ->+ NameEnv TyThing ->+ Name ->+ NameEnv HsSemanticTokenType ->+ NameEnv HsSemanticTokenType+ getTypeExclude localEnv tyThingMap n nameMap+ | n `elemNameEnv` localEnv = nameMap+ | otherwise =+ let tyThing = lookupNameEnv tyThingMap n+ in maybe nameMap (extendNameEnv nameMap n) (tyThing >>= tyThingSemantic)++-- | 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++-- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log)+handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a)+handleError recorder action' = do+ valueEither <- runExceptT action'+ case valueEither of+ Left msg -> do+ logWith recorder Warning msg+ pure $ toIdeResult (Left [])+ Right value -> pure $ toIdeResult (Right value)
+ src/Ide/Plugin/SemanticTokens/Mappings.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- This module provides mappings to convert token type information in the Haskell IDE plugin. It includes functions for:+--+-- 1. Mapping semantic token type to and from the LSP default token type.+-- 2. Mapping from GHC type and tyThing to semantic token type.+-- 3. Mapping from hieAst identifier details to haskell semantic token type.+-- 4. Mapping from LSP tokens to SemanticTokenOriginal.+module Ide.Plugin.SemanticTokens.Mappings where++import qualified Data.Array as A+import Data.List.Extra (chunksOf, (!?))+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import Data.Text (Text, unpack)+import Development.IDE (HieKind (HieFresh, HieFromDisk))+import Development.IDE.GHC.Compat+import Ide.Plugin.SemanticTokens.Types+import Ide.Plugin.SemanticTokens.Utils (mkRange)+import Language.LSP.Protocol.Types (LspEnum (knownValues),+ SemanticTokenAbsolute (SemanticTokenAbsolute),+ SemanticTokenRelative (SemanticTokenRelative),+ SemanticTokenTypes (..),+ SemanticTokens (SemanticTokens),+ UInt, absolutizeTokens)+import Language.LSP.VFS hiding (line)++-- * 1. Mapping semantic token type to and from the LSP default token type.++-- | map from haskell semantic token type to LSP default token type+toLspTokenType :: SemanticTokensConfig -> HsSemanticTokenType -> SemanticTokenTypes+toLspTokenType conf tk = case tk of+ TFunction -> stFunction conf+ TVariable -> stVariable conf+ TClassMethod -> stClassMethod conf+ TTypeVariable -> stTypeVariable conf+ TDataConstructor -> stDataConstructor conf+ TClass -> stClass conf+ TTypeConstructor -> stTypeConstructor conf+ TTypeSynonym -> stTypeSynonym conf+ TTypeFamily -> stTypeFamily conf+ TRecordField -> stRecordField conf+ TPatternSynonym -> stPatternSynonym conf++lspTokenReverseMap :: SemanticTokensConfig -> Map.Map SemanticTokenTypes HsSemanticTokenType+lspTokenReverseMap config+ | length xs /= Map.size mr = error "lspTokenReverseMap: token type mapping is not bijection"+ | otherwise = mr+ where xs = enumFrom minBound+ mr = Map.fromList $ map (\x -> (toLspTokenType config x, x)) xs++lspTokenTypeHsTokenType :: SemanticTokensConfig -> SemanticTokenTypes -> Maybe HsSemanticTokenType+lspTokenTypeHsTokenType cf tk = Map.lookup tk (lspTokenReverseMap cf)++-- * 2. Mapping from GHC type and tyThing to semantic token type.++-- | tyThingSemantic+tyThingSemantic :: TyThing -> Maybe HsSemanticTokenType+tyThingSemantic ty = case ty of+ AnId vid+ | isTyVar vid -> Just TTypeVariable+ | isRecordSelector vid -> Just TRecordField+ | isClassOpId vid -> Just TClassMethod+ | isFunVar vid -> Just TFunction+ | otherwise -> Just TVariable+ AConLike con -> case con of+ RealDataCon _ -> Just TDataConstructor+ PatSynCon _ -> Just TPatternSynonym+ ATyCon tyCon+ | isTypeSynonymTyCon tyCon -> Just TTypeSynonym+ | isTypeFamilyTyCon tyCon -> Just TTypeFamily+ | isClassTyCon tyCon -> Just TClass+ -- fall back to TTypeConstructor the result+ | otherwise -> Just TTypeConstructor+ ACoAxiom _ -> Nothing+ where+ isFunVar :: Var -> Bool+ isFunVar var = isFunType $ varType var++isFunType :: Type -> Bool+isFunType a = case a of+ ForAllTy _ t -> isFunType t+ -- Development.IDE.GHC.Compat.Core.FunTy(pattern synonym), FunTyFlag which is used to distinguish+ -- (->, =>, etc..)+ FunTy flg _ rhs -> isVisibleFunArg flg || isFunType rhs+ _x -> isFunTy a++hieKindFunMasksKind :: HieKind a -> HieFunMaskKind a+hieKindFunMasksKind hieKind = case hieKind of+ HieFresh -> HieFreshFun+ HieFromDisk full_file -> HieFromDiskFun $ recoverFunMaskArray (hie_types full_file)++-- wz1000 offered+-- the idea from https://gitlab.haskell.org/ghc/haddock/-/blob/b0b0e0366457c9aefebcc94df74e5de4d00e17b7/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs#L107+-- optimize version of looking for which types are functions without unfolding the whole type+recoverFunMaskArray ::+ -- | flat types+ A.Array TypeIndex HieTypeFlat ->+ -- | array of bool indicating whether the type is a function+ A.Array TypeIndex Bool+recoverFunMaskArray flattened = unflattened+ where+ -- The recursion in 'unflattened' is crucial - it's what gives us sharing+ -- function indicator check.+ unflattened :: A.Array TypeIndex Bool+ unflattened = fmap (\flatTy -> go (fmap (unflattened A.!) flatTy)) flattened++ -- Unfold an 'HieType' whose subterms have already been unfolded+ go :: HieType Bool -> Bool+ go (HTyVarTy _name) = False+ go (HAppTy _f _x) = False+ go (HLitTy _lit) = False+ go (HForAllTy ((_n, _k), _af) b) = b+ go (HFunTy _ _ _) = True+ go (HQualTy _constraint b) = b+ go (HCastTy b) = b+ go HCoercionTy = False+ go (HTyConApp _ _) = False++typeSemantic :: HieFunMaskKind hType -> hType -> Maybe HsSemanticTokenType+typeSemantic kind t = case kind of+ HieFreshFun -> if isFunType t then Just TFunction else Nothing+ HieFromDiskFun arr -> if arr A.! t then Just TFunction else Nothing++-- * 3. Mapping from hieAst ContextInfo to haskell semantic token type.++infoTokenType :: ContextInfo -> Maybe HsSemanticTokenType+infoTokenType x = case x of+ Use -> Nothing+ MatchBind -> Nothing+ IEThing _ -> Nothing+ TyDecl -> Nothing -- type signature+ ValBind RegularBind _ _ -> Just TVariable+ ValBind InstanceBind _ _ -> Just TClassMethod+ PatternBind {} -> Just TVariable+ ClassTyDecl _ -> Just TClassMethod+ TyVarBind _ _ -> Just TTypeVariable+ RecField _ _ -> Just TRecordField+ -- data constructor, type constructor, type synonym, type family+ Decl ClassDec _ -> Just TClass+ Decl DataDec _ -> Just TTypeConstructor+ Decl ConDec _ -> Just TDataConstructor+ Decl SynDec _ -> Just TTypeSynonym+ Decl FamDec _ -> Just TTypeFamily+ -- instance dec is class method+ Decl InstDec _ -> Just TClassMethod+ Decl PatSynDec _ -> Just TPatternSynonym+ EvidenceVarUse -> Nothing+ EvidenceVarBind {} -> Nothing++-- * 4. Mapping from LSP tokens to SemanticTokenOriginal.++-- | recoverSemanticTokens+-- for debug and test.+-- this function is used to recover the original tokens(with token in haskell token type zoon)+-- from the lsp semantic tokens(with token in lsp token type zoon)+-- the `SemanticTokensConfig` used should be a map with bijection property+recoverSemanticTokens :: SemanticTokensConfig -> VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal HsSemanticTokenType]+recoverSemanticTokens config v s = do+ tks <- recoverLspSemanticTokens v s+ return $ map (lspTokenHsToken config) tks++-- | lspTokenHsToken+-- for debug and test.+-- use the `SemanticTokensConfig` to convert lsp token type to haskell token type+-- the `SemanticTokensConfig` used should be a map with bijection property+lspTokenHsToken :: SemanticTokensConfig -> SemanticTokenOriginal SemanticTokenTypes -> SemanticTokenOriginal HsSemanticTokenType+lspTokenHsToken config (SemanticTokenOriginal tokenType location name) =+ case lspTokenTypeHsTokenType config tokenType of+ Just t -> SemanticTokenOriginal t location name+ Nothing -> error "recoverSemanticTokens: unknown lsp token type"++-- | recoverLspSemanticTokens+-- for debug and test.+-- this function is used to recover the original tokens(with token in standard lsp token type zoon)+-- from the lsp semantic tokens(with token in lsp token type zoon)+recoverLspSemanticTokens :: VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal SemanticTokenTypes]+recoverLspSemanticTokens vsf (SemanticTokens _ xs) = do+ tokens <- dataActualToken xs+ return $ mapMaybe (tokenOrigin sourceCode) tokens+ where+ sourceCode = unpack $ virtualFileText vsf+ tokenOrigin :: [Char] -> SemanticTokenAbsolute -> Maybe (SemanticTokenOriginal SemanticTokenTypes)+ tokenOrigin sourceCode' (SemanticTokenAbsolute line startChar len tokenType _tokenModifiers) = do+ -- convert back to count from 1+ let range = mkRange line startChar len+ CodePointRange (CodePointPosition x y) (CodePointPosition _ y1) <- rangeToCodePointRange vsf range+ let line' = x+ let startChar' = y+ let len' = y1 - y+ let tLine = lines sourceCode' !? fromIntegral line'+ let name = maybe "no source" (take (fromIntegral len') . drop (fromIntegral startChar')) tLine+ return $ SemanticTokenOriginal tokenType (Loc (line' + 1) (startChar' + 1) len') name++ dataActualToken :: [UInt] -> Either Text [SemanticTokenAbsolute]+ dataActualToken dt =+ maybe decodeError (Right . absolutizeTokens) $+ mapM fromTuple (chunksOf 5 $ map fromIntegral dt)+ where+ decodeError = Left "recoverSemanticTokenRelative: wrong token data"+ fromTuple [a, b, c, d, _] = SemanticTokenRelative a b c <$> fromInt (fromIntegral d) <*> return []+ fromTuple _ = Nothing+++ -- legends :: SemanticTokensLegend+ fromInt :: Int -> Maybe SemanticTokenTypes+ fromInt i = Set.toAscList knownValues !? i++-- Note [Semantic information from Multiple Sources]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We group Name into 2 categories since the information source is different:+-- 1. Locally defined Name+-- Information source is current module's HieAst,+-- Either from ContextInfo(all except differing function and none-function)+-- or from Hie Type(Differing Function and Non-function Variable)+-- 2. Imported Name+-- Information source is `TyThing` for the `Name`, looked up in `HscEnv`(with all imported things loaded).+-- `TyThing` is information rich, since it is used to represent the things that a name can refer to in ghc.+-- The reason why we need special handling for imported name is that+-- Up to 9.8+-- 1. For Hie Type, IfaceTyCon in hie type does not contain enough information to distinguish class, type syn, type family etc..+-- 2. Most imported name is only annotated as [Use] in the ContextInfo from hie.+-- 3. `namespace` in `Name` is limited, we can only classify `VarName, FldName, DataName, TvNamem, TcClsName`.+-- 4. WiredIn `Name` have `TyThing` attached, but not many are WiredIn names.
+ src/Ide/Plugin/SemanticTokens/Query.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- The query module is used to query the semantic tokens from the AST+module Ide.Plugin.SemanticTokens.Query where++import Data.Either (rights)+import Data.Foldable (fold)+import qualified Data.Map as M+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, listToMaybe,+ mapMaybe)+import qualified Data.Set as S+import qualified Data.Set as Set+import Data.Text (Text)+import Development.IDE.Core.PositionMapping (PositionMapping,+ toCurrentRange)+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Error (realSrcSpanToCodePointRange)+import Ide.Plugin.SemanticTokens.Mappings+import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind,+ HsSemanticTokenType,+ NameSemanticMap,+ SemanticTokensConfig)+import Language.LSP.Protocol.Types+import Language.LSP.VFS (VirtualFile,+ codePointRangeToRange)+import Prelude hiding (span)++---------------------------------------------------------++-- * extract semantic map from HieAst for local variables++---------------------------------------------------------++mkLocalNameSemanticFromAst :: [Name] -> HieFunMaskKind a -> RefMap a -> NameSemanticMap+mkLocalNameSemanticFromAst names hieKind rm = mkNameEnv (mapMaybe (nameNameSemanticFromHie hieKind rm) names)++nameNameSemanticFromHie :: forall a. HieFunMaskKind a -> RefMap a -> Name -> Maybe (Name, HsSemanticTokenType)+nameNameSemanticFromHie hieKind rm ns = do+ st <- nameSemanticFromRefMap rm ns+ return (ns, st)+ where+ nameSemanticFromRefMap :: RefMap a -> Name -> Maybe HsSemanticTokenType+ nameSemanticFromRefMap rm' name' = do+ spanInfos <- Map.lookup (Right name') rm'+ let typeTokenType = foldMap (typeSemantic hieKind) $ listToMaybe $ mapMaybe (identType . snd) spanInfos+ contextInfoTokenType <- foldMap (contextInfosMaybeTokenType . identInfo . snd) spanInfos+ fold [typeTokenType, Just contextInfoTokenType]++ contextInfosMaybeTokenType :: Set.Set ContextInfo -> Maybe HsSemanticTokenType+ contextInfosMaybeTokenType details = foldMap infoTokenType (Set.toList details)++-----------------------------------++-- * extract location from HieAST a++-----------------------------------++-- | get only visible names from HieAST+-- we care only the leaf node of the AST+-- and filter out the derived and evidence names+hieAstSpanNames :: VirtualFile -> HieAST a -> M.Map Range NameSet+hieAstSpanNames vf ast =+ if null (nodeChildren ast)+ then getIds ast+ else M.unionsWith unionNameSet $ map (hieAstSpanNames vf) (nodeChildren ast)+ where+ getIds ast' = fromMaybe mempty $ do+ range <- codePointRangeToRange vf $ realSrcSpanToCodePointRange $ nodeSpan ast'+ return $ M.singleton range (getNodeIds' ast')+ getNodeIds' =+ Map.foldl' combineNodeIds mempty+ . Map.filterWithKey (\k _ -> k == SourceInfo)+ . getSourcedNodeInfo+ . sourcedNodeInfo+ combineNodeIds :: NameSet -> NodeInfo a -> NameSet+ ad `combineNodeIds` (NodeInfo _ _ bd) = ad `unionNameSet` xs+ where+ xs = mkNameSet $ rights $ M.keys $ M.filterWithKey inclusion bd+ inclusion :: Identifier -> IdentifierDetails a -> Bool+ inclusion a b = not $ exclusion a b+ exclusion :: Identifier -> IdentifierDetails a -> Bool+ exclusion idt IdentifierDetails {identInfo = infos} = case idt of+ Left _ -> True+ Right _ -> any isEvidenceContext (S.toList infos)++-------------------------------------------------++-- * extract semantic tokens from NameSemanticMap++-------------------------------------------------++extractSemanticTokensFromNames :: NameSemanticMap -> M.Map Range NameSet -> M.Map Range HsSemanticTokenType+extractSemanticTokensFromNames nsm = Map.mapMaybe (foldMap (lookupNameEnv nsm) . nameSetElemsStable)++rangeSemanticMapSemanticTokens :: SemanticTokensConfig -> PositionMapping -> M.Map Range HsSemanticTokenType -> Either Text SemanticTokens+rangeSemanticMapSemanticTokens stc mapping =+ makeSemanticTokens defaultSemanticTokensLegend+ . mapMaybe (\(range, ty) -> flip toAbsSemanticToken ty <$> range)+ . Map.toAscList+ . M.mapKeys (toCurrentRange mapping)+ where+ toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute+ toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType =+ let len = endColumn - startColumn+ in SemanticTokenAbsolute+ (fromIntegral startLine)+ (fromIntegral startColumn)+ (fromIntegral len)+ (toLspTokenType stc tokenType)+ []
+ src/Ide/Plugin/SemanticTokens/SemanticConfig.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Ide.Plugin.SemanticTokens.SemanticConfig where++import Data.Char (toLower)+import Data.Default (def)+import qualified Data.Set as S+import qualified Data.Text as T+import Development.IDE (usePropertyAction)+import Ide.Plugin.Properties (defineEnumProperty,+ emptyProperties)+import Ide.Plugin.SemanticTokens.Types+import Language.Haskell.TH+import Language.LSP.Protocol.Types (LspEnum (..),+ SemanticTokenTypes)++++docName :: HsSemanticTokenType -> T.Text+docName tt = case tt of+ TVariable -> "variables"+ TFunction -> "functions"+ TDataConstructor -> "data constructors"+ TTypeVariable -> "type variables"+ TClassMethod -> "typeclass methods"+ TPatternSynonym -> "pattern synonyms"+ TTypeConstructor -> "type constructors"+ TClass -> "typeclasses"+ TTypeSynonym -> "type synonyms"+ TTypeFamily -> "type families"+ TRecordField -> "record fields"++toConfigName :: String -> String+toConfigName = ("st" <>)++type LspTokenTypeDescriptions = [(SemanticTokenTypes, T.Text)]++lspTokenTypeDescriptions :: LspTokenTypeDescriptions+lspTokenTypeDescriptions =+ map+ ( \x ->+ (x, "LSP Semantic Token Type: " <> toEnumBaseType x)+ )+ $ S.toList knownValues++allHsTokenTypes :: [HsSemanticTokenType]+allHsTokenTypes = enumFrom minBound++lowerFirst :: String -> String+lowerFirst [] = []+lowerFirst (x:xs) = toLower x : xs++allHsTokenNameStrings :: [String]+allHsTokenNameStrings = map (drop 1 . show) allHsTokenTypes++defineSemanticProperty (lb, tokenType, st) =+ defineEnumProperty+ lb+ tokenType+ lspTokenTypeDescriptions+ st++semanticDef :: SemanticTokensConfig+semanticDef = def++-- | it produces the following functions:+-- semanticConfigProperties :: Properties '[+-- 'PropertyKey "Variable" ('TEnum SemanticTokenTypes),+-- ...+-- ]+-- useSemanticConfigAction :: PluginId -> Action SemanticTokensConfig+mkSemanticConfigFunctions :: Q [Dec]+mkSemanticConfigFunctions = do+ let pid = mkName "pid"+ let semanticConfigPropertiesName = mkName "semanticConfigProperties"+ let useSemanticConfigActionName = mkName "useSemanticConfigAction"+ let allLabels = map (LabelE . (<> "Token"). lowerFirst) allHsTokenNameStrings+ allFieldsNames = map (mkName . toConfigName) allHsTokenNameStrings+ allVariableNames = map (mkName . ("_variable_" <>) . toConfigName) allHsTokenNameStrings+ -- <- useSemanticConfigAction label pid config+ mkGetProperty (variable, label) =+ BindS+ (VarP variable)+ (AppE (VarE 'usePropertyAction) label `AppE` VarE pid `AppE` VarE semanticConfigPropertiesName)+ getProperties = zipWith (curry mkGetProperty) allVariableNames allLabels+ recordUpdate =+ RecUpdE (VarE 'semanticDef) $+ zipWith (\fieldName variableName -> (fieldName, VarE variableName)) allFieldsNames allVariableNames+ -- get and then update record+ bb = DoE Nothing $ getProperties ++ [NoBindS $ AppE (VarE 'return) recordUpdate]+ let useSemanticConfigAction = FunD useSemanticConfigActionName [Clause [VarP pid] (NormalB bb) []]++ -- SemanticConfigProperties+ nameAndDescList <-+ mapM+ ( \(lb, x) -> do+ desc <- [|"LSP semantic token type to use for " <> docName x|]+ lspToken <- [|toLspTokenType def x|]+ return $ TupE [Just lb, Just desc, Just lspToken]+ )+ $ zip allLabels allHsTokenTypes+ let body = foldr (AppE . AppE (VarE 'defineSemanticProperty)) (VarE 'emptyProperties) nameAndDescList+ let semanticConfigProperties = FunD semanticConfigPropertiesName [Clause [] (NormalB body) []]+ return [semanticConfigProperties, useSemanticConfigAction]
+ src/Ide/Plugin/SemanticTokens/Types.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}++module Ide.Plugin.SemanticTokens.Types where++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 as M+import Development.IDE (Pretty (pretty), RuleResult)+import qualified Development.IDE.Core.Shake as Shake+import Development.IDE.GHC.Compat hiding (loc)+import Development.IDE.Graph.Classes (Hashable)+import GHC.Generics (Generic)+import Language.LSP.Protocol.Types+-- import template haskell+import Language.Haskell.TH.Syntax (Lift)+++-- !!!! order of declarations matters deriving enum and ord+-- since token may come from different source and we want to keep the most specific one+-- and we might want to merge them.+data HsSemanticTokenType+ = TVariable -- none function variable+ | TFunction -- function+ | TDataConstructor -- Data constructor+ | TTypeVariable -- Type variable+ | TClassMethod -- Class method+ | TPatternSynonym -- Pattern synonym+ | TTypeConstructor -- Type (Type constructor)+ | TClass -- Type class+ | TTypeSynonym -- Type synonym+ | TTypeFamily -- type family+ | TRecordField -- from match bind+ deriving (Eq, Ord, Show, Enum, Bounded, Generic, Lift)++++-- type SemanticTokensConfig = SemanticTokensConfig_ Identity+instance Default SemanticTokensConfig where+ def = STC+ { stFunction = SemanticTokenTypes_Function+ , stVariable = SemanticTokenTypes_Variable+ , stDataConstructor = SemanticTokenTypes_EnumMember+ , stTypeVariable = SemanticTokenTypes_TypeParameter+ , stClassMethod = SemanticTokenTypes_Method+ -- pattern syn is like a limited version of macro of constructing a term+ , stPatternSynonym = SemanticTokenTypes_Macro+ -- normal data type is a tagged union type look like enum type+ -- and a record is a product type like struct+ -- but we don't distinguish them yet+ , stTypeConstructor = SemanticTokenTypes_Enum+ , stClass = SemanticTokenTypes_Class+ , stTypeSynonym = SemanticTokenTypes_Type+ , stTypeFamily = SemanticTokenTypes_Interface+ , stRecordField = SemanticTokenTypes_Property+ }+-- | SemanticTokensConfig_ is a configuration for the semantic tokens plugin.+-- it contains map between the hs semantic token type and default token type.+data SemanticTokensConfig = STC+ { stFunction :: !SemanticTokenTypes+ , stVariable :: !SemanticTokenTypes+ , stDataConstructor :: !SemanticTokenTypes+ , stTypeVariable :: !SemanticTokenTypes+ , stClassMethod :: !SemanticTokenTypes+ , stPatternSynonym :: !SemanticTokenTypes+ , stTypeConstructor :: !SemanticTokenTypes+ , stClass :: !SemanticTokenTypes+ , stTypeSynonym :: !SemanticTokenTypes+ , stTypeFamily :: !SemanticTokenTypes+ , stRecordField :: !SemanticTokenTypes+ } deriving (Generic, Show)+++instance Semigroup HsSemanticTokenType where+ -- one in higher enum is more specific+ a <> b = max a b++data SemanticTokenOriginal tokenType = SemanticTokenOriginal+ { _tokenType :: tokenType,+ _loc :: Loc,+ _name :: String+ }+ deriving (Eq, Ord)++--+instance (Show tokenType) => Show (SemanticTokenOriginal tokenType) where+ show (SemanticTokenOriginal tk loc name) = show loc <> " " <> show tk <> " " <> show name++data Loc = Loc+ { _line :: UInt,+ _startChar :: UInt,+ _len :: UInt+ }+ deriving (Eq, Ord)++instance Show Loc where+ show (Loc line startChar len) = show line <> ":" <> show startChar <> "-" <> show (startChar + len)++type NameSemanticMap = NameEnv HsSemanticTokenType++data GetSemanticTokens = GetSemanticTokens+ deriving (Eq, Show, Typeable, Generic)++instance Hashable GetSemanticTokens++instance NFData GetSemanticTokens++data RangeHsSemanticTokenTypes = RangeHsSemanticTokenTypes {rangeSemanticMap :: M.Map Range HsSemanticTokenType}++instance NFData RangeHsSemanticTokenTypes where+ rnf :: RangeHsSemanticTokenTypes -> ()+ rnf (RangeHsSemanticTokenTypes a) = rwhnf a++instance Show RangeHsSemanticTokenTypes where+ show = const "GlobalNameMap"++type instance RuleResult GetSemanticTokens = RangeHsSemanticTokenTypes++data HieFunMaskKind kind where+ HieFreshFun :: HieFunMaskKind Type+ HieFromDiskFun :: A.Array TypeIndex Bool -> HieFunMaskKind TypeIndex++data SemanticLog+ = LogShake Shake.Log+ | LogNoAST FilePath+ | LogConfig SemanticTokensConfig+ | LogMsg String+ | LogNoVF+ deriving (Show)++instance Pretty SemanticLog where+ pretty theLog = case theLog of+ LogShake shakeLog -> pretty shakeLog+ LogNoAST path -> "no HieAst exist for file" <> pretty path+ LogNoVF -> "no VirtualSourceFile exist for file"+ LogConfig config -> "SemanticTokensConfig_: " <> pretty (show config)+ LogMsg msg -> "SemanticLog Debug Message: " <> pretty msg+
+ src/Ide/Plugin/SemanticTokens/Utils.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}+++module Ide.Plugin.SemanticTokens.Utils where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 (unpack)+import qualified Data.Map as Map+import Development.IDE (Position (..), Range (..))+import Development.IDE.GHC.Compat+import Ide.Plugin.SemanticTokens.Types+import Prelude hiding (span)++deriving instance Show DeclType+deriving instance Show BindType+deriving instance Show RecFieldContext++instance Show ContextInfo where+ show x = case x of+ Use -> "Use"+ MatchBind -> "MatchBind"+ IEThing _ -> "IEThing IEType" -- imported+ TyDecl -> "TyDecl"+ ValBind bt _ sp -> "ValBind of " <> show bt <> show sp+ PatternBind {} -> "PatternBind"+ ClassTyDecl _ -> "ClassTyDecl"+ Decl d _ -> "Decl of " <> show d+ TyVarBind _ _ -> "TyVarBind"+ RecField c _ -> "RecField of " <> show c+ EvidenceVarBind {} -> "EvidenceVarBind"+ EvidenceVarUse -> "EvidenceVarUse"++showCompactRealSrc :: RealSrcSpan -> String+showCompactRealSrc x = show (srcSpanStartLine x) <> ":" <> show (srcSpanStartCol x) <> "-" <> show (srcSpanEndCol x)++-- type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)]+showRefMap :: RefMap a -> String+showRefMap m = unlines+ [+ showIdentifier idn ++ ":"+ ++ "\n" ++ unlines [showSDocUnsafe (ppr span) ++ "\n" ++ showIdentifierDetails v | (span, v) <- spans]+ | (idn, spans) <- Map.toList m]++showIdentifierDetails :: IdentifierDetails a -> String+showIdentifierDetails x = show $ identInfo x++showIdentifier :: Identifier -> String+showIdentifier (Left x) = showSDocUnsafe (ppr x)+showIdentifier (Right x) = nameStableString x++showLocatedNames :: [LIdP GhcRn] -> String+showLocatedNames xs = unlines+ [ showSDocUnsafe (ppr locName) ++ " " ++ show (getLoc locName)+ | locName <- xs]++showClearName :: Name -> String+showClearName name = occNameString (occName name) <> ":" <> showSDocUnsafe (ppr name) <> ":" <> showNameType name++showName :: Name -> String+showName name = showSDocUnsafe (ppr name) <> ":" <> showNameType name++showNameType :: Name -> String+showNameType name+ | isWiredInName name = "WiredInName"+ | isSystemName name = "SystemName"+ | isInternalName name = "InternalName"+ | isExternalName name = "ExternalName"+ | otherwise = "UnknownName"++bytestringString :: ByteString -> String+bytestringString = map (toEnum . fromEnum) . unpack++spanNamesString :: [(Span, Name)] -> String+spanNamesString xs = unlines+ [ showSDocUnsafe (ppr span) ++ " " ++ showSDocUnsafe (ppr name)+ | (span, name) <- xs]++nameTypesString :: [(Name, Type)] -> String+nameTypesString xs = unlines+ [ showSDocUnsafe (ppr span) ++ " " ++ showSDocUnsafe (ppr name)+ | (span, name) <- xs]+++nameMapString :: NameSemanticMap -> [Name] -> String+nameMapString nsm names = unlines+ [ showSDocUnsafe (ppr name) ++ " " ++ show tokenType+ | name <- names+ , let tokenType = lookupNameEnv nsm name+ ]+++showSpan :: RealSrcSpan -> String+showSpan x = show (srcSpanStartLine x) <> ":" <> show (srcSpanStartCol x) <> "-" <> show (srcSpanEndCol x)+++-- rangeToCodePointRange+mkRange :: (Integral a1, Integral a2) => a1 -> a2 -> a2 -> Range+mkRange startLine startCol len =+ Range (Position (fromIntegral startLine) (fromIntegral startCol)) (Position (fromIntegral startLine) (fromIntegral $ startCol + len))
+ test/Main.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++import Control.Lens ((^?))+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (KeyValue (..), Value (..),+ object)+import Data.Default+import Data.Functor (void)+import Data.Map as Map hiding (map)+import Data.String (fromString)+import Data.Text hiding (length, map,+ unlines)+import qualified Data.Text as Text+import qualified Data.Text.Utf16.Rope as Rope+import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..))+import Development.IDE.Test (waitForBuildQueue)+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 Language.LSP.Test (Session (..),+ SessionConfig (ignoreConfigurationRequests),+ openDoc)+import qualified Language.LSP.Test as Test+import Language.LSP.VFS (VirtualFile (..))+import System.FilePath+import qualified Test.Hls as Test+import Test.Hls (PluginTestDescriptor,+ TestName, TestTree,+ TextDocumentIdentifier,+ defaultTestRunner,+ documentContents, fullCaps,+ goldenGitDiff,+ mkPluginTestDescriptor,+ pluginTestRecorder,+ runSessionWithServerInTmpDir,+ runSessionWithServerInTmpDir',+ testCase, testGroup,+ waitForAction, (@?=))+import qualified Test.Hls.FileSystem as FS+import Test.Hls.FileSystem (file, text)++testDataDir :: FilePath+testDataDir = "test" </> "testdata"++mkFs :: [FS.FileTree] -> FS.VirtualFileTree+mkFs = FS.mkVirtualFileTree testDataDir++semanticTokensPlugin :: Test.Hls.PluginTestDescriptor SemanticLog+semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor enabledSemanticDescriptor "SemanticTokens"+ where+ enabledSemanticDescriptor recorder plId =+ let semanticDescriptor = Ide.Plugin.SemanticTokens.descriptor recorder plId+ in semanticDescriptor+ { pluginConfigDescriptor =+ (pluginConfigDescriptor semanticDescriptor)+ { configInitialGenericConfig =+ (configInitialGenericConfig (pluginConfigDescriptor semanticDescriptor))+ { plcGlobalOn = True+ }+ }+ }++goldenWithHaskellAndCapsOutPut config plugin title tree path desc act =+ goldenGitDiff title (FS.vftOriginalRoot tree </> path <.> desc) $+ runSessionWithServerInTmpDir config plugin tree $+ fromString <$> do+ doc <- openDoc (path <.> "hs") "haskell"+ void waitForBuildQueue+ act doc++goldenWithSemanticTokensWithDefaultConfig :: TestName -> FilePath -> TestTree+goldenWithSemanticTokensWithDefaultConfig title path =+ goldenWithHaskellAndCapsOutPut+ def+ semanticTokensPlugin+ title+ (mkFs $ FS.directProject (path <.> "hs"))+ path+ "expected"+ (docSemanticTokensString def)++docSemanticTokensString :: SemanticTokensConfig-> TextDocumentIdentifier -> Session String+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 doc = do+ res <- Test.getSemanticTokens doc+ textContent <- documentContents doc+ let vfs = VirtualFile 0 0 (Rope.fromText textContent)+ case res ^? Language.LSP.Protocol.Types._L of+ Just tokens -> do+ either (error . show) pure $ recoverLspSemanticTokens vfs tokens+ _noTokens -> error "No tokens found"++semanticTokensClassTests :: TestTree+semanticTokensClassTests =+ testGroup+ "type class"+ [ goldenWithSemanticTokensWithDefaultConfig "golden type class" "TClass",+ goldenWithSemanticTokensWithDefaultConfig "imported class method InstanceClassMethodBind" "TInstanceClassMethodBind",+ goldenWithSemanticTokensWithDefaultConfig "imported class method TInstanceClassMethodUse" "TInstanceClassMethodUse",+ goldenWithSemanticTokensWithDefaultConfig "imported deriving" "TClassImportedDeriving"+ ]++semanticTokensValuePatternTests :: TestTree+semanticTokensValuePatternTests =+ testGroup+ "value and patterns "+ [ goldenWithSemanticTokensWithDefaultConfig "value bind" "TValBind",+ goldenWithSemanticTokensWithDefaultConfig "pattern match" "TPatternMatch",+ goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternbind"+ ]++mkSemanticConfig :: Value -> Config+mkSemanticConfig setting = def{plugins = Map.insert "SemanticTokens" conf (plugins def)}+ where+ conf = def{plcConfig = (\(Object obj) -> obj) setting }++modifySemantic :: Value -> Session ()+modifySemantic setting = Test.setHlsConfig $ mkSemanticConfig setting+++directFile :: FilePath -> Text -> [FS.FileTree]+directFile fp content =+ [ FS.directCradle [Text.pack fp]+ , file fp (text content)+ ]++semanticTokensConfigTest :: TestTree+semanticTokensConfigTest = testGroup "semantic token config test" [+ testCase "function to variable" $ do+ let content = Text.unlines ["module Hello where", "go _ = 1"]+ let fs = mkFs $ directFile "Hello.hs" content+ let funcVar = object ["functionToken" .= var]+ var :: String+ var = "variable"+ do+ recorder <- pluginTestRecorder+ Test.Hls.runSessionWithServerInTmpDir' (semanticTokensPlugin recorder)+ (mkSemanticConfig funcVar)+ def {ignoreConfigurationRequests = False}+ fullCaps+ fs $ do+ -- modifySemantic funcVar+ void waitForBuildQueue+ doc <- openDoc "Hello.hs" "haskell"+ void waitForBuildQueue+ result1 <- docLspSemanticTokensString doc+ liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n"+ ]++semanticTokensTests :: TestTree+semanticTokensTests =+ testGroup+ "other semantic Token test"+ [ testCase "module import test" $ do+ let file1 = "TModuleA.hs"+ let file2 = "TModuleB.hs"+ let expect =+ [ SemanticTokenOriginal TVariable (Loc 5 1 2) "go",+ SemanticTokenOriginal TDataConstructor (Loc 5 6 4) "Game"+ ]+ Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1, file2]) $ do+ doc1 <- openDoc file1 "haskell"+ doc2 <- openDoc file2 "haskell"+ _check1 <- waitForAction "TypeCheck" doc1+ check2 <- waitForAction "TypeCheck" doc2+ case check2 of+ Right (WaitForIdeRuleResult _) -> return ()+ Left _ -> error "TypeCheck2 failed"++ textContent2 <- documentContents doc2+ let vfs = VirtualFile 0 0 (Rope.fromText textContent2)+ res2 <- Test.getSemanticTokens doc2+ case res2 ^? Language.LSP.Protocol.Types._L of+ Just tokens -> do+ either+ (error . show)+ (\xs -> liftIO $ xs @?= expect)+ $ recoverSemanticTokens def vfs tokens+ return ()+ _ -> error "No tokens found"+ liftIO $ 1 @?= 1,+ goldenWithSemanticTokensWithDefaultConfig "mixed constancy test result generated from one ghc version" "T1",+ goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSynonym",+ goldenWithSemanticTokensWithDefaultConfig "type family" "TTypefamily",+ goldenWithSemanticTokensWithDefaultConfig "TUnicodeSyntax" "TUnicodeSyntax"+ ]++semanticTokensDataTypeTests :: TestTree+semanticTokensDataTypeTests =+ testGroup+ "get semantic Tokens"+ [ goldenWithSemanticTokensWithDefaultConfig "simple datatype" "TDataType",+ goldenWithSemanticTokensWithDefaultConfig "record" "TRecord",+ goldenWithSemanticTokensWithDefaultConfig "record With DuplicateRecordFields" "TRecordDuplicateRecordFields",+ goldenWithSemanticTokensWithDefaultConfig "datatype import" "TDatatypeImported",+ goldenWithSemanticTokensWithDefaultConfig "datatype family" "TDataFamily",+ goldenWithSemanticTokensWithDefaultConfig "GADT" "TGADT"+ ]++semanticTokensFunctionTests :: TestTree+semanticTokensFunctionTests =+ testGroup+ "get semantic of functions"+ [ goldenWithSemanticTokensWithDefaultConfig "functions" "TFunction",+ goldenWithSemanticTokensWithDefaultConfig "local functions" "TFunctionLocal",+ goldenWithSemanticTokensWithDefaultConfig "function in let binding" "TFunctionLet",+ goldenWithSemanticTokensWithDefaultConfig "negative case non-function with constraint" "TNoneFunctionWithConstraint"+ ]++main :: IO ()+main =+ defaultTestRunner $+ testGroup+ "Semantic tokens"+ [ semanticTokensTests,+ semanticTokensClassTests,+ semanticTokensDataTypeTests,+ semanticTokensValuePatternTests,+ semanticTokensFunctionTests,+ semanticTokensConfigTest+ ]
+ test/testdata/T1.hs view
@@ -0,0 +1,48 @@+-- patter syn+{-# LANGUAGE PatternSynonyms #-}++module Main where++-- import Data.Set (Set, insert)+++data Foo = Foo { foo :: Int }++class Boo a where+ boo :: a -> a++instance Boo Int where+ boo x = x + 1++data Dd = Dd Int++pattern One = Foo 1++ggg = One++data Doo = Doo Prelude.Int+type Bar1 = Int+type Bar2 = Doo++bb :: (Boo a) => a -> a+bb x = boo x+aa :: cool -> Int -> cool+aa x = \c -> aa x c+ where (xx, yy) = (1, 2)+ dd = 1++(zz, kk) = (1, 2)+cc :: Foo -> (Int, Int) -> Int+cc f (gg, vv)=+ case gg of+ 1 -> foo $ f { foo = 1 }+ 2 -> foo $ f { foo = 1 }++go = foo+add = (Prelude.+)++-- sub :: Int -> Int -> Int+-- sub x y = add x y++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ test/testdata/TClass.hs view
@@ -0,0 +1,6 @@+module TClass where+++class Foo a where+ foo :: a -> Int+
+ test/testdata/TClassImportedDeriving.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE StandaloneDeriving #-}+module TClassImportedDeriving where+-- deriving method source span of Show occurrence+data Foo = Foo deriving (Show)++-- standalone deriving method not in the same position+-- deriving instance Eq Foo++-- a :: Foo -> Foo -> Bool+-- a = (==)
+ test/testdata/TDataFamily.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeFamilies #-}+module TDatafamily where++-- Declare a list-like data family+data family XList a++-- Declare a list-like instance for Char+data instance XList Char = XCons !Char !(XList Char) | XNil++-- Declare a number-like instance for ()+data instance XList () = XListUnit !Int
+ test/testdata/TDataType.hs view
@@ -0,0 +1,3 @@+module TDataType where++data Foo = Foo Int deriving (Eq)
+ test/testdata/TDatatypeImported.hs view
@@ -0,0 +1,6 @@+module TDatatypeImported where++import System.IO++go :: IO ()+go = print 1
+ test/testdata/TFunction.hs view
@@ -0,0 +1,7 @@+module TFunction where++f :: forall a. a -> a+f x = x++x :: a+x = undefined
+ test/testdata/TFunctionLet.hs view
@@ -0,0 +1,4 @@+module TFunctionLet where++y :: Int+y = let f x = 1 in 1
+ test/testdata/TFunctionLocal.hs view
@@ -0,0 +1,8 @@+module TFunctionLocal where++f :: Int -> Int+f 1 = g 1+ where+ g x = 1++
+ test/testdata/TGADT.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+module TGADT where++data Lam :: * -> * where+ Lift :: a -> Lam a -- ^ lifted value+ Lam :: (Lam a -> Lam b) -> Lam (a -> b) -- ^ lambda abstraction
+ test/testdata/TInstanceClassMethodBind.hs view
@@ -0,0 +1,6 @@+module TInstanceClassMethodBind where+++data Foo = Foo Int+instance Eq Foo where+ (==) = undefined
+ test/testdata/TInstanceClassMethodUse.hs view
@@ -0,0 +1,5 @@+module TInstanceClassMethodUse where+++go = (==)+
+ test/testdata/TModuleA.hs view
@@ -0,0 +1,3 @@+module TModuleA where++data Game = Game Int
+ test/testdata/TModuleB.hs view
@@ -0,0 +1,5 @@+module TModuleB where++import TModuleA++go = Game 1
+ test/testdata/TNoneFunctionWithConstraint.hs view
@@ -0,0 +1,5 @@+module TNoneFunctionWithConstraint where++x :: (Eq a) => a+x = undefined+
+ test/testdata/TPatternMatch.hs view
@@ -0,0 +1,6 @@+module TPatternMatch where+++g (Nothing, _) = 1++
+ test/testdata/TPatternSynonym.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PatternSynonyms #-}+module TPatternSynonym where+++pattern Foo = 1++
+ test/testdata/TPatternbind.hs view
@@ -0,0 +1,9 @@+module TVariable where++(a, b) = (1, 2)++f g y = g y++++
+ test/testdata/TRecord.hs view
@@ -0,0 +1,7 @@+module TRecord where+++data Foo = Foo { foo :: Int }+++
+ test/testdata/TRecordDuplicateRecordFields.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE DuplicateRecordFields #-}++module TRecordDuplicateRecordFields where++data Foo = Foo { boo :: !String }
+ test/testdata/TTypefamily.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies #-}+module TTypefamily where++type family Foo a where+ Foo Int = Int+ Foo a = String
+ test/testdata/TUnicodeSyntax.hs view
@@ -0,0 +1,5 @@+module TUnicodeSyntax where++a𐐀b = "a𐐀b"++
+ test/testdata/TValBind.hs view
@@ -0,0 +1,8 @@+module TValBind where+++hello :: Int+hello = length "Hello, Haskell!"+++