Skip to content

Commit bbb75c2

Browse files
jacgaherrmann-da
jacg
authored and
aherrmann-da
committed
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
1 parent b2ad2eb commit bbb75c2

File tree

4 files changed

+58
-40
lines changed

4 files changed

+58
-40
lines changed

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

Lines changed: 41 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -55,33 +55,52 @@ atPoint
5555
-> [SpanInfo]
5656
-> Position
5757
-> Maybe (Maybe Range, [T.Text])
58-
atPoint IdeOptions{..} tcs srcSpans pos = do
59-
SpanInfo{..} <- listToMaybe $ orderSpans $ spansAtPoint pos srcSpans
60-
ty <- spaninfoType
61-
let mbName = getNameM spaninfoSource
62-
mbDefinedAt = fmap (\name -> "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n") mbName
63-
docInfo = maybe [] (\name -> getDocumentation name tcs) mbName
64-
range = Range
65-
(Position spaninfoStartLine spaninfoStartCol)
66-
(Position spaninfoEndLine spaninfoEndCol)
67-
colon = if optNewColonConvention then ":" else "::"
68-
wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
69-
typeSig = wrapLanguageSyntax $ case mbName of
70-
Nothing -> colon <> " " <> showName ty
71-
Just name ->
72-
let modulePrefix = maybe "" (<> ".") (getModuleNameAsText name)
73-
in modulePrefix <> showName name <> "\n " <> colon <> " " <> showName ty
74-
hoverInfo = docInfo <> [typeSig] <> maybeToList mbDefinedAt
75-
return (Just range, hoverInfo)
58+
atPoint IdeOptions{..} tcs pos srcSpans = do
59+
firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint srcSpans pos
60+
return (Just (range firstSpan), hoverInfo firstSpan)
7661
where
62+
-- Hover info for types, classes, type variables
63+
hoverInfo SpanInfo{spaninfoType = Nothing , ..} =
64+
documentation <> (wrapLanguageSyntax <$> name <> kind) <> location
65+
where
66+
documentation = findDocumentation mbName
67+
name = [maybe shouldNotHappen showName mbName]
68+
location = [maybe shouldNotHappen definedAt mbName]
69+
kind = [] -- TODO
70+
shouldNotHappen = "ghcide: did not expect a type level component without a name"
71+
mbName = getNameM spaninfoSource
72+
73+
-- Hover info for values/data
74+
hoverInfo SpanInfo{spaninfoType = (Just typ), ..} =
75+
documentation <> (wrapLanguageSyntax <$> nameOrSource <> typeAnnotation) <> location
76+
where
77+
mbName = getNameM spaninfoSource
78+
documentation = findDocumentation mbName
79+
typeAnnotation = [colon <> showName typ]
80+
nameOrSource = [maybe literalSource qualifyNameIfPossible mbName]
81+
literalSource = "" -- TODO: literals: display (length-limited) source
82+
qualifyNameIfPossible name' = modulePrefix <> showName name'
83+
where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')
84+
location = [maybe "" definedAt mbName]
85+
86+
findDocumentation = maybe [] (getDocumentation tcs)
87+
definedAt name = "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n"
88+
89+
range SpanInfo{..} = Range
90+
(Position spaninfoStartLine spaninfoStartCol)
91+
(Position spaninfoEndLine spaninfoEndCol)
92+
93+
colon = if optNewColonConvention then ": " else ":: "
94+
wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
95+
7796
-- NOTE(RJR): This is a bit hacky.
7897
-- We don't want to show the user type signatures generated from Eq and Show
7998
-- instances, as they do not appear in the source program.
8099
-- However the user could have written an `==` or `show` function directly,
81100
-- in which case we still want to show information for that.
82101
-- Hence we just move such information later in the list of spans.
83-
orderSpans :: [SpanInfo] -> [SpanInfo]
84-
orderSpans = uncurry (++) . partition (not . isTypeclassDeclSpan)
102+
deEmpasizeGeneratedEqShow :: [SpanInfo] -> [SpanInfo]
103+
deEmpasizeGeneratedEqShow = uncurry (++) . partition (not . isTypeclassDeclSpan)
85104
isTypeclassDeclSpan :: SpanInfo -> Bool
86105
isTypeclassDeclSpan spanInfo =
87106
case getNameM (spaninfoSource spanInfo) of
@@ -90,9 +109,7 @@ atPoint IdeOptions{..} tcs srcSpans pos = do
90109

