From 75a59ab1e22dee596d2efed6ce37d1d53317a82f Mon Sep 17 00:00:00 2001 From: Fendor Date: Thu, 4 Jan 2024 16:34:00 +0100 Subject: [PATCH 1/5] Switch to haskell-actions/setup since the haskell/actions is deprecated --- .github/actions/setup-build/action.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/actions/setup-build/action.yml b/.github/actions/setup-build/action.yml index e4480db5cc8..9bb311ddc70 100644 --- a/.github/actions/setup-build/action.yml +++ b/.github/actions/setup-build/action.yml @@ -31,7 +31,7 @@ runs: sudo chown -R $USER /usr/local/.ghcup shell: bash - - uses: haskell/actions/setup@v2.4.7 + - uses: haskell-actions/setup@v2.6.0 id: HaskEnvSetup with: ghc-version : ${{ inputs.ghc }} From 37925a03b419235a472966617011a4da1c07ee33 Mon Sep 17 00:00:00 2001 From: Patrick Wales Date: Sat, 6 Jan 2024 21:09:19 +0800 Subject: [PATCH 2/5] Implement semantic tokens plugin to support semantic highlighting(textDocument/semanticTokens/full) (#3892) * Implement semantic tokens lsp plugin draft * SemanticTokens: combine information extracted from HieAst * clean up * map to default token types in lsp * use lsp makeSemanticTokens to convert to lsp SemanticTokens type * add test and cleanup * refine semantic type to default one in lsp * Use tokens from hieAst instead of renamedSource and add test * use customize RefMap to get semantic type * use refMap from useAsts * Also compute imported names * Also compute semantic type from TyThing * Fix dependencies version * fix version * Retrieve nameSet from renamedSource to prevent names not visible(Such as by instance deriving) being handled * add hlint config to ignore test data * cean up test data * revert flake.nix * Rename query.hs to Query.hs * Build: add semantic tokens to lts21 * Refactor and add README * Semantic token, filter names in Ast * CI: add consistancy check for wether semantic tokens computations is stable across different ghc versions * Update documentation, cleanup test, remove default modifiers * Fix: IO now classfied to TTypcon, add test for GADT and data family, Update documentation * Restore stack.yaml * fix stack build * Refactor, move out ActualToken to Mappings and use ide logger * Refactor: toLspTokenType should return Maybe type * Stop use stale hieAst * add getImportedNameSemanticRule rule to semantic tokens plugin * do not retrieve hie in getImportedNameSemanticRule * fix: add description for semantic tokens * remove TValBind and TPaternBind and Use TFunction and TVariable instead * cleanup * Refactor useWithStaleMT and took care of the token range using position map * fix build for 9.4 * refactor, use golden test * refactor, use ExceptT for computeSemanticTokens * Fix 9.2 * add persistentSemanticMapRule to prevent semantic tokens block on startup * Fix, use hieKind instead of cast the type directly * add options to turn semantic tokens on and off * Disable stan plugin by default (#3917) * Fix positionMapping in stale data (#3920) * Fix positionMapping in stale data * add test for updatePositionMapping * add comment to demonstrate addOldDelta * cleanup * fix: for local variable, extract type from contextInfo instead of bind site, thus function in pattern binds can also be indentified * clean up * Update plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs Co-authored-by: Michael Peyton Jones * refactor: remove TNothing and compact the test output * refactor: rename SemanticTokenType to HsSemanticTokenType to avoid confusion with lsp' SemanticTokenTypes * refactor: push the computation of semantic token type to getSemanticTokensRule * update documentation * cleanup hieAstSpanNames * remove renamed source from getSemanticTokensRule and optimize query function for semantic token type * try to exclude names that is not visible in hie and cleanup * add HieFunMaskKind, it is to differ wether a type at type index is a function or non-function * expose function flag to expose (=>, ->, -=>, ==>) * 1. Relax GetDocMap kindMap to get TyThing for more than type variables. 2. Backport isVisibleFunArg * use customize logger, add test for unicode * fix: handle unicode in semantic tokens * update KindMap to TyThingMap * cleanup * add realSrcSpanToCodePointRange, realSrcLocToCodePointPosition to Development.IDE.GHC.Error * add Note [Semantic information from Multiple Sources] * move recoverFunMaskArray to Mappings.hs * fix test, data.Set might not appear * fix: handle semantic tokens with more than one ast * fix: instance PluginMethod Request Method_TextDocumentSemanticTokensFull * clean up * turn semantic tokens off by default * fix doc * clean up doc --------- Co-authored-by: fendor Co-authored-by: Michael Peyton Jones --- cabal.project | 9 +- ghcide/src/Development/IDE/Core/RuleTypes.hs | 8 +- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 26 ++- ghcide/src/Development/IDE/GHC/Error.hs | 26 +++ .../src/Development/IDE/Plugin/Completions.hs | 4 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 4 +- ghcide/src/Development/IDE/Spans/Common.hs | 4 +- .../Development/IDE/Spans/Documentation.hs | 5 +- haskell-language-server.cabal | 12 + hls-plugin-api/src/Ide/Plugin/Config.hs | 1 + hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 2 + hls-plugin-api/src/Ide/Types.hs | 11 +- .../hls-semantic-tokens-plugin/.hlint.yaml | 1 + plugins/hls-semantic-tokens-plugin/LICENSE | 201 ++++++++++++++++ plugins/hls-semantic-tokens-plugin/README.md | 66 ++++++ .../hls-semantic-tokens-plugin.cabal | 85 +++++++ .../src/Ide/Plugin/SemanticTokens.hs | 20 ++ .../src/Ide/Plugin/SemanticTokens/Internal.hs | 136 +++++++++++ .../src/Ide/Plugin/SemanticTokens/Mappings.hs | 220 ++++++++++++++++++ .../src/Ide/Plugin/SemanticTokens/Query.hs | 115 +++++++++ .../src/Ide/Plugin/SemanticTokens/Types.hs | 97 ++++++++ .../src/Ide/Plugin/SemanticTokens/Utils.hs | 101 ++++++++ .../hls-semantic-tokens-plugin/test/Main.hs | 214 +++++++++++++++++ .../test/testdata/T1.expected | 79 +++++++ .../test/testdata/T1.hs | 48 ++++ .../test/testdata/TClass.expected | 5 + .../test/testdata/TClass.hs | 6 + .../testdata/TClassImportedDeriving.expected | 3 + .../test/testdata/TClassImportedDeriving.hs | 10 + .../test/testdata/TDataFamily.expected | 12 + .../test/testdata/TDataType.expected | 4 + .../test/testdata/TDatafamily.hs | 11 + .../test/testdata/TDatatype.hs | 3 + .../test/testdata/TDatatypeImported.expected | 4 + .../test/testdata/TDatatypeImported.hs | 6 + .../test/testdata/TFunction.expected | 11 + .../test/testdata/TFunction.hs | 7 + .../test/testdata/TFunctionLet.expected | 5 + .../test/testdata/TFunctionLet.hs | 4 + .../test/testdata/TFunctionLocal.expected | 7 + .../test/testdata/TFunctionLocal.hs | 8 + .../test/testdata/TGADT.expected | 13 ++ .../test/testdata/TGADT.hs | 7 + .../TInstanceClassMethodBind.expected | 7 + .../test/testdata/TInstanceClassMethodBind.hs | 6 + .../testdata/TInstanceClassMethodUse.expected | 2 + .../test/testdata/TInstanceClassMethodUse.hs | 5 + .../test/testdata/TModuleA.hs | 3 + .../test/testdata/TModuleB.hs | 5 + .../TNoneFunctionWithConstraint.expected | 6 + .../testdata/TNoneFunctionWithConstraint.hs | 5 + .../test/testdata/TPatternMatch.expected | 2 + .../test/testdata/TPatternMatch.hs | 6 + .../test/testdata/TPatternSyn.expected | 1 + .../test/testdata/TPatternbind.expected | 7 + .../test/testdata/TPatternbind.hs | 9 + .../test/testdata/TPatternsyn.hs | 7 + .../test/testdata/TRecord.expected | 4 + .../test/testdata/TRecord.hs | 7 + .../test/testdata/TTypefamily.expected | 8 + .../test/testdata/TTypefamily.hs | 6 + .../test/testdata/TUnicodeSyntax.expected | 1 + .../test/testdata/TUnicodeSyntax.hs | 5 + .../test/testdata/TValBind.expected | 4 + .../test/testdata/TValBind.hs | 8 + src/HlsPlugins.hs | 8 + stack-lts21.yaml | 1 + stack.yaml | 1 + .../schema/ghc92/default-config.golden.json | 3 + .../ghc92/vscode-extension-schema.golden.json | 6 + .../schema/ghc94/default-config.golden.json | 3 + .../ghc94/vscode-extension-schema.golden.json | 6 + .../schema/ghc96/default-config.golden.json | 3 + .../ghc96/vscode-extension-schema.golden.json | 6 + .../schema/ghc98/default-config.golden.json | 3 + .../ghc98/vscode-extension-schema.golden.json | 6 + 76 files changed, 1756 insertions(+), 25 deletions(-) create mode 100644 plugins/hls-semantic-tokens-plugin/.hlint.yaml create mode 100644 plugins/hls-semantic-tokens-plugin/LICENSE create mode 100644 plugins/hls-semantic-tokens-plugin/README.md create mode 100644 plugins/hls-semantic-tokens-plugin/hls-semantic-tokens-plugin.cabal create mode 100644 plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs create mode 100644 plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs create mode 100644 plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs create mode 100644 plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs create mode 100644 plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs create mode 100644 plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/Main.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TDatafamily.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TDatatype.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSyn.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TPatternsyn.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs diff --git a/cabal.project b/cabal.project index d68a81b15ee..a12e78a84a1 100644 --- a/cabal.project +++ b/cabal.project @@ -34,6 +34,7 @@ packages: ./plugins/hls-explicit-record-fields-plugin ./plugins/hls-refactor-plugin ./plugins/hls-overloaded-record-dot-plugin + ./plugins/hls-semantic-tokens-plugin index-state: 2023-12-13T00:00:00Z @@ -55,8 +56,8 @@ constraints: text -simdutf, ghc-check -ghc-check-use-package-abis, ghc-lib-parser-ex -auto, - -- This is only present in some versions, and it's on by default since - -- 0.14.5.0, but there are some versions we allow that need this + -- This is only present in some versions, and it's on by default since + -- 0.14.5.0, but there are some versions we allow that need this -- setting stylish-haskell +ghc-lib, -- Centos 7 comes with an old gcc version that doesn't know about @@ -79,8 +80,8 @@ source-repository-package -- END DELETE if impl(ghc >= 9.1) - -- ekg packagess are old and unmaintained, but we - -- don't rely on them for the mainline build, so + -- ekg packagess are old and unmaintained, but we + -- don't rely on them for the mainline build, so -- this is okay allow-newer: ekg-json:base, diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 30251ee8d3c..995bbc023e5 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -238,14 +238,14 @@ type instance RuleResult GetHieAst = HieAstResult -- | A IntervalMap telling us what is in scope at each point type instance RuleResult GetBindings = Bindings -data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap} -instance NFData DocAndKindMap where +data DocAndTyThingMap = DKMap {getDocMap :: !DocMap, getTyThingMap :: !TyThingMap} +instance NFData DocAndTyThingMap where rnf (DKMap a b) = rwhnf a `seq` rwhnf b -instance Show DocAndKindMap where +instance Show DocAndTyThingMap where show = const "docmap" -type instance RuleResult GetDocMap = DocAndKindMap +type instance RuleResult GetDocMap = DocAndTyThingMap -- | A GHC session that we reuse. type instance RuleResult GhcSession = HscEnvEq diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index bb57f602b71..caee9d5685f 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -407,6 +407,7 @@ module Development.IDE.GHC.Compat.Core ( field_label, #endif groupOrigin, + isVisibleFunArg, ) where import qualified GHC @@ -431,13 +432,13 @@ import GHC.Core.DataCon hiding (dataConExTyCoVars) import qualified GHC.Core.DataCon as DataCon import GHC.Core.FamInstEnv hiding (pprFamInst) import GHC.Core.InstEnv -import GHC.Types.Unique.FM +import GHC.Types.Unique.FM import GHC.Core.PatSyn import GHC.Core.Predicate import GHC.Core.TyCo.Ppr import qualified GHC.Core.TyCo.Rep as TyCoRep import GHC.Core.TyCon -import GHC.Core.Type +import GHC.Core.Type import GHC.Core.Unify import GHC.Core.Utils import GHC.Driver.CmdLine (Warn (..)) @@ -489,6 +490,8 @@ import qualified GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique.Supply import GHC.Types.Var (Var (varName), setTyVarUnique, setVarUnique) + +import qualified GHC.Types.Var as TypesVar import GHC.Unit.Info (PackageName (..)) import GHC.Unit.Module hiding (ModLocation (..), UnitId, moduleUnit, @@ -597,7 +600,7 @@ pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y pattern AvailTC :: Name -> [Name] -> [FieldLabel] -> Avail.AvailInfo #if __GLASGOW_HASKELL__ >= 907 pattern AvailTC n names pieces <- Avail.AvailTC n ((,[]) -> (names,pieces)) -#else +#else pattern AvailTC n names pieces <- Avail.AvailTC n ((\gres -> foldr (\gre (names, pieces) -> case gre of Avail.NormalGreName name -> (name: names, pieces) Avail.FieldGreName label -> (names, label:pieces)) ([], []) gres) -> (names, pieces)) @@ -606,14 +609,14 @@ pattern AvailTC n names pieces <- Avail.AvailTC n ((\gres -> foldr (\gre (names, pattern AvailName :: Name -> Avail.AvailInfo #if __GLASGOW_HASKELL__ >= 907 pattern AvailName n <- Avail.Avail n -#else +#else pattern AvailName n <- Avail.Avail (Avail.NormalGreName n) #endif pattern AvailFL :: FieldLabel -> Avail.AvailInfo #if __GLASGOW_HASKELL__ >= 907 pattern AvailFL fl <- (const Nothing -> Just fl) -- this pattern always fails as this field was removed in 9.7 -#else +#else pattern AvailFL fl <- Avail.Avail (Avail.FieldGreName fl) #endif @@ -630,8 +633,17 @@ pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr #endif -pattern FunTy :: Type -> Type -> Type -pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} +#if __GLASGOW_HASKELL__ >= 906 +isVisibleFunArg = TypesVar.isVisibleFunArg +type FunTyFlag = TypesVar.FunTyFlag +#else +isVisibleFunArg VisArg = True +isVisibleFunArg _ = False +type FunTyFlag = TypesVar.AnonArgFlag +#endif +pattern FunTy :: Development.IDE.GHC.Compat.Core.FunTyFlag -> Type -> Type -> Type +pattern FunTy af arg res <- TyCoRep.FunTy {ft_af = af, ft_arg = arg, ft_res = res} + -- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) -- type HasSrcSpan x = () :: Constraint diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index 8b5c9edc297..c9fe0153d34 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -17,6 +17,8 @@ module Development.IDE.GHC.Error , realSrcSpanToRange , realSrcLocToPosition , realSrcSpanToLocation + , realSrcSpanToCodePointRange + , realSrcLocToCodePointPosition , srcSpanToFilename , rangeToSrcSpan , rangeToRealSrcSpan @@ -45,6 +47,8 @@ import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import GHC import Language.LSP.Protocol.Types (isSubrangeOf) +import Language.LSP.VFS (CodePointPosition (CodePointPosition), + CodePointRange (CodePointRange)) diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic @@ -86,6 +90,28 @@ realSrcLocToPosition :: RealSrcLoc -> Position realSrcLocToPosition real = Position (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real - 1) +-- Note [Unicode support] +-- the current situation is: +-- LSP Positions use UTF-16 code units(Unicode may count as variable columns); +-- GHC use Unicode code points(Unicode count as one column). +-- To support unicode, ideally range should be in lsp standard, +-- and codePoint should be in ghc standard. +-- see https://github.com/haskell/lsp/pull/407 + +-- | Convert a GHC SrcSpan to CodePointRange +-- see Note [Unicode support] +realSrcSpanToCodePointRange :: RealSrcSpan -> CodePointRange +realSrcSpanToCodePointRange real = + CodePointRange + (realSrcLocToCodePointPosition $ Compat.realSrcSpanStart real) + (realSrcLocToCodePointPosition $ Compat.realSrcSpanEnd real) + +-- | Convert a GHC RealSrcLoc to CodePointPosition +-- see Note [Unicode support] +realSrcLocToCodePointPosition :: RealSrcLoc -> CodePointPosition +realSrcLocToCodePointPosition real = + CodePointPosition (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real - 1) + -- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones) -- FIXME This may not be an _absolute_ file name, needs fixing. srcSpanToFilename :: SrcSpan -> Maybe FilePath diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 2b3bcd93082..18d6bfa9828 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -144,8 +144,8 @@ resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} ur #endif mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file let (dm,km) = case mdkm of - Just (DKMap docMap kindMap, _) -> (docMap,kindMap) - Nothing -> (mempty, mempty) + Just (DKMap docMap tyThingMap, _) -> (docMap,tyThingMap) + Nothing -> (mempty, mempty) doc <- case lookupNameEnv dm name of Just doc -> pure $ spanDocToMarkdown doc Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 5f1c68b83b3..446e03271e0 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -209,7 +209,7 @@ gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos atPoint :: IdeOptions -> HieAstResult - -> DocAndKindMap + -> DocAndTyThingMap -> HscEnv -> Position -> IO (Maybe (Maybe Range, [T.Text])) @@ -346,7 +346,7 @@ namesInType (TyVarTy n) = [varName n] namesInType (AppTy a b) = getTypes [a,b] namesInType (TyConApp tc ts) = tyConName tc : getTypes ts namesInType (ForAllTy b t) = varName (binderVar b) : namesInType t -namesInType (FunTy a b) = getTypes [a,b] +namesInType (FunTy _ a b) = getTypes [a,b] namesInType (CastTy t _) = namesInType t namesInType (LitTy _) = [] namesInType _ = [] diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index 2ec1e98e94e..dbdacfcd5cb 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -12,7 +12,7 @@ module Development.IDE.Spans.Common ( , spanDocToMarkdown , spanDocToMarkdownForTest , DocMap -, KindMap +, TyThingMap ) where import Control.DeepSeq @@ -31,7 +31,7 @@ import qualified Documentation.Haddock.Parser as H import qualified Documentation.Haddock.Types as H type DocMap = NameEnv SpanDoc -type KindMap = NameEnv TyThing +type TyThingMap = NameEnv TyThing -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. #if MIN_VERSION_ghc(9,5,0) diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 7f74b936a0d..a5209005d56 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -39,7 +39,7 @@ mkDocMap :: HscEnv -> RefMap a -> TcGblEnv - -> IO DocAndKindMap + -> IO DocAndTyThingMap mkDocMap env rm this_mod = do #if MIN_VERSION_ghc(9,3,0) @@ -61,8 +61,7 @@ mkDocMap env rm this_mod = doc <- getDocumentationTryGhc env n pure $ extendNameEnv nameMap n doc getType n nameMap - | isTcOcc $ occName n - , Nothing <- lookupNameEnv nameMap n + | Nothing <- lookupNameEnv nameMap n = do kind <- lookupKind env n pure $ maybe nameMap (extendNameEnv nameMap n) kind | otherwise = pure nameMap diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index b99fd25ebdf..466875f0482 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -164,6 +164,11 @@ flag overloadedRecordDot default: True manual: True +flag semanticTokens + description: Enable semantic tokens plugin + default: True + manual: True + -- formatters flag floskell @@ -333,6 +338,12 @@ common refactor build-depends: hls-refactor-plugin == 2.5.0.0 cpp-options: -Dhls_refactor +common semanticTokens + if flag(semanticTokens) + build-depends: hls-semantic-tokens-plugin == 2.5.0.0 + cpp-options: -Dhls_semanticTokens + + library import: common-deps -- configuration @@ -365,6 +376,7 @@ library , stylishHaskell , refactor , overloadedRecordDot + , semanticTokens exposed-modules: Ide.Arguments diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 785a7a5a929..81e5b7e1b16 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -66,6 +66,7 @@ parsePluginConfig :: PluginConfig -> Value -> A.Parser PluginConfig parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig <$> o .:? "globalOn" .!= plcGlobalOn def <*> o .:? "callHierarchyOn" .!= plcCallHierarchyOn def + <*> o .:? "semanticTokensOn" .!= plcSemanticTokensOn def <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def <*> o .:? "codeLensOn" .!= plcCodeLensOn def <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index 6111de4a48c..da2751106c4 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -93,6 +93,7 @@ pluginsToDefaultConfig IdePlugins {..} = SMethod_TextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn] SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn] + SMethod_TextDocumentSemanticTokensFull -> ["semanticTokensOn" A..= plcSemanticTokensOn] _ -> [] -- | Generates json schema used in haskell vscode extension @@ -123,6 +124,7 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug SMethod_TextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols"] SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions"] SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy"] + SMethod_TextDocumentSemanticTokensFull -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens"] _ -> [] schemaEntry desc = A.object diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index e7969942949..d2cfc70d9e3 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -230,6 +230,7 @@ data PluginConfig = , plcRenameOn :: !Bool , plcSelectionRangeOn :: !Bool , plcFoldingRangeOn :: !Bool + , plcSemanticTokensOn :: !Bool , plcConfig :: !Object } deriving (Show,Eq) @@ -246,11 +247,12 @@ instance Default PluginConfig where , plcRenameOn = True , plcSelectionRangeOn = True , plcFoldingRangeOn = True + , plcSemanticTokensOn = True , plcConfig = mempty } instance ToJSON PluginConfig where - toJSON (PluginConfig g ch ca cl d h s c rn sr fr cfg) = r + toJSON (PluginConfig g ch ca cl d h s c rn sr fr st cfg) = r where r = object [ "globalOn" .= g , "callHierarchyOn" .= ch @@ -263,6 +265,7 @@ instance ToJSON PluginConfig where , "renameOn" .= rn , "selectionRangeOn" .= sr , "foldingRangeOn" .= fr + , "semanticTokensOn" .= st , "config" .= cfg ] @@ -514,6 +517,9 @@ instance PluginMethod Request Method_TextDocumentRangeFormatting where where pid = pluginId pluginDesc +instance PluginMethod Request Method_TextDocumentSemanticTokensFull where + handlesRequest = pluginEnabledWithFeature plcSemanticTokensOn + instance PluginMethod Request Method_TextDocumentPrepareCallHierarchy where handlesRequest = pluginEnabledWithFeature plcCallHierarchyOn @@ -751,6 +757,9 @@ instance PluginRequestMethod Method_CallHierarchyOutgoingCalls where instance PluginRequestMethod (Method_CustomMethod m) where combineResponses _ _ _ _ (x :| _) = x +instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where + combineResponses _ _ _ _ (x :| _) = x + takeLefts :: [a |? b] -> [a] takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x]) diff --git a/plugins/hls-semantic-tokens-plugin/.hlint.yaml b/plugins/hls-semantic-tokens-plugin/.hlint.yaml new file mode 100644 index 00000000000..072cf81614f --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/.hlint.yaml @@ -0,0 +1 @@ +- ignore: { "within": 'test/testdata/*.hs' } diff --git a/plugins/hls-semantic-tokens-plugin/LICENSE b/plugins/hls-semantic-tokens-plugin/LICENSE new file mode 100644 index 00000000000..261eeb9e9f8 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/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/plugins/hls-semantic-tokens-plugin/README.md b/plugins/hls-semantic-tokens-plugin/README.md new file mode 100644 index 00000000000..5d6be35ef56 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/README.md @@ -0,0 +1,66 @@ +# Semantic tokens (LSP) plugin for Haskell language server + +## Purpose + +The purpose of this plugin is to provide semantic tokens for the Haskell language server, +according to the [LSP specification](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens) +It can be used to provide semantic highlighting for Haskell code in editors by given semantic type and modifiers for some tokens. +A lot of editors support semantic highlighting through LSP, for example vscode, vim, emacs, etc. + +## Features + +### Semantic types and modifiers + +The handles request for semantic tokens for the whole file. +It supports semantic types and but not yet modifiers from the LSP specification. + +Default semantic types defined in lsp diverge greatly from the ones used in ghc. +But default semantic types allows user with less configuration to get semantic highlighting. +That is why we use default semantic types for now. By mapping ghc semantic types to lsp semantic types. +The mapping is defined in `Mapping.hs` file. + +### delta semantic tokens, range semantic tokens and refresh + +It is not yet support capabilities for delta semantic tokens, which might be +crucial for performance. +It should be implemented in the future. + +## checkList + +* Supported PluginMethodHandler + * [x] [textDocument/semanticTokens/full](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_fullRequest). + * [ ] [textDocument/semanticTokens/full/delta](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_deltaRequest) + * [ ] [workspace/semanticTokens/refresh](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_refreshRequest) + +* Supported semantic tokens type: + * [x] class and class method + * [x] type family name (data family) + * [x] data constructor name (not distinguishing record and normal data, and GADT) + * [x] type constructor name (GADT) + * [x] record field name + * [x] type synonym + * [x] pattern synonym + * [x] ~~pattern bindings~~ In favor of differing functions and none-functions from its type + * [x] ~~value bindings~~ In favor of differing functions and none-functions from its type + * [x] functions + * [x] none-function variables + * [x] imported name + +* Supported modifiers(planning): + * [future] declaration (as in class declearations, type definition and type family) + * [future] definition (as in class instance declaration, left hand side value binding, and type family instance) + * [future] modification (as in rec field update) + +## Implementation details + +* [x] Compute visible names from renamedsource +* [x] Compute `NameSemanticMap` for imported and top level name tokens using `HscEnv`(with deps) and type checked result +* [x] Compute current module `NameSemanticMap` using `RefMap a` from the result of `GetHieAst` +* [x] Compute all visible `(Name, Span)` in current module, in turn compute their semantic token using the combination map of the above two `NameSemanticMap` +* [x] use default legends, Candidates map of token type with default token type: [Maps to default token types](https://github.com/soulomoon/haskell-language-server/blob/master/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs) +* [x] add args support to turn the plugin on and off +* [x] enhence test +* [x] enhence error reporting. +* [x] computation of semantic tokens is pushed into rule `getSemanticTokensRule` +* [future] make use of modifiers +* [future] hadling customize legends using server capabilities (how?) diff --git a/plugins/hls-semantic-tokens-plugin/hls-semantic-tokens-plugin.cabal b/plugins/hls-semantic-tokens-plugin/hls-semantic-tokens-plugin.cabal new file mode 100644 index 00000000000..e0854733dca --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/hls-semantic-tokens-plugin.cabal @@ -0,0 +1,85 @@ +cabal-version: 2.4 +name: hls-semantic-tokens-plugin +version: 2.5.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.Utils + Ide.Plugin.SemanticTokens.Internal + + hs-source-dirs: src + build-depends: + , aeson + , base + , containers + , extra + , hiedb + , mtl >= 2.2 + , ghcide == 2.5.0.0 + , hls-plugin-api == 2.5.0.0 + , lens + , lsp >=2.3 + , sqlite-simple + , text + , unordered-containers + , transformers + , bytestring + , syb + , array + , deepseq + , hls-graph == 2.5.0.0 + + default-language: Haskell2010 + default-extensions: DataKinds + +test-suite tests + type: exitcode-stdio-1.0 + 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.5.0.0 + , ghcide-test-utils + , hls-plugin-api + , lens + , lsp + , ghc + , text-rope + , lsp-test + , text + , data-default + , bytestring + , ghcide == 2.5.0.0 + , hls-plugin-api == 2.5.0.0 diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs new file mode 100644 index 00000000000..2386827a2a1 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +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, + Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder <> Internal.persistentGetSemanticTokensRule, + pluginConfigDescriptor = + defaultConfigDescriptor + { configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False} + } + } diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs new file mode 100644 index 00000000000..9e69a213c87 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -0,0 +1,136 @@ +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnicodeSyntax #-} + +-- | +-- This module provides the core functionality of the plugin. +module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule) where + +import Control.Lens ((^.)) +import Control.Monad.Except (ExceptT, liftEither, + withExceptT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Except (runExceptT) +import qualified Data.Map as Map +import qualified Data.Text as T +import Development.IDE (Action, + GetDocMap (GetDocMap), + GetHieAst (GetHieAst), + HieAstResult (HAR, hieAst, hieModule, refMap), + IdeResult, IdeState, + Priority (..), Recorder, + Rules, WithPriority, + cmapWithPrio, define, + fromNormalizedFilePath, + hieKind, ideLogger, + logPriority, 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.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) + +logActionWith :: (MonadIO m) => IdeState -> Priority -> String -> m () +logActionWith st prior = liftIO . logPriority (ideLogger st) prior . T.pack + +----------------------- +---- the api +----------------------- + +computeSemanticTokens :: IdeState -> NormalizedFilePath -> ExceptT PluginError Action SemanticTokens +computeSemanticTokens st nfp = do + logActionWith st Debug $ "Computing semantic tokens:" <> show nfp + (RangeHsSemanticTokenTypes {rangeSemanticMap}, mapping) <- useWithStaleE GetSemanticTokens nfp + withExceptT PluginInternalError $ liftEither $ rangeSemanticMapSemanticTokens mapping rangeSemanticMap + +semanticTokensFull :: PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull +semanticTokensFull state _ param = do + nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) + items <- runActionE "SemanticTokens.semanticTokensFull" state $ computeSemanticTokens 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/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs new file mode 100644 index 00000000000..b369b0403c6 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs @@ -0,0 +1,220 @@ +{-# 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 :: HsSemanticTokenType -> SemanticTokenTypes +toLspTokenType tk = case tk of + -- Function type variable + TFunction -> SemanticTokenTypes_Function + -- None function type variable + TVariable -> SemanticTokenTypes_Variable + TClass -> SemanticTokenTypes_Class + TClassMethod -> SemanticTokenTypes_Method + TTypeVariable -> SemanticTokenTypes_TypeParameter + -- 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 + TTypeCon -> SemanticTokenTypes_Enum + TDataCon -> SemanticTokenTypes_EnumMember + TRecField -> SemanticTokenTypes_Property + -- pattern syn is like a limited version of macro of constructing a term + TPatternSyn -> SemanticTokenTypes_Macro + -- saturated type + TTypeSyn -> SemanticTokenTypes_Type + -- not sure if this is correct choice + TTypeFamily -> SemanticTokenTypes_Interface + +lspTokenReverseMap :: Map.Map SemanticTokenTypes HsSemanticTokenType +lspTokenReverseMap = Map.fromList $ map (\x -> (toLspTokenType x, x)) $ enumFrom minBound + +fromLspTokenType :: SemanticTokenTypes -> Maybe HsSemanticTokenType +fromLspTokenType tk = Map.lookup tk lspTokenReverseMap + +-- * 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 TRecField + | isClassOpId vid -> Just TClassMethod + | isFunVar vid -> Just TFunction + | otherwise -> Just TVariable + AConLike con -> case con of + RealDataCon _ -> Just TDataCon + PatSynCon _ -> Just TPatternSyn + ATyCon tyCon + | isTypeSynonymTyCon tyCon -> Just TTypeSyn + | isTypeFamilyTyCon tyCon -> Just TTypeFamily + | isClassTyCon tyCon -> Just TClass + -- fall back to TTypeCon the result + | otherwise -> Just TTypeCon + 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 TRecField + -- data constructor, type constructor, type synonym, type family + Decl ClassDec _ -> Just TClass + Decl DataDec _ -> Just TTypeCon + Decl ConDec _ -> Just TDataCon + Decl SynDec _ -> Just TTypeSyn + Decl FamDec _ -> Just TTypeFamily + -- instance dec is class method + Decl InstDec _ -> Just TClassMethod + Decl PatSynDec _ -> Just TPatternSyn + EvidenceVarUse -> Nothing + EvidenceVarBind {} -> Nothing + +-- * 4. Mapping from LSP tokens to SemanticTokenOriginal. + +-- | line, startChar, len, tokenType, modifiers +type ActualToken = (UInt, UInt, UInt, HsSemanticTokenType, UInt) + +-- | 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) +recoverSemanticTokens :: VirtualFile -> SemanticTokens -> Either Text [SemanticTokenOriginal] +recoverSemanticTokens vsf (SemanticTokens _ xs) = do + tokens <- dataActualToken xs + return $ mapMaybe (tokenOrigin sourceCode) tokens + where + sourceCode = unpack $ virtualFileText vsf + tokenOrigin :: [Char] -> ActualToken -> Maybe SemanticTokenOriginal + tokenOrigin sourceCode' (line, startChar, len, tokenType, _) = 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 [ActualToken] + dataActualToken dt = + maybe decodeError (Right . fmap semanticTokenAbsoluteActualToken . 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 + + semanticTokenAbsoluteActualToken :: SemanticTokenAbsolute -> ActualToken + semanticTokenAbsoluteActualToken (SemanticTokenAbsolute line startChar len tokenType _tokenModifiers) = + case fromLspTokenType tokenType of + Just t -> (line, startChar, len, t, 0) + Nothing -> error "semanticTokenAbsoluteActualToken: unknown token type" + + -- 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/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs new file mode 100644 index 00000000000..7758176d04c --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs @@ -0,0 +1,115 @@ +{-# 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) +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 name -> + isDerivedOccName (nameOccName name) + || any isEvidenceContext (S.toList infos) + +------------------------------------------------- + +-- * extract semantic tokens from NameSemanticMap + +------------------------------------------------- + +extractSemanticTokensFromNames :: NameSemanticMap -> M.Map Range NameSet -> M.Map Range HsSemanticTokenType +extractSemanticTokensFromNames nsm rnMap = Map.mapMaybe (foldMap (lookupNameEnv nsm) . nameSetElemsStable) rnMap + +rangeSemanticMapSemanticTokens :: PositionMapping -> M.Map Range HsSemanticTokenType -> Either Text SemanticTokens +rangeSemanticMapSemanticTokens mapping = + makeSemanticTokens defaultSemanticTokensLegend + . mapMaybe (\(range, ty) -> flip toAbsSemanticToken ty <$> range) + . Map.toAscList + . M.mapKeys (\r -> toCurrentRange mapping r) + 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 tokenType) + [] diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs new file mode 100644 index 00000000000..a6fb63c0c0a --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.SemanticTokens.Types where + +import Control.DeepSeq (NFData (rnf), rwhnf) +import qualified Data.Array as A +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 + +-- !!!! 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 + | TDataCon -- Data constructor + | TTypeVariable -- Type variable + | TClassMethod -- Class method + | TPatternSyn -- Pattern synonym + | TTypeCon -- Type (Type constructor) + | TClass -- Type class + | TTypeSyn -- Type synonym + | TTypeFamily -- type family + | TRecField -- from match bind + deriving (Eq, Ord, Show, Enum, Bounded) + +instance Semigroup HsSemanticTokenType where + -- one in higher enum is more specific + a <> b = max a b + +data SemanticTokenOriginal = SemanticTokenOriginal + { _tokenType :: HsSemanticTokenType, + _loc :: Loc, + _name :: String + } + deriving (Eq, Ord) + +-- +instance Show SemanticTokenOriginal 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 + | 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" diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs new file mode 100644 index 00000000000..fb29c147298 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/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/plugins/hls-semantic-tokens-plugin/test/Main.hs b/plugins/hls-semantic-tokens-plugin/test/Main.hs new file mode 100644 index 00000000000..56a8f473939 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/Main.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Arrow (Arrow ((***)), (&&&), + (+++)) +import Control.Lens hiding (use, (<.>)) +import Control.Monad (forM) +import Control.Monad.IO.Class (liftIO) +import Data.Bifunctor +import qualified Data.ByteString as BS +import Data.Data +import Data.Default +import Data.Functor (void) +import qualified Data.List as List +import Data.Map as Map hiding (map) +import Data.Maybe (fromJust) +import qualified Data.Maybe +import qualified Data.Set as Set +import Data.String (fromString) +import Data.Text hiding (length, map, + unlines) +import qualified Data.Text.Utf16.Rope as Rope +import Development.IDE (getFileContents, runAction, + toNormalizedUri) +import Development.IDE.Core.Rules (Log) +import Development.IDE.Core.Shake (getVirtualFile) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import Development.IDE.Test (waitForBuildQueue) +import Ide.Plugin.Error (getNormalizedFilePathE) +import Ide.Plugin.SemanticTokens +import Ide.Plugin.SemanticTokens.Mappings +import Ide.Plugin.SemanticTokens.Types +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types (SemanticTokens (..), + SemanticTokensParams (..), + _L, type (|?) (..)) +import qualified Language.LSP.Server as Lsp +import Language.LSP.Test (Session (..), openDoc) +import qualified Language.LSP.Test as Test +import Language.LSP.VFS (VirtualFile (..)) +import System.Environment.Blank +import System.FilePath +import Test.Hls (PluginTestDescriptor, + Session (..), TestName, + TestTree, + TextDocumentIdentifier, + defaultTestRunner, + documentContents, + goldenGitDiff, + mkPluginTestDescriptor, + mkPluginTestDescriptor', + runSessionWithServerInTmpDir, + testCase, testGroup, + waitForAction, (@?=)) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.Util (withCanonicalTempDir) + +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 + } + } + } + +mkSemanticTokensParams :: TextDocumentIdentifier -> SemanticTokensParams +mkSemanticTokensParams = SemanticTokensParams Nothing Nothing + +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 + r <- act doc + return r + +goldenWithSemanticTokens :: TestName -> FilePath -> TestTree +goldenWithSemanticTokens title path = + goldenWithHaskellAndCapsOutPut + def + semanticTokensPlugin + title + (mkFs $ FS.directProject (path <.> "hs")) + path + "expected" + docSemanticTokensString + +docSemanticTokensString :: TextDocumentIdentifier -> Session String +docSemanticTokensString doc = do + res <- Test.getSemanticTokens doc + textContent <- documentContents doc + let vfs = VirtualFile 0 0 (Rope.fromText textContent) + let expect = [] + case res ^? _L of + Just tokens -> do + either (error . show) (return . unlines . map show) $ recoverSemanticTokens vfs tokens + _noTokens -> error "No tokens found" + +semanticTokensImportedTests :: TestTree +semanticTokensImportedTests = + testGroup + "imported test" + [ goldenWithSemanticTokens "type class" "TClass" + ] + +semanticTokensClassTests :: TestTree +semanticTokensClassTests = + testGroup + "type class" + [ goldenWithSemanticTokens "golden type class" "TClass", + goldenWithSemanticTokens "imported class method InstanceClassMethodBind" "TInstanceClassMethodBind", + goldenWithSemanticTokens "imported class method TInstanceClassMethodUse" "TInstanceClassMethodUse", + goldenWithSemanticTokens "imported deriving" "TClassImportedDeriving" + ] + +semanticTokensValuePatternTests :: TestTree +semanticTokensValuePatternTests = + testGroup + "value and patterns " + [ goldenWithSemanticTokens "value bind" "TValBind", + goldenWithSemanticTokens "pattern match" "TPatternMatch", + goldenWithSemanticTokens "pattern bind" "TPatternbind" + ] + +semanticTokensTests :: TestTree +semanticTokensTests = + testGroup + "other semantic Token test" + [ testCase "module import test" $ do + let filePath1 = "./test/testdata/TModuleA.hs" + let filePath2 = "./test/testdata/TModuleB.hs" + + let file1 = "TModuleA.hs" + let file2 = "TModuleB.hs" + let expect = + [ SemanticTokenOriginal TVariable (Loc 5 1 2) "go", + SemanticTokenOriginal TDataCon (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 x) -> return () + Left y -> error "TypeCheck2 failed" + + res2 <- Test.getSemanticTokens doc2 + textContent2 <- documentContents doc2 + let vfs = VirtualFile 0 0 (Rope.fromText textContent2) + case res2 ^? _L of + Just tokens -> do + either + (error . show) + (\xs -> liftIO $ xs @?= expect) + $ recoverSemanticTokens vfs tokens + return () + _ -> error "No tokens found" + liftIO $ 1 @?= 1, + goldenWithSemanticTokens "mixed constancy test result generated from one ghc version" "T1", + goldenWithSemanticTokens "pattern bind" "TPatternSyn", + goldenWithSemanticTokens "type family" "TTypefamily", + goldenWithSemanticTokens "TUnicodeSyntax" "TUnicodeSyntax" + ] + +semanticTokensDataTypeTests = + testGroup + "get semantic Tokens" + [ goldenWithSemanticTokens "simple datatype" "TDataType", + goldenWithSemanticTokens "record" "TRecord", + goldenWithSemanticTokens "datatype import" "TDatatypeImported", + goldenWithSemanticTokens "datatype family" "TDataFamily", + goldenWithSemanticTokens "GADT" "TGADT" + ] + +semanticTokensFunctionTests = + testGroup + "get semantic of functions" + [ goldenWithSemanticTokens "functions" "TFunction", + goldenWithSemanticTokens "local functions" "TFunctionLocal", + goldenWithSemanticTokens "function in let binding" "TFunctionLet", + goldenWithSemanticTokens "negative case non-function with constraint" "TNoneFunctionWithConstraint" + ] + +main :: IO () +main = + defaultTestRunner $ + testGroup + "Semantic tokens" + [ semanticTokensTests, + semanticTokensClassTests, + semanticTokensDataTypeTests, + semanticTokensValuePatternTests, + semanticTokensFunctionTests + ] diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected new file mode 100644 index 00000000000..8e00ed86de3 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected @@ -0,0 +1,79 @@ +9:6-9 TTypeCon "Foo" +9:12-15 TDataCon "Foo" +9:18-21 TRecField "foo" +9:25-28 TTypeCon "Int" +11:7-10 TClass "Boo" +11:11-12 TTypeVariable "a" +12:3-6 TClassMethod "boo" +12:10-11 TTypeVariable "a" +12:15-16 TTypeVariable "a" +14:10-13 TClass "Boo" +14:14-17 TTypeCon "Int" +15:5-8 TClassMethod "boo" +15:9-10 TVariable "x" +15:13-14 TVariable "x" +15:15-16 TClassMethod "+" +17:6-8 TTypeCon "Dd" +17:11-13 TDataCon "Dd" +17:14-17 TTypeCon "Int" +19:9-12 TPatternSyn "One" +19:15-18 TDataCon "Foo" +21:1-4 TVariable "ggg" +21:7-10 TPatternSyn "One" +23:6-9 TTypeCon "Doo" +23:12-15 TDataCon "Doo" +23:16-27 TTypeCon "Prelude.Int" +24:6-10 TTypeSyn "Bar1" +24:13-16 TTypeCon "Int" +25:6-10 TTypeSyn "Bar2" +25:13-16 TTypeCon "Doo" +27:1-3 TFunction "bb" +27:8-11 TClass "Boo" +27:12-13 TTypeVariable "a" +27:18-19 TTypeVariable "a" +27:23-24 TTypeVariable "a" +28:1-3 TFunction "bb" +28:4-5 TVariable "x" +28:9-12 TClassMethod "boo" +28:13-14 TVariable "x" +29:1-3 TFunction "aa" +29:7-11 TTypeVariable "cool" +29:15-18 TTypeCon "Int" +29:22-26 TTypeVariable "cool" +30:1-3 TFunction "aa" +30:4-5 TVariable "x" +30:9-10 TVariable "c" +30:14-16 TFunction "aa" +30:17-18 TVariable "x" +30:19-20 TVariable "c" +31:12-14 TVariable "xx" +31:16-18 TVariable "yy" +32:11-13 TVariable "dd" +34:2-4 TVariable "zz" +34:6-8 TVariable "kk" +35:1-3 TFunction "cc" +35:7-10 TTypeCon "Foo" +35:15-18 TTypeCon "Int" +35:20-23 TTypeCon "Int" +35:28-31 TTypeCon "Int" +36:1-3 TFunction "cc" +36:4-5 TVariable "f" +36:7-9 TVariable "gg" +36:11-13 TVariable "vv" +37:10-12 TVariable "gg" +38:14-17 TRecField "foo" +38:18-19 TFunction "$" +38:20-21 TVariable "f" +38:24-27 TRecField "foo" +39:14-17 TRecField "foo" +39:18-19 TFunction "$" +39:20-21 TVariable "f" +39:24-27 TRecField "foo" +41:1-3 TFunction "go" +41:6-9 TRecField "foo" +42:1-4 TFunction "add" +42:7-18 TClassMethod "(Prelude.+)" +47:1-5 TVariable "main" +47:9-11 TTypeCon "IO" +48:1-5 TVariable "main" +48:8-16 TFunction "putStrLn" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs new file mode 100644 index 00000000000..07b0476c1e7 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/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/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected new file mode 100644 index 00000000000..d5f6e510024 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected @@ -0,0 +1,5 @@ +4:7-10 TClass "Foo" +4:11-12 TTypeVariable "a" +5:3-6 TClassMethod "foo" +5:10-11 TTypeVariable "a" +5:15-18 TTypeCon "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs new file mode 100644 index 00000000000..692754ec710 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs @@ -0,0 +1,6 @@ +module TClass where + + +class Foo a where + foo :: a -> Int + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected new file mode 100644 index 00000000000..5e9c894bf49 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected @@ -0,0 +1,3 @@ +4:6-9 TTypeCon "Foo" +4:12-15 TDataCon "Foo" +4:26-30 TClass "Show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs new file mode 100644 index 00000000000..8afd8afbd99 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/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/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected new file mode 100644 index 00000000000..b2b0c25d185 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected @@ -0,0 +1,12 @@ +5:13-18 TTypeFamily "XList" +5:19-20 TTypeVariable "a" +8:15-20 TTypeFamily "XList" +8:21-25 TTypeCon "Char" +8:28-33 TDataCon "XCons" +8:35-39 TTypeCon "Char" +8:42-47 TTypeFamily "XList" +8:48-52 TTypeCon "Char" +8:56-60 TDataCon "XNil" +11:15-20 TTypeFamily "XList" +11:26-35 TDataCon "XListUnit" +11:37-40 TTypeCon "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected new file mode 100644 index 00000000000..f8f844c423b --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected @@ -0,0 +1,4 @@ +3:6-9 TTypeCon "Foo" +3:12-15 TDataCon "Foo" +3:16-19 TTypeCon "Int" +3:30-32 TClass "Eq" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatafamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatafamily.hs new file mode 100644 index 00000000000..b9047a72d2b --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/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/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatype.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatype.hs new file mode 100644 index 00000000000..894065e391f --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatype.hs @@ -0,0 +1,3 @@ +module TDataType where + +data Foo = Foo Int deriving (Eq) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected new file mode 100644 index 00000000000..7c00ac76a26 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected @@ -0,0 +1,4 @@ +5:1-3 TVariable "go" +5:7-9 TTypeCon "IO" +6:1-3 TVariable "go" +6:6-11 TFunction "print" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs new file mode 100644 index 00000000000..f6ac8996d95 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs @@ -0,0 +1,6 @@ +module TDatatypeImported where + +import System.IO + +go :: IO () +go = print 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected new file mode 100644 index 00000000000..f34510728b5 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected @@ -0,0 +1,11 @@ +3:1-2 TFunction "f" +3:13-14 TTypeVariable "a" +3:16-17 TTypeVariable "a" +3:21-22 TTypeVariable "a" +4:1-2 TFunction "f" +4:3-4 TVariable "x" +4:7-8 TVariable "x" +6:1-2 TVariable "x" +6:6-7 TTypeVariable "a" +7:1-2 TVariable "x" +7:5-14 TVariable "undefined" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs new file mode 100644 index 00000000000..4efe5cecc4a --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/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/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected new file mode 100644 index 00000000000..002da409ca2 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected @@ -0,0 +1,5 @@ +3:1-2 TVariable "y" +3:6-9 TTypeCon "Int" +4:1-2 TVariable "y" +4:9-10 TFunction "f" +4:11-12 TVariable "x" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs new file mode 100644 index 00000000000..96854c34ad8 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs @@ -0,0 +1,4 @@ +module TFunctionLet where + +y :: Int +y = let f x = 1 in 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected new file mode 100644 index 00000000000..74fbb3a6aa4 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected @@ -0,0 +1,7 @@ +3:1-2 TFunction "f" +3:6-9 TTypeCon "Int" +3:13-16 TTypeCon "Int" +4:1-2 TFunction "f" +4:7-8 TFunction "g" +6:5-6 TFunction "g" +6:7-8 TVariable "x" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs new file mode 100644 index 00000000000..fed144b00c6 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/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/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected new file mode 100644 index 00000000000..a8a3d37c638 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected @@ -0,0 +1,13 @@ +5:6-9 TTypeCon "Lam" +6:3-7 TDataCon "Lift" +6:11-12 TTypeVariable "a" +6:36-39 TTypeCon "Lam" +6:40-41 TTypeVariable "a" +7:3-6 TDataCon "Lam" +7:12-15 TTypeCon "Lam" +7:16-17 TTypeVariable "a" +7:21-24 TTypeCon "Lam" +7:25-26 TTypeVariable "b" +7:36-39 TTypeCon "Lam" +7:41-42 TTypeVariable "a" +7:46-47 TTypeVariable "b" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs new file mode 100644 index 00000000000..e0cccf8bed6 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/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/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected new file mode 100644 index 00000000000..d0cfc85d3b7 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected @@ -0,0 +1,7 @@ +4:6-9 TTypeCon "Foo" +4:12-15 TDataCon "Foo" +4:16-19 TTypeCon "Int" +5:10-12 TClass "Eq" +5:13-16 TTypeCon "Foo" +6:5-9 TClassMethod "(==)" +6:12-21 TVariable "undefined" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs new file mode 100644 index 00000000000..68b634f470d --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs @@ -0,0 +1,6 @@ +module TInstanceClassMethodBind where + + +data Foo = Foo Int +instance Eq Foo where + (==) = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected new file mode 100644 index 00000000000..36e41ff096a --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected @@ -0,0 +1,2 @@ +4:1-3 TFunction "go" +4:9-13 TClassMethod "(==)" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs new file mode 100644 index 00000000000..24ea9efd284 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs @@ -0,0 +1,5 @@ +module TInstanceClassMethodUse where + + +go = (==) + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs new file mode 100644 index 00000000000..7d2c2bb034d --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs @@ -0,0 +1,3 @@ +module TModuleA where + +data Game = Game Int diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs new file mode 100644 index 00000000000..15ae4a7c440 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs @@ -0,0 +1,5 @@ +module TModuleB where + +import TModuleA + +go = Game 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected new file mode 100644 index 00000000000..2dd89fd1dae --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected @@ -0,0 +1,6 @@ +3:1-2 TVariable "x" +3:7-9 TClass "Eq" +3:10-11 TTypeVariable "a" +3:16-17 TTypeVariable "a" +4:1-2 TVariable "x" +4:5-14 TVariable "undefined" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs new file mode 100644 index 00000000000..9a7119dbdbe --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs @@ -0,0 +1,5 @@ +module TNoneFunctionWithConstraint where + +x :: (Eq a) => a +x = undefined + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected new file mode 100644 index 00000000000..eb3d90cbc76 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected @@ -0,0 +1,2 @@ +4:1-2 TFunction "g" +4:4-11 TDataCon "Nothing" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs new file mode 100644 index 00000000000..95e97c1abb6 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs @@ -0,0 +1,6 @@ +module TPatternMatch where + + +g (Nothing, _) = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSyn.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSyn.expected new file mode 100644 index 00000000000..11502922e29 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSyn.expected @@ -0,0 +1 @@ +5:9-12 TPatternSyn "Foo" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected new file mode 100644 index 00000000000..6c62634487a --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected @@ -0,0 +1,7 @@ +3:2-3 TVariable "a" +3:5-6 TVariable "b" +5:1-2 TFunction "f" +5:3-4 TFunction "g" +5:5-6 TVariable "y" +5:9-10 TFunction "g" +5:11-12 TVariable "y" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs new file mode 100644 index 00000000000..49e642a35d7 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs @@ -0,0 +1,9 @@ +module TVariable where + +(a, b) = (1, 2) + +f g y = g y + + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternsyn.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternsyn.hs new file mode 100644 index 00000000000..9590467307d --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternsyn.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module TPatternSyn where + + +pattern Foo = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected new file mode 100644 index 00000000000..683d1c142a0 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected @@ -0,0 +1,4 @@ +4:6-9 TTypeCon "Foo" +4:12-15 TDataCon "Foo" +4:18-21 TRecField "foo" +4:25-28 TTypeCon "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs new file mode 100644 index 00000000000..b3176a154fe --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs @@ -0,0 +1,7 @@ +module TRecord where + + +data Foo = Foo { foo :: Int } + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected new file mode 100644 index 00000000000..edd5a2a169c --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected @@ -0,0 +1,8 @@ +4:13-16 TTypeFamily "Foo" +4:17-18 TTypeVariable "a" +5:3-6 TTypeFamily "Foo" +5:7-10 TTypeCon "Int" +5:13-16 TTypeCon "Int" +6:3-6 TTypeFamily "Foo" +6:7-8 TTypeVariable "a" +6:11-17 TTypeSyn "String" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs new file mode 100644 index 00000000000..d8c925e370f --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/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/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected new file mode 100644 index 00000000000..0b94b7c045e --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected @@ -0,0 +1 @@ +3:1-4 TVariable "a\66560b" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs new file mode 100644 index 00000000000..1b8c7c1baa1 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs @@ -0,0 +1,5 @@ +module TUnicodeSyntax where + +a𐐀b = "a𐐀b" + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected new file mode 100644 index 00000000000..993cf807ef0 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected @@ -0,0 +1,4 @@ +4:1-6 TVariable "hello" +4:10-13 TTypeCon "Int" +5:1-6 TVariable "hello" +5:9-15 TClassMethod "length" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs new file mode 100644 index 00000000000..506af37a428 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs @@ -0,0 +1,8 @@ +module TValBind where + + +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 4d371859987..d97cda79fa0 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -120,6 +120,11 @@ import qualified Ide.Plugin.StylishHaskell as StylishHaskell import qualified Development.IDE.Plugin.CodeAction as Refactor #endif +#if hls_semanticTokens +import qualified Ide.Plugin.SemanticTokens as SemanticTokens +#endif + + data Log = forall a. (Pretty a) => Log PluginId a instance Pretty Log where @@ -172,6 +177,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #if hls_callHierarchy CallHierarchy.descriptor "callHierarchy" : #endif +#if hls_semanticTokens + let pId = "semanticTokens" in SemanticTokens.descriptor (pluginRecorder pId) pId: +#endif #if hls_class let pId = "class" in Class.descriptor (pluginRecorder pId) pId: #endif diff --git a/stack-lts21.yaml b/stack-lts21.yaml index 2920b0e807f..b1d4d8632b7 100644 --- a/stack-lts21.yaml +++ b/stack-lts21.yaml @@ -35,6 +35,7 @@ packages: - ./plugins/hls-splice-plugin - ./plugins/hls-stan-plugin - ./plugins/hls-stylish-haskell-plugin + - ./plugins/hls-semantic-tokens-plugin ghc-options: "$everything": -haddock diff --git a/stack.yaml b/stack.yaml index 922b55f461d..f399c3aa2e3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -35,6 +35,7 @@ packages: - ./plugins/hls-splice-plugin - ./plugins/hls-stan-plugin - ./plugins/hls-stylish-haskell-plugin + - ./plugins/hls-semantic-tokens-plugin ghc-options: "$everything": -haddock diff --git a/test/testdata/schema/ghc92/default-config.golden.json b/test/testdata/schema/ghc92/default-config.golden.json index d78d49e0460..949df9ed883 100644 --- a/test/testdata/schema/ghc92/default-config.golden.json +++ b/test/testdata/schema/ghc92/default-config.golden.json @@ -114,6 +114,9 @@ "retrie": { "globalOn": true }, + "semanticTokens": { + "globalOn": false + }, "splice": { "globalOn": true } diff --git a/test/testdata/schema/ghc92/vscode-extension-schema.golden.json b/test/testdata/schema/ghc92/vscode-extension-schema.golden.json index 690de92ab5d..d7e3623ed1d 100644 --- a/test/testdata/schema/ghc92/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc92/vscode-extension-schema.golden.json @@ -249,6 +249,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.semanticTokens.globalOn": { + "default": true, + "description": "Enables semanticTokens plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.splice.globalOn": { "default": true, "description": "Enables splice plugin", diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json index 50efb986c2d..96f2567cec7 100644 --- a/test/testdata/schema/ghc94/default-config.golden.json +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -114,6 +114,9 @@ "retrie": { "globalOn": true }, + "semanticTokens": { + "globalOn": false + }, "splice": { "globalOn": true }, diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json index 30c843b3d6d..f9e00d2f184 100644 --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -249,6 +249,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.semanticTokens.globalOn": { + "default": true, + "description": "Enables semanticTokens plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.splice.globalOn": { "default": true, "description": "Enables splice plugin", diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index 50efb986c2d..96f2567cec7 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -114,6 +114,9 @@ "retrie": { "globalOn": true }, + "semanticTokens": { + "globalOn": false + }, "splice": { "globalOn": true }, diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json index 30c843b3d6d..f9e00d2f184 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -249,6 +249,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.semanticTokens.globalOn": { + "default": true, + "description": "Enables semanticTokens plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.splice.globalOn": { "default": true, "description": "Enables splice plugin", diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index 8ad95561c6d..31c5a79400e 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -79,6 +79,9 @@ "qualifyImportedNames": { "globalOn": true }, + "semanticTokens": { + "globalOn": false + }, "stan": { "globalOn": false } diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json index 5950032867d..5073a3e3394 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -171,6 +171,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.semanticTokens.globalOn": { + "default": true, + "description": "Enables semanticTokens plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.stan.globalOn": { "default": true, "description": "Enables stan plugin", From 92d3ba98161f8b6f7e1b8abec70df9ee6af16216 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 6 Jan 2024 14:02:27 -0800 Subject: [PATCH 3/5] update Floskell to 0.11.* (#3933) * update Floskell to 0.11.* Floskell 0.11.* supports Aeson 2.2.* * package version 2.5.0.0, Stack Floskell dependency, codeowner * update GHC 9.4 Stack resolver https://www.stackage.org/lts-21.25 remove duplicate `extra-deps` --- CODEOWNERS | 2 +- plugins/hls-floskell-plugin/CHANGELOG.md | 4 ++++ plugins/hls-floskell-plugin/hls-floskell-plugin.cabal | 2 +- plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs | 4 ++-- stack-lts21.yaml | 8 ++------ stack.yaml | 2 +- 6 files changed, 11 insertions(+), 11 deletions(-) create mode 100644 plugins/hls-floskell-plugin/CHANGELOG.md diff --git a/CODEOWNERS b/CODEOWNERS index fa6be0f2632..fbed53aac08 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -15,7 +15,7 @@ /plugins/hls-class-plugin @Ailrun /plugins/hls-eval-plugin /plugins/hls-explicit-imports-plugin @pepeiborra -/plugins/hls-floskell-plugin @Ailrun +/plugins/hls-floskell-plugin @Ailrun @peterbecich /plugins/hls-fourmolu-plugin @georgefst /plugins/hls-gadt-plugin @July541 /plugins/hls-hlint-plugin @eddiemundo diff --git a/plugins/hls-floskell-plugin/CHANGELOG.md b/plugins/hls-floskell-plugin/CHANGELOG.md new file mode 100644 index 00000000000..e18ef08cd66 --- /dev/null +++ b/plugins/hls-floskell-plugin/CHANGELOG.md @@ -0,0 +1,4 @@ +# Revision history for hls-floskell-plugin + +## 2.5.1.0 -- 2024-01-05 +Updates Floskell dependency to 0.11.*, which supports Aeson 2.2.* diff --git a/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal b/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal index 9f0b1712ee5..6ca0e409c4e 100644 --- a/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal +++ b/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal @@ -28,7 +28,7 @@ library hs-source-dirs: src build-depends: , base >=4.12 && <5 - , floskell ^>=0.10.8 + , floskell ^>=0.11.0 , ghcide == 2.5.0.0 , hls-plugin-api == 2.5.0.0 , lsp-types ^>=2.1 diff --git a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs index 77800f4066a..e030ef7f2c6 100644 --- a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs +++ b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs @@ -39,10 +39,10 @@ provider _ideState typ contents fp _ = do let (range, selectedContents) = case typ of FormatText -> (fullRange contents, contents) FormatRange r -> (normalize r, extractTextInRange (extendToFullLines r) contents) - result = reformat config (Just file) . TL.encodeUtf8 $ TL.fromStrict selectedContents + result = reformat config (Just file) $ TL.fromStrict selectedContents case result of Left err -> throwError $ PluginInternalError $ T.pack $ "floskellCmd: " ++ err - Right new -> pure $ InL [TextEdit range . TL.toStrict $ TL.decodeUtf8 new] + Right new -> pure $ InL [TextEdit range $ TL.toStrict new] -- | Find Floskell Config, user and system wide or provides a default style. -- Every directory of the filepath will be searched to find a user configuration. diff --git a/stack-lts21.yaml b/stack-lts21.yaml index b1d4d8632b7..55ea89b301a 100644 --- a/stack-lts21.yaml +++ b/stack-lts21.yaml @@ -1,4 +1,4 @@ -resolver: lts-21.2 # ghc-9.4 +resolver: lts-21.25 # ghc-9.4 packages: - . @@ -44,12 +44,11 @@ ghc-options: allow-newer: true extra-deps: -- floskell-0.10.7 +- floskell-0.11.1 - hiedb-0.4.4.0 - hie-bios-0.13.1 - implicit-hie-0.1.4.0 - monad-dijkstra-0.1.1.3 -- algebraic-graphs-0.6.1 - retrie-1.2.2 - stylish-haskell-0.14.4.0 - lsp-2.3.0.0 @@ -59,11 +58,8 @@ extra-deps: # stan dependencies not found in the stackage snapshot - stan-0.1.0.2 - clay-0.14.0 -- colourista-0.1.0.2 - dir-traverse-0.2.3.0 - extensions-0.1.0.0 -- relude-1.2.1.0 -- slist-0.2.1.0 - tomland-1.3.3.2 - trial-0.0.0.0 - trial-optparse-applicative-0.0.0.0 diff --git a/stack.yaml b/stack.yaml index f399c3aa2e3..0c927eb5420 100644 --- a/stack.yaml +++ b/stack.yaml @@ -43,7 +43,7 @@ ghc-options: allow-newer: true extra-deps: -- floskell-0.10.8 +- floskell-0.11.1 - retrie-1.2.2 - hiedb-0.4.4.0 - implicit-hie-0.1.4.0 From f4df1aa736f813eddcd6898f33b9f1fe93cc7e29 Mon Sep 17 00:00:00 2001 From: wz1000 Date: Mon, 8 Jan 2024 15:29:38 +0530 Subject: [PATCH 4/5] Adapt to minor API change for 9.6.4 compatibility (#3929) The CPP will need to be adjusted again for 9.8.2 as the patch is likely to be backported there as well. --- ghcide/src/Development/IDE/Import/FindImports.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index 358666a0e9c..5fe250c9ce4 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -219,7 +219,11 @@ notFoundErr env modName reason = } LookupUnusable unusable -> let unusables' = map get_unusable unusable +#if MIN_VERSION_ghc(9,6,4) && !MIN_VERSION_ghc(9,8,1) + get_unusable (m, ModUnusable r) = r +#else get_unusable (m, ModUnusable r) = (moduleUnit m, r) +#endif get_unusable (_, r) = pprPanic "findLookupResult: unexpected origin" (ppr r) in notFound {fr_unusables = unusables'} From 2156ac2836596c7604bf2172ee9c3d468dc4a295 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Tue, 9 Jan 2024 11:13:19 +0000 Subject: [PATCH 5/5] Remove some people from CODEOWNERS (#3930) Also: - Sort plugin list - Add some missing components - Add @soulomoon for semantic-tokens --- CODEOWNERS | 38 +++++++++++++++++++++++--------------- 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index fbed53aac08..9c1f09495ad 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -2,49 +2,57 @@ /ghcide @pepeiborra /ghcide/session-loader @pepeiborra @fendor /hls-graph @pepeiborra -/hls-plugin-api @berberman +/hls-plugin-api @michaelpj @fendor /hls-test-utils @fendor +/hie-compat @wz1000 + +# HLS main +/src @fendor +/exe @fendor /test @fendor -/hie-compat # Plugins /plugins/hls-alternate-number-format-plugin @drsooch -/plugins/hls-cabal-plugin @fendor /plugins/hls-cabal-fmt-plugin @VeryMilkyJoe @fendor +/plugins/hls-cabal-plugin @fendor /plugins/hls-call-hierarchy-plugin @July541 -/plugins/hls-class-plugin @Ailrun +/plugins/hls-change-type-signature-plugin +/plugins/hls-class-plugin +/plugins/hls-code-range-plugin @kokobd /plugins/hls-eval-plugin +/plugins/hls-explicit-fixity-plugin /plugins/hls-explicit-imports-plugin @pepeiborra -/plugins/hls-floskell-plugin @Ailrun @peterbecich +/plugins/hls-explicit-record-fields-plugin @ozkutuk +/plugins/hls-floskell-plugin @peterbecich /plugins/hls-fourmolu-plugin @georgefst /plugins/hls-gadt-plugin @July541 /plugins/hls-hlint-plugin @eddiemundo /plugins/hls-module-name-plugin /plugins/hls-ormolu-plugin @georgefst -/plugins/hls-pragmas-plugin @berberman @Ailrun @eddiemundo +/plugins/hls-overloaded-record-dot-plugin @joyfulmantis +/plugins/hls-pragmas-plugin @eddiemundo /plugins/hls-qualify-imported-names-plugin @eddiemundo -/plugins/hls-rename-plugin @OliverMadine /plugins/hls-refactor-plugin @santiweight +/plugins/hls-rename-plugin /plugins/hls-retrie-plugin @pepeiborra -/plugins/hls-code-range-plugin @kokobd +/plugins/hls-semantic-tokens-plugin @soulomoon /plugins/hls-splice-plugin @konn -/plugins/hls-stylish-haskell-plugin @Ailrun /plugins/hls-stan-plugin @0rphee -/plugins/hls-explicit-record-fields-plugin @ozkutuk -/plugins/hls-overloaded-record-dot-plugin @joyfulmantis +/plugins/hls-stylish-haskell-plugin @michaelpj # Benchmarking /shake-bench @pepeiborra +/bench @pepeiborra # Docs /docs @michaelpj # CI -/.circleci @Anton-Latukha -/.github @Anton-Latukha @Ailrun -/.gitlab @hasufell +/.circleci +/.github @michaelpj @fendor # Build *.nix @berberman @michaelpj @guibou -*.project +*.project @michaelpj +*.stack* @michaelpj .gitpod.* @kokobd