diff options
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Ppr.hs | 29 | ||||
-rw-r--r-- | testsuite/tests/th/T10828.stderr | 4 | ||||
-rw-r--r-- | testsuite/tests/th/T14060.stdout | 14 | ||||
-rw-r--r-- | testsuite/tests/th/T20868.hs | 17 | ||||
-rw-r--r-- | testsuite/tests/th/T20868.stdout | 7 | ||||
-rw-r--r-- | testsuite/tests/th/all.T | 1 |
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, ['']) |