91110
locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]
92111
locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
93-
fmap (map srcSpanToLocation) .
94-
mapMaybeM (getSpan . spaninfoSource) .
95-
spansAtPoint pos
112+
fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos
96113
where getSpan :: SpanSource -> m (Maybe SrcSpan)
97114
getSpan NoSource = pure Nothing
98115
getSpan (SpanS sp) = pure $ Just sp
@@ -121,6 +138,7 @@ locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
121138
setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
122139
setFileName _ span@(UnhelpfulSpan _) = span
123140

141+
-- | Filter out spans which do not enclose a given point
124142
spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
125143
spansAtPoint pos = filter atp where
126144
line = _line pos

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -18,8 +18,8 @@ import SrcLoc
1818

1919

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

‎test/data/GotoHover.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -19,11 +19,11 @@ a +! b = a - b
1919
hhh (Just a) (><) = a >< a
2020
iii a b = a `b` a
2121
jjj s = pack $ s <> s
22-
class Class a where
22+
class MyClass a where
2323
method :: a -> Int
24-
instance Class Int where
24+
instance MyClass Int where
2525
method = succ
26-
kkk :: Class a => Int -> a -> Int
26+
kkk :: MyClass a => Int -> a -> Int
2727
kkk n c = n + method c
2828

2929
doBind :: Maybe ()

‎test/exe/Main.hs

Lines changed: 11 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -825,17 +825,17 @@ findDefinitionAndHoverTests = let
825825
aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
826826
dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
827827
dcL12 = Position 12 11 ;
828-
xtcL5 = Position 5 11 ; xtc = [ExpectExternFail]
829-
tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16]
828+
xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
829+
tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]
830830
vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
831831
opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
832832
opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
833833
aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
834834
b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
835-
xvL20 = Position 20 8 ; xvMsg = [ExpectHoverText ["Data.Text.pack", ":: String -> Text"], ExpectExternFail]
836-
clL23 = Position 23 11 ; cls = [mkR 21 0 22 20]
835+
xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
836+
clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]
837837
clL25 = Position 25 9
838-
eclL15 = Position 15 8 ; ecls = [ExpectHoverText ["Num"], ExpectExternFail]
838+
eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
839839
dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
840840
dnbL30 = Position 30 23
841841
lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]
@@ -852,24 +852,24 @@ findDefinitionAndHoverTests = let
852852
, test yes yes aaaL14 aaa "top-level name" -- 120
853853
, test broken broken dcL7 tcDC "data constructor record #247"
854854
, test yes yes dcL12 tcDC "data constructor plain" -- 121
855-
, test yes broken tcL6 tcData "type constructor #249" -- 147
856-
, test broken broken xtcL5 xtc "type constructor external #249"
855+
, test yes yes tcL6 tcData "type constructor #248" -- 147
856+
, test broken yes xtcL5 xtc "type constructor external #248,249"
857857
, test broken yes xvL20 xvMsg "value external package #249" -- 120
858858
, test yes yes vvL16 vv "plain parameter" -- 120
859859
, test yes yes aL18 apmp "pattern match name" -- 120
860860
, test yes yes opL16 op "top-level operator" -- 120, 123
861861
, test yes yes opL18 opp "parameter operator" -- 120
862862
, test yes yes b'L19 bp "name in backticks" -- 120
863-
, test yes broken clL23 cls "class in instance declaration #250"
864-
, test yes broken clL25 cls "class in signature #250" -- 147
865-
, test broken broken eclL15 ecls "external class in signature #249,250"
863+
, test yes yes clL23 cls "class in instance declaration #250"
864+
, test yes yes clL25 cls "class in signature #250" -- 147
865+
, test broken yes eclL15 ecls "external class in signature #249,250"
866866
, test yes yes dnbL29 dnb "do-notation bind" -- 137
867867
, test yes yes dnbL30 dnb "do-notation lookup"
868868
, test yes yes lcbL33 lcb "listcomp bind" -- 137
869869
, test yes yes lclL33 lcb "listcomp lookup"
870870
, test yes yes mclL36 mcl "top-level fn 1st clause"
871871
, test yes yes mclL37 mcl "top-level fn 2nd clause #246"
872-
, test no broken docL40 doc "documentation"
872+
, test no broken docL40 doc "documentation #7"
873873
]
874874
where yes, broken :: (TestTree -> Maybe TestTree)
875875
yes = Just -- test should run and pass

0 commit comments

Comments
 (0)