API Annotations: more explicit foralls fixup

The AnnForall annotations introduced via Phab:D4894 are not always
attached to the correct SourceSpan.

Closes #16230

2 files changed, 25 insertions, 24 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index ce5c523e6f..e33b715b51 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1142,20 +1142,20 @@ inst_decl :: { LInstDecl GhcPs }
           -- data/newtype instance declaration
         | data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs
                           maybe_derivings
-            {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
+            {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
                                       Nothing (reverse (snd  $ unLoc $5))
                                               (fmap reverse $6))
-                    ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
+                    ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
 
           -- GADT instance declaration
         | data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
                  gadt_constrlist
                  maybe_derivings
-            {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4
+            {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4)
                                    (snd $ unLoc $5) (snd $ unLoc $6)
                                    (fmap reverse $7))
                     ((fst $ unLoc $1):mj AnnInstance $2
-                       :(fst $ unLoc $5)++(fst $ unLoc $6)) }
+                       :(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }
 
 overlap_pragma :: { Maybe (Located OverlapMode) }
   : '{-# OVERLAPPABLE'    '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))))
@@ -1241,8 +1241,8 @@ ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
         : 'forall' tv_bndrs '.' type '=' ktype
               {% do { hintExplicitForall (getLoc $1)
                     ; (eqn,ann) <- mkTyFamInstEqn (Just $2) $4 $6
-                    ; ams (sLL $4 $> (mj AnnEqual $5:ann, eqn))
-                          [mu AnnForall $1, mj AnnDot $3]  } }
+                    ; return (sLL $1 $>
+                               (mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } }
         | type '=' ktype
               {% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3
                     ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn))  } }
@@ -1312,16 +1312,16 @@ at_decl_inst :: { LInstDecl GhcPs }
         -- data/newtype instance declaration, with optional 'instance' keyword
         -- (can't use opt_instance because you get reduce/reduce errors)
         | data_or_newtype capi_ctype tycl_hdr_inst constrs maybe_derivings
-               {% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
+               {% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 (snd $ unLoc $3)
                                     Nothing (reverse (snd $ unLoc $4))
                                             (fmap reverse $5))
-                       ((fst $ unLoc $1):(fst $ unLoc $4)) }
+                       ((fst $ unLoc $1):(fst $ unLoc $3) ++ (fst $ unLoc $4)) }
 
         | data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs maybe_derivings
-               {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
+               {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
                                     Nothing (reverse (snd $ unLoc $5))
                                             (fmap reverse $6))
-                       ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
+                       ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
 
         -- GADT instance declaration, with optional 'instance' keyword
         -- (can't use opt_instance because you get reduce/reduce errors)
@@ -1329,17 +1329,17 @@ at_decl_inst :: { LInstDecl GhcPs }
                  gadt_constrlist
                  maybe_derivings
                 {% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2
-                                $3 (snd $ unLoc $4) (snd $ unLoc $5)
+                                (snd $ unLoc $3) (snd $ unLoc $4) (snd $ unLoc $5)
                                 (fmap reverse $6))
-                        ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
+                        ((fst $ unLoc $1):(fst $ unLoc $3)++(fst $ unLoc $4)++(fst $ unLoc $5)) }
 
         | data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
                  gadt_constrlist
                  maybe_derivings
                 {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3
-                                $4 (snd $ unLoc $5) (snd $ unLoc $6)
+                                (snd $ unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)
                                 (fmap reverse $7))
-                        ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)++(fst $ unLoc $6)) }
+                        ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }
 
 data_or_newtype :: { Located (AddAnn, NewOrData) }
         : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }
@@ -1382,20 +1382,21 @@ tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }
                                     }
         | type                      { sL1 $1 (Nothing, $1) }
 
-tycl_hdr_inst :: { Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs) }
+tycl_hdr_inst :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs)) }
         : 'forall' tv_bndrs '.' context '=>' type   {% hintExplicitForall (getLoc $1)
                                                        >> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5)
-                                                           >> ams (sLL $1 $> $ (Just $4, Just $2, $6))
-                                                                  [mu AnnForall $1, mj AnnDot $3])
+                                                           >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]
+                                                                                , (Just $4, Just $2, $6)))
+                                                          )
                                                     }
         | 'forall' tv_bndrs '.' type   {% hintExplicitForall (getLoc $1)
-                                          >> ams (sLL $1 $> $ (Nothing, Just $2, $4))
-                                                 [mu AnnForall $1, mj AnnDot $3]
+                                          >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]
+                                                               , (Nothing, Just $2, $4)))
                                        }
         | context '=>' type         {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
-                                       >> (return (sLL $1 $> (Just $1, Nothing, $3)))
+                                       >> (return (sLL $1 $>([], (Just $1, Nothing, $3))))
                                     }
-        | type                      { sL1 $1 (Nothing, Nothing, $1) }
+        | type                      { sL1 $1 ([], (Nothing, Nothing, $1)) }
 
 
 capi_ctype :: { Maybe (Located CType) }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 6a756544d9..0766b04ada 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -263,13 +263,13 @@ mkTyFamInstEqn bndrs lhs rhs
 mkDataFamInst :: SrcSpan
               -> NewOrData
               -> Maybe (Located CType)
-              -> Located ( Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
-                         , LHsType GhcPs)
+              -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
+                        , LHsType GhcPs)
               -> Maybe (LHsKind GhcPs)
               -> [LConDecl GhcPs]
               -> HsDeriving GhcPs
               -> P (LInstDecl GhcPs)
-mkDataFamInst loc new_or_data cType (dL->L _ (mcxt, bndrs, tycl_hdr))
+mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
               ksig data_cons maybe_deriv
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan