summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Parser.y12
-rw-r--r--testsuite/tests/printer/Makefile6
-rw-r--r--testsuite/tests/printer/Test22765.hs61
-rw-r--r--testsuite/tests/printer/all.T3
-rw-r--r--utils/check-exact/ExactPrint.hs10
-rw-r--r--utils/check-exact/Main.hs3
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
View Lorry Controller Status