parser: opt_kind_sig has incorrect SrcSpan

The production for opt_kind_sig is

  opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
          :                             { noLoc Nothing }
          | '::' kind                   {% ajl (sLL $1 $> (Just $2)) AnnDcolon (gl $1) }

The outer Location is used only to get the full span for the enclosing
declration, and is then stripped. The inner LHsKind then has a SrcSpan that does
not include the '::'

Extend the SrcSpan on $2 to include $1

Reviewed By: austin

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

GHC Trac Issues: #10209

(cherry picked from commit 8aefc9b746512e91891879ad546e850e8a427d23)

6 files changed, 56 insertions, 27 deletions

diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index afd6e1e44b..4e94b3e33f 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -466,7 +466,8 @@ data TyClDecl name
     --
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
     --             'ApiAnnotation.AnnData',
-    --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnWhere',
+    --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon',
+    --             'ApiAnnotation.AnnWhere',
     --             'ApiAnnotation.AnnOpen','ApiAnnotation.AnnDcolon',
     --             'ApiAnnotation.AnnClose'
 
@@ -490,7 +491,8 @@ data TyClDecl name
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
     --              'ApiAnnotation.AnnFamily',
     --              'ApiAnnotation.AnnNewType',
-    --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnWhere'
+    --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon'
+    --              'ApiAnnotation.AnnWhere',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
     DataDecl { tcdLName    :: Located name        -- ^ Type constructor
@@ -1095,6 +1097,7 @@ data DataFamInstDecl name
     -- ^
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
     --           'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',
+    --           'ApiAnnotation.AnnDcolon'
     --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
     --           'ApiAnnotation.AnnClose'
 
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index b5a3f9af88..7937eb8ef0 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -145,6 +145,9 @@ type LHsType name = Located (HsType name)
       -- For details on above see note [Api annotations] in ApiAnnotation
 type HsKind name = HsType name
 type LHsKind name = Located (HsKind name)
+      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
 type LHsTyVarBndr name = Located (HsTyVarBndr name)
 
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index fe55ab4458..73af11714b 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -785,8 +785,8 @@ ty_decl :: { LTyClDecl RdrName }
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared
                 {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $5) $3
-                                   (unLoc $4))
-                        (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $5)) }
+                                   (snd $ unLoc $4))
+                        (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
 
           -- ordinary data type or newtype declaration
         | data_or_newtype capi_ctype tycl_hdr constrs deriving
@@ -802,15 +802,15 @@ ty_decl :: { LTyClDecl RdrName }
                  gadt_constrlist
                  deriving
             {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3
-                            (unLoc $4) (snd $ unLoc $5) (unLoc $6) )
+                            (snd $ unLoc $4) (snd $ unLoc $5) (unLoc $6) )
                                    -- We need the location on tycl_hdr in case
                                    -- constrs and deriving are both empty
-                    ((fst $ unLoc $1):(fst $ unLoc $5)) }
+                    ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
 
           -- data/newtype family
         | 'data' 'family' type opt_kind_sig
-                {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4))
-                        [mj AnnData $1,mj AnnFamily $2] }
+                {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (snd $ unLoc $4))
+                        (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }
 
 inst_decl :: { LInstDecl RdrName }
         : 'instance' overlap_pragma inst_type where_inst
@@ -845,9 +845,9 @@ inst_decl :: { LInstDecl RdrName }
                  gadt_constrlist
                  deriving
             {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4
-                                   (unLoc $5) (snd $ unLoc $6) (unLoc $7))
+                                   (snd $ unLoc $5) (snd $ unLoc $6) (unLoc $7))
                     ((fst $ unLoc $1):mj AnnInstance $2
-                       :(fst $ unLoc $6)) }
+                       :(fst $ unLoc $5)++(fst $ unLoc $6)) }
 
 overlap_pragma :: { Maybe (Located OverlapMode) }
   : '{-# OVERLAPPABLE'    '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))))
