API Annotations: more explicit foralls fixup

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

Closes #16230

6 files changed, 120 insertions, 25 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
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index 2478f29ff0..f7a66f41bb 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -149,3 +149,7 @@ T15303:
 .PHONY: T16212
 T16212:
 	$(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16212.hs
+
+.PHONY: T16230
+T16230:
+	$(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16230.hs
diff --git a/testsuite/tests/ghc-api/annotations/T16230.stdout b/testsuite/tests/ghc-api/annotations/T16230.stdout
new file mode 100644
index 0000000000..af1d96395e
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T16230.stdout
@@ -0,0 +1,66 @@
+---Unattached Annotation Problems (should be empty list)---
+[]
+---Ann before enclosing span problem (should be empty list)---
+[
+
+]
+
+---Annotations-----------------------
+-- SrcSpan the annotation is attached to, AnnKeywordId,
+--    list of locations the keyword item appears in
+[
+((Test16230.hs:1:1,AnnModule), [Test16230.hs:7:1-6]),
+((Test16230.hs:1:1,AnnWhere), [Test16230.hs:7:28-32]),
+((Test16230.hs:9:1-17,AnnImport), [Test16230.hs:9:1-6]),
+((Test16230.hs:9:1-17,AnnSemi), [Test16230.hs:11:1]),
+((Test16230.hs:11:1-11,AnnData), [Test16230.hs:11:1-4]),
+((Test16230.hs:11:1-11,AnnFamily), [Test16230.hs:11:6-11]),
+((Test16230.hs:11:1-11,AnnSemi), [Test16230.hs:12:1]),
+((Test16230.hs:12:1-52,AnnData), [Test16230.hs:12:1-4]),
+((Test16230.hs:12:1-52,AnnDot), [Test16230.hs:12:33]),
+((Test16230.hs:12:1-52,AnnEqual), [Test16230.hs:12:48]),
+((Test16230.hs:12:1-52,AnnForall), [Test16230.hs:12:15-20]),
+((Test16230.hs:12:1-52,AnnInstance), [Test16230.hs:12:6-13]),
+((Test16230.hs:12:1-52,AnnSemi), [Test16230.hs:14:1]),
+((Test16230.hs:12:22-32,AnnCloseP), [Test16230.hs:12:32]),
+((Test16230.hs:12:22-32,AnnDcolon), [Test16230.hs:12:25-26]),
+((Test16230.hs:12:22-32,AnnOpenP), [Test16230.hs:12:22]),
+((Test16230.hs:12:38-46,AnnCloseP), [Test16230.hs:12:46]),
+((Test16230.hs:12:38-46,AnnOpenP), [Test16230.hs:12:38]),
+((Test16230.hs:(14,1)-(15,13),AnnClass), [Test16230.hs:14:1-5]),
+((Test16230.hs:(14,1)-(15,13),AnnSemi), [Test16230.hs:17:1]),
+((Test16230.hs:(14,1)-(15,13),AnnWhere), [Test16230.hs:14:11-15]),
+((Test16230.hs:15:3-13,AnnType), [Test16230.hs:15:3-6]),
+((Test16230.hs:(17,1)-(18,31),AnnInstance), [Test16230.hs:17:1-8]),
+((Test16230.hs:(17,1)-(18,31),AnnSemi), [Test16230.hs:21:1]),
+((Test16230.hs:(17,1)-(18,31),AnnWhere), [Test16230.hs:17:26-30]),
+((Test16230.hs:17:10-24,AnnDot), [Test16230.hs:17:18]),
+((Test16230.hs:17:10-24,AnnForall), [Test16230.hs:17:10-15]),
+((Test16230.hs:17:22-24,AnnCloseS), [Test16230.hs:17:24]),
+((Test16230.hs:17:22-24,AnnOpenS), [Test16230.hs:17:22]),
+((Test16230.hs:18:3-31,AnnDot), [Test16230.hs:18:16]),
+((Test16230.hs:18:3-31,AnnEqual), [Test16230.hs:18:27]),
+((Test16230.hs:18:3-31,AnnForall), [Test16230.hs:18:8-13]),
+((Test16230.hs:18:3-31,AnnType), [Test16230.hs:18:3-6]),
+((Test16230.hs:18:8-31,AnnDot), [Test16230.hs:18:16]),
+((Test16230.hs:18:8-31,AnnEqual), [Test16230.hs:18:27]),
+((Test16230.hs:18:8-31,AnnForall), [Test16230.hs:18:8-13]),
+((Test16230.hs:18:21-23,AnnCloseS), [Test16230.hs:18:23]),
+((Test16230.hs:18:21-23,AnnOpenS), [Test16230.hs:18:21]),
+((Test16230.hs:21:1-17,AnnFamily), [Test16230.hs:21:6-11]),
+((Test16230.hs:21:1-17,AnnSemi), [Test16230.hs:24:1]),
+((Test16230.hs:21:1-17,AnnType), [Test16230.hs:21:1-4]),
+((Test16230.hs:21:1-17,AnnWhere), [Test16230.hs:21:19-23]),
+((Test16230.hs:22:3-38,AnnDot), [Test16230.hs:22:13]),
+((Test16230.hs:22:3-38,AnnEqual), [Test16230.hs:22:31]),
+((Test16230.hs:22:3-38,AnnForall), [Test16230.hs:22:3-8]),
+((Test16230.hs:22:3-38,AnnSemi), [Test16230.hs:23:3]),
+((Test16230.hs:22:17-19,AnnCloseS), [Test16230.hs:22:19]),
+((Test16230.hs:22:17-19,AnnOpenS), [Test16230.hs:22:17]),
+((Test16230.hs:22:21-29,AnnCloseP), [Test16230.hs:22:29]),
+((Test16230.hs:22:21-29,AnnOpenP), [Test16230.hs:22:21]),
+((Test16230.hs:23:3-36,AnnDot), [Test16230.hs:23:11]),
+((Test16230.hs:23:3-36,AnnEqual), [Test16230.hs:23:31]),
+((Test16230.hs:23:3-36,AnnForall), [Test16230.hs:23:3-8]),
+((<no location info>,AnnEofPos), [Test16230.hs:24:1])
+]
diff --git a/testsuite/tests/ghc-api/annotations/Test16230.hs b/testsuite/tests/ghc-api/annotations/Test16230.hs
new file mode 100644
index 0000000000..e231878464
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test16230.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+module MoreExplicitForalls where
+
+import Data.Proxy
+
+data family F1 a
+data instance forall (x :: Bool). F1 (Proxy x) = MkF
+
+class C a where
+  type F2 a b
+
+instance forall a. C [a] where
+  type forall b. F2 [a] b = Int
+
+
+type family G a b where
+  forall x y. G [x] (Proxy y) = Double
+  forall z.   G z   z         = Bool
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index 212e218ccb..e4413f7924 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -59,6 +59,7 @@ test('T13163',      [extra_files(['Test13163.hs']),
                      ignore_stderr], makefile_test, ['T13163'])
 test('T15303',      [extra_files(['Test15303.hs']),
                      ignore_stderr], makefile_test, ['T15303'])
-# Stricter tests from trac #16217 now causes this to fail. Will be fixed for trac #16212
 test('T16212',      [expect_broken(16212),extra_files(['Test16212.hs']),
                      ignore_stderr], makefile_test, ['T16212'])
+test('T16230',      [extra_files(['Test16230.hs']),
+                     ignore_stderr], makefile_test, ['T16230'])