EPA: Add annotation for 'type' in DataDeclwip/az/T22765-type-ann-missing

Closes #22765

6 files changed, 84 insertions, 11 deletions

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 2648552bee..16b6519788 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1279,7 +1279,7 @@ ty_decl :: { LTyClDecl GhcPs }
                 {% mkTyData (comb4 $1 $3 $4 $5) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
                            Nothing (reverse (snd $ unLoc $4))
                                    (fmap reverse $5)
-                           ((fstOf3 $ unLoc $1):(fst $ unLoc $4)) }
+                           ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)) }
                                    -- We need the location on tycl_hdr in case
                                    -- constrs and deriving are both empty
 
@@ -1290,7 +1290,7 @@ ty_decl :: { LTyClDecl GhcPs }
             {% mkTyData (comb4 $1 $3 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
                             (snd $ unLoc $4) (snd $ unLoc $5)
                             (fmap reverse $6)
-                            ((fstOf3 $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
+                            ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)++(fst $ unLoc $5)) }
                                    -- We need the location on tycl_hdr in case
                                    -- constrs and deriving are both empty
 
@@ -1514,10 +1514,10 @@ at_decl_inst :: { LInstDecl GhcPs }
                                 (fmap reverse $7)
                         ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) }
 
-type_data_or_newtype :: { Located (AddEpAnn, Bool, NewOrData) }
-        : 'data'        { sL1 $1 (mj AnnData    $1,False,DataType) }
-        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,False,NewType) }
-        | 'type' 'data' { sL1 $1 (mj AnnData    $1,True ,DataType) }
+type_data_or_newtype :: { Located ([AddEpAnn], Bool, NewOrData) }
+        : 'data'        { sL1 $1 ([mj AnnData    $1],            False,DataType) }
+        | 'newtype'     { sL1 $1 ([mj AnnNewtype $1],            False,NewType) }
+        | 'type' 'data' { sL1 $1 ([mj AnnType $1, mj AnnData $2],True ,DataType) }
 
 data_or_newtype :: { Located (AddEpAnn, NewOrData) }
         : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index e98cfc425c..dfe29ea25d 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -775,3 +775,9 @@ HsDocTy:
 	# See comment on pprWithDocString, this won't round trip
 	# $(CHECK_PPR)   $(LIBDIR) HsDocTy.hs
 	$(CHECK_EXACT) $(LIBDIR) HsDocTy.hs
+
+.PHONY: Test22765
+Test22765:
+	$(CHECK_PPR)   $(LIBDIR) Test22765.hs
+	$(CHECK_EXACT) $(LIBDIR) Test22765.hs
+
diff --git a/testsuite/tests/printer/Test22765.hs b/testsuite/tests/printer/Test22765.hs
new file mode 100644
index 0000000000..6d74470900
--- /dev/null
+++ b/testsuite/tests/printer/Test22765.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE TypeData #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MonoLocalBinds #-}
+
+module Test22765 where
+
+import Data.Kind (Type)
+import Data.Type.Equality
+
+-- example from GHC User's Guide 6.4.10.6
+
+type data Ex :: Type where
+  MkEx :: forall a. a -> Ex
+
+type family UnEx (ex :: Ex) :: k
+type instance UnEx (MkEx x) = x
+
+-- -------------------------------------
+
+type data P = MkP
+data Prom = P
+
+-- -------------------------------------
+
+type data Nat = Zero | Succ Nat
+
+-- type level GADT
+type data Vec :: Nat -> Type -> Type where
+    VNil :: Vec Zero a
+    VCons :: a -> Vec n a -> Vec (Succ n) a
+
+type X = VCons Bool (VCons Int VNil)
+
+-- -------------------------------------
+
+type data Foo :: Type -> Type where
+  MkFoo1 :: a ~ Int         => Foo a
+  MkFoo2 :: a ~~ Int        => Foo a
+
+-- -------------------------------------
+
+-- splice should be equivalent to giving the declaration directly
+$( [d| type data Nat = Zero | Succ Nat |] )
+
+data Vec :: Nat -> Type -> Type where
+    VNil :: Vec Zero a
+    VCons :: a -> Vec n a -> Vec (Succ n) a
+
+instance Functor (Vec n) where
+    fmap _ VNil = VNil
+    fmap f (VCons x xs) = VCons (f x) (fmap f xs)
+
+-- -------------------------------------
+
+type data List a = Nil | Cons a (List a)
+
+type data Pair a b = MkPair a b
+
+type data Sum a b = L a | R b
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 050031c6a3..409c9f2b13 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -186,4 +186,5 @@ test('T22488', normal, ghci_script, ['T22488.script'])
 test('T22488_docHead', normal, compile_and_run, ['-package ghc'])
 test('T20531', extra_files(['T20531_defs.hs']), ghci_script, ['T20531.script'])
 test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_red_ticks.script'])
-test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
\ No newline at end of file
+test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
+test('Test22765', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22765'])
\ No newline at end of file
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index df7fdfda1e..0724da1ef9 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -3643,9 +3643,13 @@ exactDataDefn an exactHdr
 
   an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]
 
-  an0 <- markEpAnnL an' lidl $ case condecls of
-    DataTypeCons _ _ -> AnnData
-    NewTypeCon   _ -> AnnNewtype
+  an0 <- case condecls of
+    DataTypeCons is_type_data _ -> do
+      an0' <- if is_type_data
+                then markEpAnnL an' lidl AnnType
+                else return an'
+      markEpAnnL an0' lidl AnnData
+    NewTypeCon   _ -> markEpAnnL an' lidl AnnNewtype
 
   an1 <- markEpAnnL an0 lidl AnnInstance -- optional
   mb_ct' <- mapM markAnnotated mb_ct
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index ab12ac4c09..d9d7feceac 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -203,7 +203,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
  -- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
  -- "../../testsuite/tests/printer/PprArrowLambdaCase.hs" Nothing
  -- "../../testsuite/tests/printer/Test16279.hs" Nothing
- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
+ -- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
+ "../../testsuite/tests/printer/Test22765.hs" Nothing
 
 -- cloneT does not need a test, function can be retired