@@ -907,19 +907,19 @@ at_decl_cls :: { LHsDecl RdrName }
         :  -- data family declarations, with optional 'family' keyword
           'data' opt_family type opt_kind_sig
                 {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3
-                                                  (unLoc $4)))
-                        (mj AnnData $1:$2) }
+                                                  (snd $ unLoc $4)))
+                        (mj AnnData $1:$2++(fst $ unLoc $4)) }
 
            -- type family declarations, with optional 'family' keyword
            -- (can't use opt_instance because you get shift/reduce errors
         | 'type' type opt_kind_sig
                {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $2 $3)
-                                                  OpenTypeFamily $2 (unLoc $3)))
-                       [mj AnnType $1] }
+                                                  OpenTypeFamily $2 (snd $ unLoc $3)))
+                       (mj AnnType $1:(fst $ unLoc $3)) }
         | 'type' 'family' type opt_kind_sig
                {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4)
-                                                  OpenTypeFamily $3 (unLoc $4)))
-                       [mj AnnType $1,mj AnnFamily $2] }
+                                                  OpenTypeFamily $3 (snd $ unLoc $4)))
+                       (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) }
 
            -- default type instances, with optional 'instance' keyword
         | 'type' ty_fam_inst_eqn
@@ -955,16 +955,16 @@ at_decl_inst :: { LInstDecl RdrName }
                  gadt_constrlist
                  deriving
                 {% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2
-                                $3 (unLoc $4) (snd $ unLoc $5) (unLoc $6))
-                        ((fst $ unLoc $1):(fst $ unLoc $5)) }
+                                $3 (snd $ unLoc $4) (snd $ unLoc $5) (unLoc $6))
+                        ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
 
 data_or_newtype :: { Located (AddAnn,NewOrData) }
         : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }
         | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }
 
-opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
-        :                             { noLoc Nothing }
-        | '::' kind                   {% ajl (sLL $1 $> (Just $2)) AnnDcolon (gl $1) }
+opt_kind_sig :: { Located ([AddAnn],Maybe (LHsKind RdrName)) }
+        :                             { noLoc ([],Nothing) }
+        | '::' kind                   { sLL $1 $> ([mj AnnDcolon $1],Just ($2)) }
 
 -- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
diff --git a/testsuite/tests/ghc-api/annotations/AnnotationTuple.hs b/testsuite/tests/ghc-api/annotations/AnnotationTuple.hs
index 1eced4d2cb..764c4e515f 100644
--- a/testsuite/tests/ghc-api/annotations/AnnotationTuple.hs
+++ b/testsuite/tests/ghc-api/annotations/AnnotationTuple.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections,TypeFamilies #-}
 module AnnotationTuple (foo) where
 
 {
@@ -13,6 +13,9 @@ foo = let
 bar = print $ map (1, "hello"   , 6.5,, [5, 5, 6, 7]) [Just (), Nothing]
 ;
 baz = (1, "hello", 6.5,,,,) 'a' (Just ())
+;
+
+data family GMap k :: * -> *
 }
 -- Note: the trailing whitespace in this file is used to check that we
 -- have an annotation for it.
