Fix #248 and #250 (#267)

* Fix #248 and #250

This fixes hover for types, classes and type variables.

Information about spans includes a `Maybe Type` which is `Just` for data-level
expressions and `Nothing` for type-level expressions.

`AtPoint.atPoint` which is the oddly-named function responsible for constructing
hover information, runs in the `Maybe` monad, and aborted at the first sight of
a `Nothing`, thus producing no hover information for type-level spans.

In the process of fixing this, I have refactored the function to

+ separate the construction of data-level and type-level hover info

+ make the components that make up the hover info (and their construction) more
  clear

I can see plenty little improvements that could be made to the functionality of
the code (and lots that could be made to its organization), but the most
important fixes of the basic missing functionality are here.

Fix #248
Fix #250

* Revert behaviour of locationsAtPoint to match its name

The name suggests that it returns all locations, while the last commit changed
this to return at most one.

* Fix issue numbers in test titles

There was some confusion about which tests addressed issue 248 vs 249

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