Fix #248 and #250

src/Development/IDE/Spans/AtPoint.hs

@@ -55,33 +55,52 @@ atPoint
   -> [SpanInfo]
   -> Position
   -> Maybe (Maybe Range, [T.Text])
-atPoint IdeOptions{..} tcs srcSpans pos = do
-    SpanInfo{..} <- listToMaybe $ orderSpans $ spansAtPoint pos srcSpans
-    ty <- spaninfoType
-    let mbName  = getNameM spaninfoSource
-        mbDefinedAt = fmap (\name -> "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n") mbName
-        docInfo  = maybe [] (\name -> getDocumentation name tcs) mbName
-        range = Range
-                  (Position spaninfoStartLine spaninfoStartCol)
-                  (Position spaninfoEndLine spaninfoEndCol)
-        colon = if optNewColonConvention then ":" else "::"
-        wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
-        typeSig = wrapLanguageSyntax $ case mbName of
-          Nothing -> colon <> " " <> showName ty
-          Just name ->
-            let modulePrefix = maybe "" (<> ".") (getModuleNameAsText name)
-            in  modulePrefix <> showName name <> "\n  " <> colon <> " " <> showName ty
-        hoverInfo = docInfo <> [typeSig] <> maybeToList mbDefinedAt
-    return (Just range, hoverInfo)
+atPoint IdeOptions{..} tcs pos srcSpans = do
+    firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint srcSpans pos
+    return (Just (range firstSpan), hoverInfo firstSpan)
   where
+    -- Hover info for types, classes, type variables
+    hoverInfo SpanInfo{spaninfoType = Nothing , ..} =
+       documentation <> (wrapLanguageSyntax <$> name <> kind) <> location
+     where
+       documentation = findDocumentation mbName
+       name     = [maybe shouldNotHappen showName  mbName]
+       location = [maybe shouldNotHappen definedAt mbName]
+       kind     = [] -- TODO
+       shouldNotHappen = "ghcide: did not expect a type level component without a name"
+       mbName = getNameM spaninfoSource
+
+    -- Hover info for values/data
+    hoverInfo SpanInfo{spaninfoType = (Just typ), ..} =
+       documentation <> (wrapLanguageSyntax <$> nameOrSource <> typeAnnotation) <> location
+     where
+       mbName = getNameM spaninfoSource
+       documentation  = findDocumentation mbName
+       typeAnnotation = [colon <> showName typ]
+       nameOrSource   = [maybe literalSource qualifyNameIfPossible mbName]
+       literalSource = "" -- TODO: literals: display (length-limited) source
+       qualifyNameIfPossible name' = modulePrefix <> showName name'
+         where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')
+       location = [maybe "" definedAt mbName]
+
+    findDocumentation = maybe [] (getDocumentation tcs)
+    definedAt name = "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n"
+
+    range SpanInfo{..} = Range
+      (Position spaninfoStartLine spaninfoStartCol)
+      (Position spaninfoEndLine spaninfoEndCol)
+
+    colon = if optNewColonConvention then ": " else ":: "
+    wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
+
     -- NOTE(RJR): This is a bit hacky.
     -- We don't want to show the user type signatures generated from Eq and Show
     -- instances, as they do not appear in the source program.
     -- However the user could have written an `==` or `show` function directly,
     -- in which case we still want to show information for that.
     -- Hence we just move such information later in the list of spans.
-    orderSpans :: [SpanInfo] -> [SpanInfo]
-    orderSpans = uncurry (++) . partition (not . isTypeclassDeclSpan)
+    deEmpasizeGeneratedEqShow :: [SpanInfo] -> [SpanInfo]
+    deEmpasizeGeneratedEqShow = uncurry (++) . partition (not . isTypeclassDeclSpan)
     isTypeclassDeclSpan :: SpanInfo -> Bool
     isTypeclassDeclSpan spanInfo =
       case getNameM (spaninfoSource spanInfo) of
@@ -90,9 +109,7 @@ atPoint IdeOptions{..} tcs srcSpans pos = do
 
 locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]
 locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
-    fmap (map srcSpanToLocation) .
-    mapMaybeM (getSpan . spaninfoSource) .
-    spansAtPoint pos
+    fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos
   where getSpan :: SpanSource -> m (Maybe SrcSpan)
         getSpan NoSource = pure Nothing
         getSpan (SpanS sp) = pure $ Just sp
@@ -121,6 +138,7 @@ locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
         setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
         setFileName _ span@(UnhelpfulSpan _) = span
 
+-- | Filter out spans which do not enclose a given point
 spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
 spansAtPoint pos = filter atp where
   line = _line pos

src/Development/IDE/Spans/Documentation.hs

@@ -18,8 +18,8 @@ import SrcLoc
 
 
 getDocumentation
- ::  Name -- ^ The name you want documentation for.
- -> [TypecheckedModule] -- ^ All of the possible modules it could be defined in.
+ :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in.
+ ->  Name -- ^ The name you want documentation for.
  -> [T.Text]
 -- This finds any documentation between the name you want
 -- documentation for and the one before it. This is only an
@@ -28,7 +28,7 @@ getDocumentation
 -- may be edge cases where it is very wrong).
 -- TODO : Build a version of GHC exactprint to extract this information
 -- more accurately.
