1. Relax GetDocMap kindMap to get TyThing for more than type variables.

2. Backport isVisibleFunArg

Author: soulomoon

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
@@ -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,
@@ -630,9 +633,18 @@ pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr
 pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr
 #endif
 
-pattern FunTy :: FunTyFlag -> Type -> Type -> Type
+#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
 

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

@@ -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

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

@@ -13,7 +13,6 @@
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE ViewPatterns          #-}
 
 -- |
 -- This module provides the core functionality of the plugin.
@@ -28,24 +27,22 @@ import qualified Data.Map                             as Map
 import           Data.Maybe                           (listToMaybe, mapMaybe)
 import qualified Data.Text                            as T
 import           Development.IDE                      (Action,
+                                                       GetDocMap (GetDocMap),
                                                        GetHieAst (GetHieAst),
-                                                       GhcSessionDeps (GhcSessionDeps),
                                                        HieAstResult (HAR, hieAst, hieModule, refMap),
                                                        IdeState, Priority (..),
                                                        Recorder, Rules,
                                                        WithPriority,
-                                                       catchSrcErrors,
                                                        cmapWithPrio, define,
                                                        hieKind, ideLogger,
                                                        logPriority, use_)
-import           Development.IDE.Core.Compile         (lookupName)
 import           Development.IDE.Core.PluginUtils     (runActionE,
                                                        useWithStaleE)
 import           Development.IDE.Core.PositionMapping (idDelta, toCurrentRange)
 import           Development.IDE.Core.Rules           (Log (LogShake))
+import           Development.IDE.Core.RuleTypes       (DocAndKindMap (..))
 import           Development.IDE.Core.Shake           (addPersistentRule)
 import           Development.IDE.GHC.Compat
-import           Development.IDE.Types.HscEnvEq       (hscEnv)
 import           Ide.Plugin.Error                     (PluginError (PluginInternalError),
                                                        getNormalizedFilePathE)
 import           Ide.Plugin.SemanticTokens.Mappings
@@ -93,30 +90,33 @@ semanticTokensFull state _ param = do
 getSemanticTokensRule :: Recorder (WithPriority Log) -> Rules ()
 getSemanticTokensRule recorder =
   define (cmapWithPrio LogShake recorder) $ \GetSemanticTokens nfp -> do
-    (hscEnv -> hsc) <- use_ GhcSessionDeps nfp
+    -- (hscEnv -> hsc) <- use_ GhcSessionDeps nfp
     (HAR {..}) <- use_ GetHieAst nfp
+    (DKMap{getKindMap}) <- use_ GetDocMap nfp
     Just (_, ast) <- return $ listToMaybe $ Map.toList $ getAsts hieAst
     -- get current location from the old ones
     let spanNamesMap = hieAstSpanNames ast
     let names = nameSetElemsStable $ unionNameSets $ Map.elems spanNamesMap
     let localSemanticMap = mkLocalNameSemanticFromAst names (hieKindFunMasksKind hieKind) refMap
     -- get imported name semantic map
     -- liftIO $ putStrLn $ unlines $ fmap showClearName $ nameSetElemsStable nameSet
-    importedNameSemanticMap <- liftIO $ foldrM (getTypeExclude localSemanticMap hsc) emptyNameEnv names
+    let importedNameSemanticMap = foldr (getTypeExclude localSemanticMap getKindMap) emptyNameEnv names
     -- let importedNameSemanticMap = computeImportedNameSemanticMap $ nameSetElemsStable nameSet
     let sMap = plusNameEnv_C (<>) importedNameSemanticMap localSemanticMap
     let rangeTokenType = extractSemanticTokensFromNames sMap spanNamesMap
     return ([], Just $ RangeHsSemanticTokenTypes rangeTokenType)
   where
     -- ignore one already in discovered in local
-    getTypeExclude localEnv env n nameMap
-      | n `elemNameEnv` localEnv = pure nameMap
+    getTypeExclude :: NameEnv a
+        -> NameEnv TyThing
+        -> Name
+        -> NameEnv HsSemanticTokenType
+        -> NameEnv HsSemanticTokenType
+    getTypeExclude localEnv kindMap n nameMap
+      | n `elemNameEnv` localEnv = nameMap
       | otherwise =
-          do
-            tyThing <- lookupImported env n
-            pure $ maybe nameMap (extendNameEnv nameMap n) (tyThing >>= tyThingSemantic)
-    lookupImported :: HscEnv -> Name -> IO (Maybe TyThing)
-    lookupImported env = fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env
+            let tyThing = lookupNameEnv kindMap n in
+            maybe nameMap (extendNameEnv nameMap n) (tyThing >>= tyThingSemantic)
 
 -- | Persistent rule to ensure that semantic tokens doesn't block on startup
 persistentGetSemanticTokensRule :: Rules ()

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

@@ -89,12 +89,11 @@ tyThingSemantic ty = case ty of
 
 isFunType :: Type -> Bool
 isFunType a = case a of
-  ForAllTy _ t      -> isFunType t
+  ForAllTy _ t    -> isFunType t
 --   Development.IDE.GHC.Compat.Core.FunTy(pattern synonym), FunTyFlag which is used to distinguish
 --   (->, =>, etc..)
-  FunTy FTF_T_T _ _ -> True
-  FunTy _ _ rhs     -> isFunType rhs
-  _x                -> isFunTy a
+  FunTy flg _ rhs-> if isVisibleFunArg flg then True else isFunType rhs
+  _x              -> isFunTy a
 
 hieKindFunMasksKind :: HieKind a -> HieFunMaskKind a
 hieKindFunMasksKind hieKind = case hieKind of