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..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 @@ -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 +expandTypeSyn :: Type -> Type +expandTypeSyn ty + | Just ty' <- coreView ty = expandTypeSyn ty' + | otherwise = ty + isFunType :: Type -> Bool -isFunType a = case 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..) 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 +