expose function flag to expose (=>, ->, -=>, ==>)

Author: soulomoon

ghcide/src/Development/IDE/GHC/Compat/Core.hs

@@ -431,13 +431,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 (..))
@@ -597,7 +597,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 +606,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 +630,8 @@ 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}
+pattern FunTy :: 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

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -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 _                = []

plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs

@@ -53,7 +53,6 @@ toLspTokenType tk = case tk of
   -- not sure if this is correct choice
   TTypeFamily   -> SemanticTokenTypes_Interface
 
---   TNothing      -> Nothing
 
 lspTokenReverseMap :: Map.Map SemanticTokenTypes HsSemanticTokenType
 lspTokenReverseMap = Map.fromList $ map (\x -> (toLspTokenType x, x)) $ enumFrom minBound
@@ -90,11 +89,12 @@ tyThingSemantic ty = case ty of
 
 isFunType :: Type -> Bool
 isFunType a = case a of
-  ForAllTy _ t -> isFunType t
---   Development.IDE.GHC.Compat.Core.FunTy(pattern synonym) hides FunTyFlag which is used to distinguish
+  ForAllTy _ t      -> isFunType t
+--   Development.IDE.GHC.Compat.Core.FunTy(pattern synonym), FunTyFlag which is used to distinguish
 --   (->, =>, etc..)
-  FunTy _ _    -> True
-  _x           -> isFunTy a
+  FunTy FTF_T_T _ _ -> True
+  FunTy _ _ rhs     -> isFunType rhs
+  _x                -> isFunTy a
 
 hieKindFunMasksKind :: HieKind a -> HieFunMaskKind a
 hieKindFunMasksKind hieKind = case hieKind of

plugins/hls-semantic-tokens-plugin/test/Main.hs

@@ -179,6 +179,7 @@ semanticTokensFunctionTests =
     [ goldenWithSemanticTokens "functions" "TFunction",
       goldenWithSemanticTokens "local functions" "TFunctionLocal",
       goldenWithSemanticTokens "function in let binding" "TFunctionLet"
+      , goldenWithSemanticTokens "negative case non-function with constraint" "TNoneFunctionWithConstraint"
     ]
 
 main :: IO ()

plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected

@@ -8,4 +8,4 @@
 6:1-2 TVariable "x"
 6:6-7 TTypeVariable "a"
 7:1-2 TVariable "x"
-7:5-14 TFunction "undefined"
+7:5-14 TVariable "undefined"

plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected

@@ -4,4 +4,4 @@
 5:10-12 TClass "Eq"
 5:13-16 TTypeCon "Foo"
 6:5-9 TClassMethod "(==)"
-6:12-21 TFunction "undefined"
+6:12-21 TVariable "undefined"

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"

plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs

@@ -0,0 +1,5 @@
+module TNoneFunctionWithConstraint where
+
+x :: (Eq a) => a
+x = undefined
+