improve hover rendering

Author: wz1000

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

@@ -23,6 +23,10 @@ module Development.IDE.Spans.AtPoint (
   , LookupModule
   ) where
 
+
+import           GHC.Data.FastString                  (lengthFS)
+import qualified GHC.Utils.Outputable                 as O
+
 import           Development.IDE.GHC.Error
 import           Development.IDE.GHC.Orphans          ()
 import           Development.IDE.Types.Location
@@ -59,7 +63,6 @@ import           Data.Tree
 import qualified Data.Tree                            as T
 import           Data.Version                         (showVersion)
 import           Development.IDE.Types.Shake          (WithHieDb)
-import qualified GHC.Utils.Outputable                 as O
 import           HieDb                                hiding (pointCommand,
                                                        withHieDb)
 import           System.Directory                     (doesFileExist)
@@ -174,14 +177,18 @@ documentHighlight hf rf pos = pure highlights
     highlights = do
       n <- ns
       ref <- fromMaybe [] (M.lookup (Right n) rf)
-      pure $ makeHighlight ref
-    makeHighlight (sp,dets) =
-      DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)
+      maybeToList (makeHighlight n ref)
+    makeHighlight n (sp,dets)
+      | isTvNameSpace (nameNameSpace n) && isBadSpan n sp = Nothing
+      | otherwise = Just $ DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)
     highlightType s =
       if any (isJust . getScopeFromContext) s
         then DocumentHighlightKind_Write
         else DocumentHighlightKind_Read
 
+    isBadSpan :: Name -> RealSrcSpan -> Bool
+    isBadSpan n sp = srcSpanStartLine sp /= srcSpanEndLine sp || (srcSpanEndCol sp - srcSpanStartCol sp > lengthFS (occNameFS $ nameOccName n))
+
 -- | Locate the type definition of the name at a given position.
 gotoTypeDefinition
   :: MonadIO m
@@ -327,23 +334,22 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
         renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) [x])
           = renderEvidenceTree x
         renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_), ..}) xs)
-          = hang (text "- Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $
-                 vcat $ text "depending on:" : map renderEvidenceTree' xs
-        renderEvidenceTree x = renderEvidenceTree' x
+          = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $
+                 vcat $ text "constructed using:" : map renderEvidenceTree' xs
+        renderEvidenceTree (T.Node (EvidenceInfo{..}) _)
+          = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $
+                 vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar)
 
         -- renderEvidenceTree' skips let bound evidence variables and prints the children directly
         renderEvidenceTree' (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) xs)
           = vcat (map renderEvidenceTree' xs)
-        renderEvidenceTree' (T.Node (EvidenceInfo{..}) xs)
-          = hang (text "- Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $
-                 vcat $ map (text . T.unpack) (maybeToList $ definedAt evidenceVar)
-                     ++ [printDets evidenceSpan evidenceDetails (null xs)]
-                     ++ map renderEvidenceTree' xs
-
-        printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> Bool -> SDoc
-        printDets _    Nothing True = text ""
-        printDets _    Nothing False = text "constructed using:"
-        printDets ospn (Just (src,_,mspn)) _ = pprSrc
+        renderEvidenceTree' (T.Node (EvidenceInfo{..}) _)
+          = hang (text "- `" O.<> expandType evidenceType O.<> "`") 2 $
+                 vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar)
+
+        printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> SDoc
+        printDets _    Nothing = text "using an external instance"
+        printDets ospn (Just (src,_,mspn)) = pprSrc
                                       $$ text "at" <+> ppr spn
           where
             -- Use the bind span if we have one, else use the occurence span
@@ -409,37 +415,19 @@ locationsAtPoint
   -> IdeOptions
   -> M.Map ModuleName NormalizedFilePath
   -> Position
-<<<<<<< HEAD
-  -> HieASTs a
-  -> m [(Location, Identifier)]
-locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast =
-||||||| parent of 86ebcf859 (Jump to instance definition and explain typeclass evidence)
-  -> HieASTs a
-  -> m [Location]
-locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast =
-=======
   -> HieAstResult
-  -> m [Location]
+  -> m [(Location, Identifier)]
 locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) =
->>>>>>> 86ebcf859 (Jump to instance definition and explain typeclass evidence)
   let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)
       evTrees = mapMaybe (either (const Nothing) $ getEvidenceTree _rm) ns
       evNs = concatMap (map (Right . evidenceVar) . T.flatten) evTrees
       zeroPos = Position 0 0
       zeroRange = Range zeroPos zeroPos
-<<<<<<< HEAD
       modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports
    in fmap (nubOrd . concat) $ mapMaybeM
         (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m)))
                 (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n)))
-        ns
-||||||| parent of 86ebcf859 (Jump to instance definition and explain typeclass evidence)
-      modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports
-    in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns
-=======
-      modToLocation m = (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) <$> M.lookup m imports
-    in nubOrd . concat <$> mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) (ns ++ evNs)
->>>>>>> 86ebcf859 (Jump to instance definition and explain typeclass evidence)
+        (ns ++ evNs)
 
 -- | Given a 'Name' attempt to find the location where it is defined.
 nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])