-getDocumentation targetName tcs = fromMaybe [] $ do
+getDocumentation tcs targetName = fromMaybe [] $ do
   -- Find the module the target is defined in.
   targetNameSpan <- realSpan $ nameSrcSpan targetName
   tc <-

test/data/GotoHover.hs

@@ -19,11 +19,11 @@ a +! b = a - b
 hhh (Just a) (><) = a >< a
 iii a b = a `b` a
 jjj s = pack $ s <> s
-class Class a where
+class MyClass a where
   method :: a -> Int
-instance Class Int where
+instance MyClass Int where
   method = succ
-kkk :: Class a => Int -> a -> Int
+kkk :: MyClass a => Int -> a -> Int
 kkk n c = n + method c
 
 doBind :: Maybe ()

test/exe/Main.hs

@@ -825,17 +825,17 @@ findDefinitionAndHoverTests = let
   aaaL14 = Position 14 20  ;  aaa    = [mkR   7  0    7  3]
   dcL7   = Position  7 11  ;  tcDC   = [mkR   3 23    5 16]
   dcL12  = Position 12 11  ;
-  xtcL5  = Position  5 11  ;  xtc    = [ExpectExternFail]
-  tcL6   = Position  6 11  ;  tcData = [mkR   3  0    5 16]
+  xtcL5  = Position  5 11  ;  xtc    = [ExpectExternFail,   ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
+  tcL6   = Position  6 11  ;  tcData = [mkR   3  0    5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]
   vvL16  = Position 16 12  ;  vv     = [mkR  16  4   16  6]
   opL16  = Position 16 15  ;  op     = [mkR  17  2   17  4]
   opL18  = Position 18 22  ;  opp    = [mkR  18 13   18 17]
   aL18   = Position 18 20  ;  apmp   = [mkR  18 10   18 11]
   b'L19  = Position 19 13  ;  bp     = [mkR  19  6   19  7]
-  xvL20  = Position 20  8  ;  xvMsg  = [ExpectHoverText ["Data.Text.pack", ":: String -> Text"], ExpectExternFail]
-  clL23  = Position 23 11  ;  cls    = [mkR  21  0   22 20]
+  xvL20  = Position 20  8  ;  xvMsg  = [ExpectExternFail,   ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
+  clL23  = Position 23 11  ;  cls    = [mkR  21  0   22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]
   clL25  = Position 25  9
-  eclL15 = Position 15  8  ;  ecls   = [ExpectHoverText ["Num"], ExpectExternFail]
+  eclL15 = Position 15  8  ;  ecls   = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
   dnbL29 = Position 29 18  ;  dnb    = [ExpectHoverText [":: ()"],   mkR  29 12   29 21]
   dnbL30 = Position 30 23
   lcbL33 = Position 33 26  ;  lcb    = [ExpectHoverText [":: Char"], mkR  33 26   33 27]
@@ -852,24 +852,24 @@ findDefinitionAndHoverTests = let
   , test yes    yes    aaaL14 aaa    "top-level name"                       -- 120
   , test broken broken dcL7   tcDC   "data constructor record         #247"
   , test yes    yes    dcL12  tcDC   "data constructor plain"               -- 121
-  , test yes    broken tcL6   tcData "type constructor                #249" -- 147
-  , test broken broken xtcL5  xtc    "type constructor external       #249"
+  , test yes    yes    tcL6   tcData "type constructor                #248" -- 147
+  , test broken yes    xtcL5  xtc    "type constructor external   #248,249"
   , test broken yes    xvL20  xvMsg  "value external package          #249" -- 120
   , test yes    yes    vvL16  vv     "plain parameter"                      -- 120
   , test yes    yes    aL18   apmp   "pattern match name"                   -- 120
   , test yes    yes    opL16  op     "top-level operator"                   -- 120, 123
   , test yes    yes    opL18  opp    "parameter operator"                   -- 120
   , test yes    yes    b'L19  bp     "name in backticks"                    -- 120
-  , test yes    broken clL23  cls    "class in instance declaration   #250"
-  , test yes    broken clL25  cls    "class in signature              #250" -- 147
-  , test broken broken eclL15 ecls   "external class in signature #249,250"
+  , test yes    yes    clL23  cls    "class in instance declaration   #250"
+  , test yes    yes    clL25  cls    "class in signature              #250" -- 147
+  , test broken yes    eclL15 ecls   "external class in signature #249,250"
   , test yes    yes    dnbL29 dnb    "do-notation   bind"                   -- 137
   , test yes    yes    dnbL30 dnb    "do-notation lookup"
   , test yes    yes    lcbL33 lcb    "listcomp   bind"                      -- 137
   , test yes    yes    lclL33 lcb    "listcomp lookup"
   , test yes    yes    mclL36 mcl    "top-level fn 1st clause"
   , test yes    yes    mclL37 mcl    "top-level fn 2nd clause         #246"
-  , test no     broken docL40 doc    "documentation"
+  , test no     broken docL40 doc    "documentation                     #7"
   ]
   where yes, broken :: (TestTree -> Maybe TestTree)
         yes    = Just -- test should run and pass