improve hover rendering

Author: wz1000

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

@@ -179,14 +179,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 HkWrite
         else HkRead
 
+    isBadSpan :: Name -> RealSrcSpan -> Bool
+    isBadSpan n sp = srcSpanStartLine sp /= srcSpanEndLine sp || (srcSpanEndCol sp - srcSpanStartCol sp > lengthFS (occNameFS $ nameOccName n))
+
 gotoTypeDefinition
   :: MonadIO m
   => WithHieDb
@@ -290,30 +294,29 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) _rf _ kind) (DKMap dm km) env pos
         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) (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) (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) (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
             spn = fromMaybe ospn mspn
             pprSrc = case src of
               -- Users don't know what HsWrappers are
-              EvWrapperBind -> "bound by type signature or pattern"
+              EvWrapperBind -> "bound by a context"
               _ -> ppr src
 #endif
 
@@ -352,24 +355,12 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi
             HQualTy a b -> getTypes [a,b]
             HCastTy a -> getTypes [a]
             _ -> []
-<<<<<<< HEAD
-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)
-||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence)
-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts)
-=======
-        in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts)
->>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence)
+        in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)
     HieFresh ->
       let ts = concat $ pointCommand ast pos getts
           getts x = nodeType ni  ++ mapMaybe identType (M.elems $ nodeIdentifiers ni)
             where ni = nodeInfo x
-<<<<<<< HEAD
-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)
-||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence)
-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts)
-=======
-        in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts)
->>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence)
+        in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)
 
 namesInType :: Type -> [Name]
 namesInType (TyVarTy n)      = [varName n]
@@ -394,13 +385,7 @@ locationsAtPoint
   -> Position
   -> HieAstResult
   -> m [Location]
-<<<<<<< HEAD
-locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast =
-||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence)
-locationsAtPoint hiedb lookupModule _ideOptions imports pos ast =
-=======
-locationsAtPoint hiedb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) =
->>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence)
+locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) =
   let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)
 #if MIN_VERSION_ghc(9,0,1)
       evTrees = mapMaybe (either (const Nothing) $ getEvidenceTree _rm) ns
@@ -410,16 +395,8 @@ locationsAtPoint hiedb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _)
 #endif
       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 (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns
-||||||| parent of dc807c4a (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 hiedb lookupModule) ns
-=======
       modToLocation m = (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) <$> M.lookup m imports
-    in nubOrd . concat <$> mapMaybeM (either (pure . modToLocation) $ nameToLocation hiedb lookupModule) (ns ++ evNs)
->>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence)
+    in nubOrd . concat <$> mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) (ns ++ evNs)
 
 -- | Given a 'Name' attempt to find the location where it is defined.
 nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])