From 54864247bcecd15a6a4599bdc3432b4ee8e2321a Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 16 Jan 2024 18:17:45 +0800 Subject: [PATCH 1/3] expand type synonym to extract function type when possible --- .../src/Ide/Plugin/SemanticTokens/Mappings.hs | 10 +++++++++- plugins/hls-semantic-tokens-plugin/test/Main.hs | 1 + .../testdata/TFunctionUnderTypeSynonym.expected | 17 +++++++++++++++++ .../test/testdata/TFunctionUnderTypeSynonym.hs | 9 +++++++++ 4 files changed, 36 insertions(+), 1 deletion(-) create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected create mode 100644 plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs 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 index fd724ed92f..b8373203c3 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs @@ -81,14 +81,21 @@ tyThingSemantic ty = case ty of isFunVar :: Var -> Bool isFunVar var = isFunType $ varType var +-- expand the type synonym https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Core.Type.html +coreFullView :: Type -> Type +coreFullView ty + | Just ty' <- coreView ty = coreFullView ty' + | otherwise = ty + isFunType :: Type -> Bool -isFunType a = case a of +isFunType a = case coreFullView 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 @@ -119,6 +126,7 @@ recoverFunMaskArray flattened = unflattened go (HQualTy _constraint b) = b go (HCastTy b) = b go HCoercionTy = False + -- we have no enough information to expand the type synonym go (HTyConApp _ _) = False typeSemantic :: HieFunMaskKind hType -> hType -> Maybe HsSemanticTokenType diff --git a/plugins/hls-semantic-tokens-plugin/test/Main.hs b/plugins/hls-semantic-tokens-plugin/test/Main.hs index ff02764658..ef8482081a 100644 --- a/plugins/hls-semantic-tokens-plugin/test/Main.hs +++ b/plugins/hls-semantic-tokens-plugin/test/Main.hs @@ -215,6 +215,7 @@ semanticTokensFunctionTests = "get semantic of functions" [ goldenWithSemanticTokensWithDefaultConfig "functions" "TFunction", goldenWithSemanticTokensWithDefaultConfig "local functions" "TFunctionLocal", + goldenWithSemanticTokensWithDefaultConfig "functions under type synonym" "TFunctionUnderTypeSynonym", goldenWithSemanticTokensWithDefaultConfig "function in let binding" "TFunctionLet", goldenWithSemanticTokensWithDefaultConfig "negative case non-function with constraint" "TNoneFunctionWithConstraint" ] diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected new file mode 100644 index 0000000000..010cf0c613 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected @@ -0,0 +1,17 @@ +3:6-8 TTypeSynonym "T1" +3:11-14 TTypeConstructor "Int" +3:18-21 TTypeConstructor "Int" +4:6-8 TTypeSynonym "T2" +4:18-19 TTypeVariable "a" +4:21-22 TTypeVariable "a" +4:26-27 TTypeVariable "a" +5:1-3 TFunction "f1" +5:7-9 TTypeSynonym "T1" +6:1-3 TFunction "f1" +6:4-5 TVariable "x" +6:8-9 TVariable "x" +7:1-3 TFunction "f2" +7:7-9 TTypeSynonym "T2" +8:1-3 TFunction "f2" +8:4-5 TVariable "x" +8:8-9 TVariable "x" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs new file mode 100644 index 0000000000..6485232394 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs @@ -0,0 +1,9 @@ +module TFunctionUnderTypeSynonym where + +type T1 = Int -> Int +type T2 = forall a. a -> a +f1 :: T1 +f1 x = x +f2 :: T2 +f2 x = x + From 9cfeefed76406318855837921ec3a9df7b445414 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 16 Jan 2024 18:30:58 +0800 Subject: [PATCH 2/3] mend rename coreFullView to avoid conliction in ghc 9.8 --- .../src/Ide/Plugin/SemanticTokens/Mappings.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) 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 index b8373203c3..34cfba8692 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -82,13 +83,13 @@ tyThingSemantic ty = case ty of isFunVar var = isFunType $ varType var -- expand the type synonym https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Core.Type.html -coreFullView :: Type -> Type -coreFullView ty - | Just ty' <- coreView ty = coreFullView ty' +expandTypeSyn :: Type -> Type +expandTypeSyn ty + | Just ty' <- coreView ty = expandTypeSyn ty' | otherwise = ty isFunType :: Type -> Bool -isFunType a = case coreFullView a of +isFunType a = case expandTypeSyn a of ForAllTy _ t -> isFunType t -- Development.IDE.GHC.Compat.Core.FunTy(pattern synonym), FunTyFlag which is used to distinguish -- (->, =>, etc..) From 1670e0d64644243a6f6dfa0d9426ec424ae8b7e3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 16 Jan 2024 18:31:52 +0800 Subject: [PATCH 3/3] mend cleanup --- .../src/Ide/Plugin/SemanticTokens/Mappings.hs | 1 - 1 file changed, 1 deletion(-) 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 index 34cfba8692..013d77a9e6 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -- |