Semantic tokens: expand type synonym to checkout forall function type when possible (#3967)

* expand type synonym to extract function type when possible

* rename coreFullView to avoid conliction in ghc 9.8

Author: soulomoon

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

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"
     ]

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"

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
+