diff --git a/testsuite/tests/ghc-api/annotations/exampleTest.stdout b/testsuite/tests/ghc-api/annotations/exampleTest.stdout
index 42da538cc7..7e6c423b75 100644
--- a/testsuite/tests/ghc-api/annotations/exampleTest.stdout
+++ b/testsuite/tests/ghc-api/annotations/exampleTest.stdout
@@ -2,12 +2,12 @@
 [
 (AK AnnotationTuple.hs:13:39 AnnComma = [AnnotationTuple.hs:13:39])
 
-(AK <no location info> AnnEofPos = [AnnotationTuple.hs:21:1])
+(AK <no location info> AnnEofPos = [AnnotationTuple.hs:24:1])
 ]
 
 --------------------------------
 [
-(AK AnnotationTuple.hs:1:1 AnnCloseC = [AnnotationTuple.hs:16:1])
+(AK AnnotationTuple.hs:1:1 AnnCloseC = [AnnotationTuple.hs:19:1])
 
 (AK AnnotationTuple.hs:1:1 AnnModule = [AnnotationTuple.hs:2:1-6])
 
@@ -95,6 +95,8 @@
 
 (AK AnnotationTuple.hs:15:1-41 AnnFunId = [AnnotationTuple.hs:15:1-3])
 
+(AK AnnotationTuple.hs:15:1-41 AnnSemi = [AnnotationTuple.hs:16:1])
+
 (AK AnnotationTuple.hs:15:7-27 AnnCloseP = [AnnotationTuple.hs:15:27])
 
 (AK AnnotationTuple.hs:15:7-27 AnnOpenP = [AnnotationTuple.hs:15:7])
@@ -119,6 +121,14 @@
 
 (AK AnnotationTuple.hs:15:39-40 AnnOpenP = [AnnotationTuple.hs:15:39])
 
-(AK <no location info> AnnEofPos = [AnnotationTuple.hs:21:1])
+(AK AnnotationTuple.hs:18:1-28 AnnData = [AnnotationTuple.hs:18:1-4])
+
+(AK AnnotationTuple.hs:18:1-28 AnnDcolon = [AnnotationTuple.hs:18:20-21])
+
+(AK AnnotationTuple.hs:18:1-28 AnnFamily = [AnnotationTuple.hs:18:6-11])
+
+(AK AnnotationTuple.hs:18:23-28 AnnRarrow = [AnnotationTuple.hs:18:25-26])
+
+(AK <no location info> AnnEofPos = [AnnotationTuple.hs:24:1])
 ]
 
diff --git a/testsuite/tests/ghc-api/annotations/parseTree.stdout b/testsuite/tests/ghc-api/annotations/parseTree.stdout
index 0638608c6b..c36c7b9510 100644
--- a/testsuite/tests/ghc-api/annotations/parseTree.stdout
+++ b/testsuite/tests/ghc-api/annotations/parseTree.stdout
@@ -11,7 +11,7 @@
  (AnnotationTuple.hs:15:25, [m], ()),
  (AnnotationTuple.hs:15:26, [m], ())]
 [
-(AK AnnotationTuple.hs:1:1 AnnCloseC = [AnnotationTuple.hs:16:1])
+(AK AnnotationTuple.hs:1:1 AnnCloseC = [AnnotationTuple.hs:19:1])
 
 (AK AnnotationTuple.hs:1:1 AnnModule = [AnnotationTuple.hs:2:1-6])
 
@@ -99,6 +99,8 @@
 
 (AK AnnotationTuple.hs:15:1-41 AnnFunId = [AnnotationTuple.hs:15:1-3])
 
+(AK AnnotationTuple.hs:15:1-41 AnnSemi = [AnnotationTuple.hs:16:1])
+
 (AK AnnotationTuple.hs:15:7-27 AnnCloseP = [AnnotationTuple.hs:15:27])
 
 (AK AnnotationTuple.hs:15:7-27 AnnOpenP = [AnnotationTuple.hs:15:7])
@@ -123,6 +125,14 @@
 
 (AK AnnotationTuple.hs:15:39-40 AnnOpenP = [AnnotationTuple.hs:15:39])
 
-(AK <no location info> AnnEofPos = [AnnotationTuple.hs:21:1])
+(AK AnnotationTuple.hs:18:1-28 AnnData = [AnnotationTuple.hs:18:1-4])
+
+(AK AnnotationTuple.hs:18:1-28 AnnDcolon = [AnnotationTuple.hs:18:20-21])
+
+(AK AnnotationTuple.hs:18:1-28 AnnFamily = [AnnotationTuple.hs:18:6-11])
+
+(AK AnnotationTuple.hs:18:23-28 AnnRarrow = [AnnotationTuple.hs:18:25-26])
+
+(AK <no location info> AnnEofPos = [AnnotationTuple.hs:24:1])
 ]