Fix source spans for multi-clause definitions (haskell/ghcide#318)

* Fix source spans for multi-clause definitions

Currently, we use the source span of the match which corresponds to
the whole clause instead of just the function identifier. This
resulted in us pointing every goto definition request within a clause
to the function if there is no other information (either because it
failed because it came from an external package or simply because you
are not on an identifier).

This PR fixes this by getting the proper source spans frmo the
HsMatchContext. Somewhat annoyingly, we have to get it from the parsed
module since GHC messes this up during typechecking but it’s
reasonably simple.

src/Development/IDE/Spans/Calculate.hs

@@ -23,13 +23,15 @@ import           Desugar
 import           GHC
 import           GhcMonad
 import           FastString (mkFastString)
+import           OccName
 import           Development.IDE.Types.Location
 import           Development.IDE.Spans.Type
 import           Development.IDE.GHC.Error (zeroSpan)
 import           Prelude hiding (mod)
 import           TcHsSyn
 import           Var
 import Development.IDE.Core.Compile
+import qualified Development.IDE.GHC.Compat as Compat
 import Development.IDE.GHC.Util
 
 
@@ -63,7 +65,8 @@ getSpanInfo mods tcm =
          es  = listifyAllSpans  tcs :: [LHsExpr GhcTc]
          ps  = listifyAllSpans' tcs :: [Pat GhcTc]
          ts  = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]
-     bts <- mapM (getTypeLHsBind tcm) bs -- binds
+     let funBinds = funBindMap $ tm_parsed_module tcm
+     bts <- mapM (getTypeLHsBind funBinds) bs -- binds
      ets <- mapM (getTypeLHsExpr tcm) es -- expressions
      pts <- mapM (getTypeLPat tcm)    ps -- patterns
      tts <- mapM (getLHsType tcm)     ts -- types
@@ -76,6 +79,15 @@ getSpanInfo mods tcm =
           | b `isSubspanOf` a = GT
           | otherwise         = compare (srcSpanStart a) (srcSpanStart b)
 
+-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always
+-- points to the first match) whereas the parsed module has the correct locations.
+-- Therefore we build up a map from OccName to the corresponding definition in the parsed module
+-- to lookup precise locations for things like multi-clause function definitions.
+--
+-- For now this only contains FunBinds.
+funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs)
+funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ]
+
 getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)]
 getExports m
     | Just (_, _, Just exports, _) <- renamedSource m =
@@ -95,12 +107,15 @@ ieLNames _ = []
 
 -- | Get the name and type of a binding.
 getTypeLHsBind :: (GhcMonad m)
-               => TypecheckedModule
+               => OccEnv (HsBind GhcPs)
                -> LHsBind GhcTc
                -> m [(SpanSource, SrcSpan, Maybe Type)]
-getTypeLHsBind _ (L _spn FunBind{ fun_id = pid
-                                , fun_matches = MG{mg_alts=(L _ matches)}}) =
-  return [(Named (getName (unLoc pid)), getLoc match, Just (varType (unLoc pid))) | match <- matches ]
+getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid})
+  | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) =
+  return [(Named (getName (unLoc pid)), getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
+-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.
+getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =
+  return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))]
 getTypeLHsBind _ _ = return []
 
 -- | Get the name and type of an expression.

test/data/GotoHover.hs

@@ -34,7 +34,7 @@ listCompBind :: [Char]
 listCompBind = [ succ c | c <- "ptfx" ]
 
 multipleClause :: Bool -> Char
-multipleClause True  = 't'
+multipleClause True  =    't'
 multipleClause False = 'f'
 
 -- | Recognizable docs: kpqz

test/exe/Main.hs

@@ -1004,6 +1004,8 @@ findDefinitionAndHoverTests = let
     check (ExpectRange expectedRange) = do
       assertNDefinitionsFound 1 defs
       assertRangeCorrect (head defs) expectedRange
+    check ExpectNoDefinitions = do
+      assertNDefinitionsFound 0 defs
     check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
     check _ = pure () -- all other expectations not relevant to getDefinition
 
@@ -1018,13 +1020,14 @@ findDefinitionAndHoverTests = let
 
     check expected =
       case hover of
-        Nothing -> liftIO $ assertFailure "no hover found"
+        Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
         Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
                   ,_range    = rangeInHover } ->
           case expected of
             ExpectRange  expectedRange -> checkHoverRange expectedRange rangeInHover msg
             ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
             ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
+            ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
             _ -> pure () -- all other expectations not relevant to hover
         _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
 
@@ -1089,6 +1092,7 @@ findDefinitionAndHoverTests = let
   lclL33 = Position 33 22
   mclL36 = Position 36  1  ;  mcl    = [mkR  36  0   36 14]
   mclL37 = Position 37  1
+  spaceL37 = Position 37  24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
   docL41 = Position 41  1  ;  doc    = [ExpectHoverText ["Recognizable docs: kpqz"]]
                            ;  constr = [ExpectHoverText ["Monad m =>"]]
   eitL40 = Position 40 28  ;  kindE  = [ExpectHoverText [":: * -> * -> *\n"]]
@@ -1126,6 +1130,7 @@ findDefinitionAndHoverTests = let
   , 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 yes    yes    spaceL37 space "top-level fn on space #315"
   , test no     broken docL41 doc    "documentation                     #7"
   , test no     broken eitL40 kindE  "kind of Either                  #273"
   , test no     broken intL40 kindI  "kind of Int                     #273"
@@ -1482,7 +1487,10 @@ data Expect
   | ExpectHoverRange Range -- Only hover should report this range
   | ExpectHoverText [T.Text] -- the hover message must contain these snippets
   | ExpectExternFail -- definition lookup in other file expected to fail
+  | ExpectNoDefinitions
+  | ExpectNoHover
 --  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
+  deriving Eq
 
 mkR :: Int -> Int -> Int -> Int -> Expect
 mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn