diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/hls-semantic-tokens-plugin.cabal b/hls-semantic-tokens-plugin.cabal new file mode 100644 --- /dev/null +++ b/hls-semantic-tokens-plugin.cabal @@ -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 + +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 diff --git a/src/Ide/Plugin/SemanticTokens.hs b/src/Ide/Plugin/SemanticTokens.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/SemanticTokens.hs @@ -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 + } + } diff --git a/src/Ide/Plugin/SemanticTokens/Internal.hs b/src/Ide/Plugin/SemanticTokens/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -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) diff --git a/src/Ide/Plugin/SemanticTokens/Mappings.hs b/src/Ide/Plugin/SemanticTokens/Mappings.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/SemanticTokens/Mappings.hs @@ -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. diff --git a/src/Ide/Plugin/SemanticTokens/Query.hs b/src/Ide/Plugin/SemanticTokens/Query.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/SemanticTokens/Query.hs @@ -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) + [] diff --git a/src/Ide/Plugin/SemanticTokens/SemanticConfig.hs b/src/Ide/Plugin/SemanticTokens/SemanticConfig.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/SemanticTokens/SemanticConfig.hs @@ -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] diff --git a/src/Ide/Plugin/SemanticTokens/Types.hs b/src/Ide/Plugin/SemanticTokens/Types.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/SemanticTokens/Types.hs @@ -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 + diff --git a/src/Ide/Plugin/SemanticTokens/Utils.hs b/src/Ide/Plugin/SemanticTokens/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/SemanticTokens/Utils.hs @@ -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)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/testdata/T1.hs b/test/testdata/T1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T1.hs @@ -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!" diff --git a/test/testdata/TClass.hs b/test/testdata/TClass.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TClass.hs @@ -0,0 +1,6 @@ +module TClass where + + +class Foo a where + foo :: a -> Int + diff --git a/test/testdata/TClassImportedDeriving.hs b/test/testdata/TClassImportedDeriving.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TClassImportedDeriving.hs @@ -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 = (==) diff --git a/test/testdata/TDataFamily.hs b/test/testdata/TDataFamily.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TDataFamily.hs @@ -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 diff --git a/test/testdata/TDataType.hs b/test/testdata/TDataType.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TDataType.hs @@ -0,0 +1,3 @@ +module TDataType where + +data Foo = Foo Int deriving (Eq) diff --git a/test/testdata/TDatatypeImported.hs b/test/testdata/TDatatypeImported.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TDatatypeImported.hs @@ -0,0 +1,6 @@ +module TDatatypeImported where + +import System.IO + +go :: IO () +go = print 1 diff --git a/test/testdata/TFunction.hs b/test/testdata/TFunction.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TFunction.hs @@ -0,0 +1,7 @@ +module TFunction where + +f :: forall a. a -> a +f x = x + +x :: a +x = undefined diff --git a/test/testdata/TFunctionLet.hs b/test/testdata/TFunctionLet.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TFunctionLet.hs @@ -0,0 +1,4 @@ +module TFunctionLet where + +y :: Int +y = let f x = 1 in 1 diff --git a/test/testdata/TFunctionLocal.hs b/test/testdata/TFunctionLocal.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TFunctionLocal.hs @@ -0,0 +1,8 @@ +module TFunctionLocal where + +f :: Int -> Int +f 1 = g 1 + where + g x = 1 + + diff --git a/test/testdata/TGADT.hs b/test/testdata/TGADT.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TGADT.hs @@ -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 diff --git a/test/testdata/TInstanceClassMethodBind.hs b/test/testdata/TInstanceClassMethodBind.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TInstanceClassMethodBind.hs @@ -0,0 +1,6 @@ +module TInstanceClassMethodBind where + + +data Foo = Foo Int +instance Eq Foo where + (==) = undefined diff --git a/test/testdata/TInstanceClassMethodUse.hs b/test/testdata/TInstanceClassMethodUse.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TInstanceClassMethodUse.hs @@ -0,0 +1,5 @@ +module TInstanceClassMethodUse where + + +go = (==) + diff --git a/test/testdata/TModuleA.hs b/test/testdata/TModuleA.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TModuleA.hs @@ -0,0 +1,3 @@ +module TModuleA where + +data Game = Game Int diff --git a/test/testdata/TModuleB.hs b/test/testdata/TModuleB.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TModuleB.hs @@ -0,0 +1,5 @@ +module TModuleB where + +import TModuleA + +go = Game 1 diff --git a/test/testdata/TNoneFunctionWithConstraint.hs b/test/testdata/TNoneFunctionWithConstraint.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TNoneFunctionWithConstraint.hs @@ -0,0 +1,5 @@ +module TNoneFunctionWithConstraint where + +x :: (Eq a) => a +x = undefined + diff --git a/test/testdata/TPatternMatch.hs b/test/testdata/TPatternMatch.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TPatternMatch.hs @@ -0,0 +1,6 @@ +module TPatternMatch where + + +g (Nothing, _) = 1 + + diff --git a/test/testdata/TPatternSynonym.hs b/test/testdata/TPatternSynonym.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TPatternSynonym.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module TPatternSynonym where + + +pattern Foo = 1 + + diff --git a/test/testdata/TPatternbind.hs b/test/testdata/TPatternbind.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TPatternbind.hs @@ -0,0 +1,9 @@ +module TVariable where + +(a, b) = (1, 2) + +f g y = g y + + + + diff --git a/test/testdata/TRecord.hs b/test/testdata/TRecord.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TRecord.hs @@ -0,0 +1,7 @@ +module TRecord where + + +data Foo = Foo { foo :: Int } + + + diff --git a/test/testdata/TRecordDuplicateRecordFields.hs b/test/testdata/TRecordDuplicateRecordFields.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TRecordDuplicateRecordFields.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module TRecordDuplicateRecordFields where + +data Foo = Foo { boo :: !String } diff --git a/test/testdata/TTypefamily.hs b/test/testdata/TTypefamily.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TTypefamily.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module TTypefamily where + +type family Foo a where + Foo Int = Int + Foo a = String diff --git a/test/testdata/TUnicodeSyntax.hs b/test/testdata/TUnicodeSyntax.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TUnicodeSyntax.hs @@ -0,0 +1,5 @@ +module TUnicodeSyntax where + +a𐐀b = "a𐐀b" + + diff --git a/test/testdata/TValBind.hs b/test/testdata/TValBind.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TValBind.hs @@ -0,0 +1,8 @@ +module TValBind where + + +hello :: Int +hello = length "Hello, Haskell!" + + +