TH: Fix pretty printing of newtypes with operators and GADT syntax (#20868)wip/th-gadt-pp

The pretty printer for regular data types already accounted for these,
and had some duplication with the newtype pretty printer.

Factoring the logic out into a common function and using it for both
newtypes and data declarations is enough to fix the bug.

6 files changed, 43 insertions, 29 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 7a6fbb0db9..449a6e5087 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -478,8 +478,15 @@ ppr_overlap o = text $
 
 ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
          -> Doc
-ppr_data maybeInst ctxt t argsDoc ksig cs decs
-  = sep [text "data" <+> maybeInst
+ppr_data = ppr_typedef "data"
+
+ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
+            -> Doc
+ppr_newtype maybeInst ctxt t argsDoc ksig c decs = ppr_typedef "newtype" maybeInst ctxt t argsDoc ksig [c] decs
+
+ppr_typedef :: String -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
+ppr_typedef data_or_newtype maybeInst ctxt t argsDoc ksig cs decs
+  = sep [text data_or_newtype <+> maybeInst
             <+> pprCxt ctxt
             <+> case t of
                  Just n -> pprName' Applied n <+> argsDoc
@@ -511,24 +518,6 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs
                 Nothing -> empty
                 Just k  -> dcolon <+> ppr k
 
-ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
-            -> Doc
-ppr_newtype maybeInst ctxt t argsDoc ksig c decs
-  = sep [text "newtype" <+> maybeInst
-            <+> pprCxt ctxt
-            <+> case t of
-                 Just n -> ppr n <+> argsDoc
-                 Nothing -> argsDoc
-            <+> ksigDoc,
-         nest 2 (char '=' <+> ppr c),
-         if null decs
-           then empty
-           else nest nestDepth
-                $ vcat $ map ppr_deriv_clause decs]
-  where
-    ksigDoc = case ksig of
-                Nothing -> empty
-                Just k  -> dcolon <+> ppr k
 
 ppr_deriv_clause :: DerivClause -> Doc
 ppr_deriv_clause (DerivClause ds ctxt)
diff --git a/testsuite/tests/th/T10828.stderr b/testsuite/tests/th/T10828.stderr
index 455be91914..65bdef500e 100644
--- a/testsuite/tests/th/T10828.stderr
+++ b/testsuite/tests/th/T10828.stderr
@@ -4,8 +4,8 @@ data instance D_0 GHC.Types.Int GHC.Types.Bool :: * where
 data E_3 where MkE_4 :: a_5 -> E_3
 data Foo_6 a_7 b_8 where
     MkFoo_9, MkFoo'_10 :: a_11 -> Foo_6 a_11 b_12
-newtype Bar_13 :: * -> GHC.Types.Bool -> *
-  = MkBar_14 :: a_15 -> Bar_13 a_15 b_16
+newtype Bar_13 :: * -> GHC.Types.Bool -> * where
+    MkBar_14 :: a_15 -> Bar_13 a_15 b_16
 data T10828.T (a_0 :: *) where
     T10828.MkT :: forall (a_1 :: *) . a_1 -> a_1 -> T10828.T a_1
     T10828.MkC :: forall (a_2 :: *) (b_3 :: *) . (GHC.Types.~) a_2
diff --git a/testsuite/tests/th/T14060.stdout b/testsuite/tests/th/T14060.stdout
index abef2b1457..6c9c0635d4 100644
--- a/testsuite/tests/th/T14060.stdout
+++ b/testsuite/tests/th/T14060.stdout
@@ -1,11 +1,11 @@
 newtype Main.Foo1
-  = Main.Foo1 (Data.Proxy.Proxy ('(:) 'GHC.Types.False
-                                      ('(:) 'GHC.Types.True
-                                            ('(:) 'GHC.Types.False ('[] :: [GHC.Types.Bool])))))
+    = Main.Foo1 (Data.Proxy.Proxy ('(:) 'GHC.Types.False
+                                        ('(:) 'GHC.Types.True
+                                              ('(:) 'GHC.Types.False ('[] :: [GHC.Types.Bool])))))
 newtype Main.Foo2 (a_0 :: *)
-  = Main.Foo2 (Data.Proxy.Proxy (Main.Wurble (GHC.Maybe.Maybe a_0)
-                                             ('GHC.Maybe.Nothing :: GHC.Maybe.Maybe a_0)))
+    = Main.Foo2 (Data.Proxy.Proxy (Main.Wurble (GHC.Maybe.Maybe a_0)
+                                               ('GHC.Maybe.Nothing :: GHC.Maybe.Maybe a_0)))
 newtype Main.Foo3
-  = Main.Foo3 (Data.Proxy.Proxy (Main.Foo3Fam2 GHC.Types.Int :: *))
+    = Main.Foo3 (Data.Proxy.Proxy (Main.Foo3Fam2 GHC.Types.Int :: *))
 newtype Main.Foo4
-  = Main.Foo4 (Data.Proxy.Proxy (Main.Foo4Fam2 GHC.Types.Int :: *))
+    = Main.Foo4 (Data.Proxy.Proxy (Main.Foo4Fam2 GHC.Types.Int :: *))
diff --git a/testsuite/tests/th/T20868.hs b/testsuite/tests/th/T20868.hs
new file mode 100644
index 0000000000..4f2d9592ad
--- /dev/null
+++ b/testsuite/tests/th/T20868.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE TemplateHaskell, GADTs #-}
+module Main where
+
+import Language.Haskell.TH
+
+
+main :: IO ()
+main = do
+  x <- [d| newtype MyType where MyCons :: Bool -> MyType
+           newtype MyType1 where MyCons1 :: Show a => a -> Bool -> MyType
+           newtype MyType2 a where MyCons2 :: a -> MyType
+           newtype MyType3 a where MyCons3 :: a -> MyType
+           newtype MyType4 = (:#) Int
+           newtype MyType5 where (:##) :: Int -> MyType
+           |]
+  putStrLn $ pprint x
+
diff --git a/testsuite/tests/th/T20868.stdout b/testsuite/tests/th/T20868.stdout
new file mode 100644
index 0000000000..ac37b7c35f
--- /dev/null
+++ b/testsuite/tests/th/T20868.stdout
@@ -0,0 +1,7 @@
+newtype MyType_0 where MyCons_1 :: GHC.Types.Bool -> MyType_0
+newtype MyType1_2 where
+    MyCons1_3 :: GHC.Show.Show a_4 => a_4 -> GHC.Types.Bool -> MyType_0
+newtype MyType2_5 a_6 where MyCons2_7 :: a_8 -> MyType_0
+newtype MyType3_9 a_10 where MyCons3_11 :: a_12 -> MyType_0
+newtype MyType4_13 = (:#_14) GHC.Types.Int
+newtype MyType5_15 where (:##_16) :: GHC.Types.Int -> MyType_0
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 01a64a3848..97e5700607 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -549,3 +549,4 @@ test('T20842', normal, compile_and_run, [''])
 test('T15433a', [extra_files(['T15433_aux.hs'])], multimod_compile_fail, ['T15433a', '-v0'])
 test('T15433b', [extra_files(['T15433_aux.hs'])], multimod_compile, ['T15433b', '-v0'])
 test('T20711', normal, compile_and_run, [''])
+test('T20868', normal, compile_and_run, [''])