ApiAnnotations : parens around a context with wildcard loses annotations

Summary:
In the following code, the extra set of parens around the context end up
with detached annotations.

    {-# LANGUAGE PartialTypeSignatures #-}
    module ParensAroundContext where

    f :: ((Eq a, _)) => a -> a -> Bool
    f x y = x == y

Trac ticket #10354

It turns out it was the TupleTy that was the culprit.

This may also solve #10315

Test Plan: ./validate

Reviewers: hvr, austin, goldfire

Reviewed By: austin

Subscribers: goldfire, bgamari, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D868

GHC Trac Issues: #10354, #10315

2 files changed, 15 insertions, 13 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index ed6f5ad4c8..5a862a8058 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1606,14 +1606,14 @@ ctypedoc :: { LHsType RdrName }
 -- Thus for some reason we allow    f :: a~b => blah
 -- but not                          f :: ?x::Int => blah
 context :: { LHsContext RdrName }
-        : btype '~'      btype          {% amms (checkContext
-                                             (sLL $1 $> $ HsEqTy $1 $3))
-                                             [mj AnnTilde $2] }
-        | btype                         {% do { ctx <- checkContext $1
+        : btype '~'      btype          {% do { (anns,ctx) <- checkContext
+                                                 (sLL $1 $> $ HsEqTy $1 $3)
+                                              ; ams ctx (mj AnnTilde $2:anns) } }
+        | btype                         {% do { (anns,ctx) <- checkContext $1
                                               ; if null (unLoc ctx)
                                                  then addAnnotation (gl $1) AnnUnit (gl $1)
                                                  else return ()
-                                              ; return ctx
+                                              ; ams ctx anns
                                               } }
 
 type :: { LHsType RdrName }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 5e2fa131cf..14476407fc 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -864,18 +864,20 @@ checkTyClHdr is_cls ty
       = parseErrorSDoc l (text "Malformed head of type or class declaration:"
                           <+> ppr ty)
 
-checkContext :: LHsType RdrName -> P (LHsContext RdrName)
+checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName)
 checkContext (L l orig_t)
-  = check orig_t
+  = check [] (L l orig_t)
  where
-  check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
-    = return (L l ts)           -- Ditto ()
+  check anns (L lp (HsTupleTy _ ts))   -- (Eq a, Ord b) shows up as a tuple type
+    = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()
 
-  check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
-    = check (unLoc ty)
+  check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
+       = check anns' ty
+         where anns' = if l == lp1 then anns
+                                   else (anns ++ mkParensApiAnn lp1)
 
-  check _
-    = return (L l [L l orig_t])
+  check _anns _
+    = return ([],L l [L l orig_t]) -- no need for anns, returning original
 
 -- -------------------------------------------------------------------------
 -- Checking Patterns.