Change Template Haskell representation of GADTs.

Previous representation of GADTs in TH was not expressive enough
to express possible GADT return types. See #11341

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari

Subscribers: thomie, RyanGlScott

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

GHC Trac Issues: #11341

compiler/deSugar/DsMeta.hs

@@ -1964,21 +1964,20 @@ repConstr (PrefixCon ps) Nothing [con]
     = do arg_tys  <- repList bangTypeQTyConName repBangTy ps
          rep2 normalCName [unC con, unC arg_tys]
 
-repConstr (PrefixCon ps) (Just res_ty) cons
-    = do arg_tys      <- repList bangTypeQTyConName repBangTy ps
-         (res_n, idx) <- repGadtReturnTy res_ty
-         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_n
-                        , unC idx]
+repConstr (PrefixCon ps) (Just (L _ res_ty)) cons
+    = do arg_tys     <- repList bangTypeQTyConName repBangTy ps
+         res_ty' <- repTy res_ty
+         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
 
 repConstr (RecCon (L _ ips)) resTy cons
     = do args     <- concatMapM rep_ip ips
          arg_vtys <- coreList varBangTypeQTyConName args
          case resTy of
            Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
-           Just res_ty -> do
-             (res_n, idx) <- repGadtReturnTy res_ty
+           Just (L _ res_ty) -> do
+             res_ty' <- repTy res_ty
              rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
-                                unC res_n, unC idx]
+                                unC res_ty']
 
     where
       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
@@ -1996,15 +1995,6 @@ repConstr (InfixCon st1 st2) Nothing [con]
 repConstr (InfixCon {}) (Just _) _ = panic "repConstr: infix GADT constructor?"
 repConstr _ _ _                    = panic "repConstr: invariant violated"
 
-repGadtReturnTy :: LHsType Name -> DsM (Core TH.Name, Core [TH.TypeQ])
-repGadtReturnTy res_ty | Just (n, tys) <- hsTyGetAppHead_maybe res_ty
-  = do { n'   <- lookupLOcc n
-       ; tys' <- repList typeQTyConName repLTy tys
-       ; return (n', tys') }
-repGadtReturnTy res_ty
-  = failWithDs (ptext (sLit "Malformed constructor result type:")
-            <+> ppr res_ty)
-
 ------------ Types -------------------
 
 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ

compiler/hsSyn/Convert.hs

@@ -189,10 +189,10 @@ cvtDec (TySynD tc tvs rhs)
                   , tcdRhs = rhs' } }
 
 cvtDec (DataD ctxt tc tvs ksig constrs derivs)
-  = do  { let isGadtCon (GadtC    _ _ _ _) = True
-              isGadtCon (RecGadtC _ _ _ _) = True
-              isGadtCon (ForallC  _ _ c  ) = isGadtCon c
-              isGadtCon _                  = False
+  = do  { let isGadtCon (GadtC    _ _ _) = True
+              isGadtCon (RecGadtC _ _ _) = True
+              isGadtCon (ForallC  _ _ c) = isGadtCon c
+              isGadtCon _                = False
               isGadtDecl  = all isGadtCon constrs
               isH98Decl   = all (not . isGadtCon) constrs
         ; unless (isGadtDecl || isH98Decl)
@@ -480,22 +480,18 @@ cvtConstr (ForallC tvs ctxt con)
                                    unLoc (fromMaybe (noLoc [])
                                           (con_cxt con'))) } }
 
-cvtConstr (GadtC c strtys ty idx)
-  = do  { c'   <- mapM cNameL c
-        ; args <- mapM cvt_arg strtys
-        ; idx' <- mapM cvtType idx
-        ; ty'  <- tconNameL ty
-        ; L _ ret_ty <- mk_apps (HsTyVar ty') idx'
-        ; c_ty       <- mk_arr_apps args ret_ty
+cvtConstr (GadtC c strtys ty)
+  = do  { c'      <- mapM cNameL c
+        ; args    <- mapM cvt_arg strtys
+        ; L _ ty' <- cvtType ty
+        ; c_ty    <- mk_arr_apps args ty'
         ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
 
-cvtConstr (RecGadtC c varstrtys ty idx)
+cvtConstr (RecGadtC c varstrtys ty)
   = do  { c'       <- mapM cNameL c
-        ; ty'      <- tconNameL ty
+        ; ty'      <- cvtType ty
         ; rec_flds <- mapM cvt_id_arg varstrtys
-        ; idx'     <- mapM cvtType idx
-        ; ret_ty   <- mk_apps (HsTyVar ty') idx'
-        ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ret_ty)
+        ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
         ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
 
 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness

compiler/typecheck/TcSplice.hs

@@ -13,6 +13,7 @@ TcSplice: Template Haskell splices
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module TcSplice(
@@ -1338,41 +1339,42 @@ reifyDataCon isGadtDataCon tys dc
              (ex_tvs, theta, arg_tys)
                  = dataConInstSig dc tys
              -- used for GADTs data constructors
-             (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, _)
+             (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, g_res_ty)
                  = dataConFullSig dc
              (srcUnpks, srcStricts)
                  = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
              dcdBangs  = zipWith TH.Bang srcUnpks srcStricts
              fields    = dataConFieldLabels dc
              name      = reifyName dc
-             r_ty_name = reifyName (dataConTyCon dc) -- return type for GADTs
-             -- return type indices
+             -- Universal tvs present in eq_spec need to be filtered out, as
+             -- they will not appear anywhere in the type.
              subst     = mkTopTCvSubst (map eqSpecPair g_eq_spec)
-             idx       = substTyVars subst g_univ_tvs
-             -- universal tvs that were not substituted
              g_unsbst_univ_tvs = filter (`notElemTCvSubst` subst) g_univ_tvs
 
        ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
-       ; idx_tys   <- reifyTypes idx
-
-       ; let main_con | not (null fields) && not isGadtDataCon
-                      = TH.RecC name (zip3 (map reifyFieldLabel fields)
-                                      dcdBangs r_arg_tys)
-                      | not (null fields)
-                      = TH.RecGadtC [name]
-                                   (zip3 (map (reifyName . flSelector) fields)
-                                    dcdBangs r_arg_tys) r_ty_name idx_tys
-                      | dataConIsInfix dc
-                      = ASSERT( length arg_tys == 2 )
-                        TH.InfixC (s1,r_a1) name (s2,r_a2)
-                      | isGadtDataCon
-                      = TH.GadtC [name] (dcdBangs `zip` r_arg_tys) r_ty_name
-                                 idx_tys
-                      | otherwise
-                      = TH.NormalC name (dcdBangs `zip` r_arg_tys)
-             [r_a1, r_a2] = r_arg_tys
+
+       ; let [r_a1, r_a2] = r_arg_tys
              [s1,   s2]   = dcdBangs
-             (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs
+
+       ; main_con <-
+           if | not (null fields) && not isGadtDataCon ->
+                  return $ TH.RecC name (zip3 (map reifyFieldLabel fields)
+                                         dcdBangs r_arg_tys)
+              | not (null fields) -> do
+                  { res_ty <- reifyType g_res_ty
+                  ; return $ TH.RecGadtC [name]
+                                     (zip3 (map (reifyName . flSelector) fields)
+                                      dcdBangs r_arg_tys) res_ty }
+              | dataConIsInfix dc ->
+                  ASSERT( length arg_tys == 2 )
+                  return $ TH.InfixC (s1,r_a1) name (s2,r_a2)
+              | isGadtDataCon -> do
+                  { res_ty <- reifyType g_res_ty
+                  ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }
+              | otherwise ->
+                  return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
+
+       ; let (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs
                                                  , g_theta )
                                | otherwise     = ( ex_tvs, theta )
              ret_con | null ex_tvs' && null theta' = return main_con

libraries/template-haskell/Language/Haskell/TH/Lib.hs

@@ -11,7 +11,7 @@ module Language.Haskell.TH.Lib where
 
 import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)
 import qualified Language.Haskell.TH.Syntax as TH
-import Control.Monad( liftM, liftM2, liftM3 )
+import Control.Monad( liftM, liftM2 )
 import Data.Word( Word8 )
 
 ----------------------------------------------------------
@@ -550,13 +550,11 @@ infixC st1 con st2 = do st1' <- st1
 forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
 forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
 
-gadtC :: [Name] -> [StrictTypeQ] -> Name -> [TypeQ] -> ConQ
-gadtC cons strtys ty idx = liftM3 (GadtC cons) (sequence strtys)
-                                  (return ty)  (sequence idx)
+gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
+gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty
 
-recGadtC :: [Name] -> [VarStrictTypeQ] -> Name -> [TypeQ] -> ConQ
-recGadtC cons varstrtys ty idx = liftM3 (RecGadtC cons) (sequence varstrtys)
-                                        (return ty)     (sequence idx)
+recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ
+recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty
 
 -------------------------------------------------------------------------------
 -- *   Type

libraries/template-haskell/Language/Haskell/TH/Ppr.hs

@@ -361,10 +361,10 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs
 
     isGadtDecl :: Bool
     isGadtDecl = not (null cs) && all isGadtCon cs
-        where isGadtCon (GadtC _ _ _ _   ) = True
-              isGadtCon (RecGadtC _ _ _ _) = True
-              isGadtCon (ForallC _ _ x   ) = isGadtCon x
-              isGadtCon  _                 = False
+        where isGadtCon (GadtC _ _ _   ) = True
+              isGadtCon (RecGadtC _ _ _) = True
+              isGadtCon (ForallC _ _ x ) = isGadtCon x
+              isGadtCon  _               = False
 
     ksigDoc = case ksig of
                 Nothing -> empty
@@ -506,38 +506,38 @@ instance Ppr Con where
                          <+> pprName' Infix c
                          <+> pprBangType st2
 
-    ppr (ForallC ns ctxt (GadtC c sts ty idx))
-        = commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty idx
+    ppr (ForallC ns ctxt (GadtC c sts ty))
+        = commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty
 
-    ppr (ForallC ns ctxt (RecGadtC c vsts ty idx))
+    ppr (ForallC ns ctxt (RecGadtC c vsts ty))
         = commaSep c <+> dcolon <+> pprForall ns ctxt
-      <+> pprRecFields vsts ty idx
+      <+> pprRecFields vsts ty
 
     ppr (ForallC ns ctxt con)
         = pprForall ns ctxt <+> ppr con
 
-    ppr (GadtC c sts ty idx)
-        = commaSep c <+> dcolon <+> pprGadtRHS sts ty idx
+    ppr (GadtC c sts ty)
+        = commaSep c <+> dcolon <+> pprGadtRHS sts ty
 
-    ppr (RecGadtC c vsts ty idx)
-        = commaSep c <+> dcolon <+> pprRecFields vsts ty idx
+    ppr (RecGadtC c vsts ty)
+        = commaSep c <+> dcolon <+> pprRecFields vsts ty
 
 pprForall :: [TyVarBndr] -> Cxt -> Doc
 pprForall ns ctxt
     = text "forall" <+> hsep (map ppr ns)
   <+> char '.' <+> pprCxt ctxt
 
-pprRecFields :: [(Name, Strict, Type)] -> Name -> [Type] -> Doc
-pprRecFields vsts ty idx
+pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
+pprRecFields vsts ty
     = braces (sep (punctuate comma $ map pprVarBangType vsts))
-  <+> arrow <+> ppr ty <+> sep (map ppr idx)
+  <+> arrow <+> ppr ty
 
-pprGadtRHS :: [(Strict, Type)] -> Name -> [Type] -> Doc
-pprGadtRHS [] ty idx
-    = ppr ty <+> sep (map ppr idx)
-pprGadtRHS sts ty idx
+pprGadtRHS :: [(Strict, Type)] -> Type -> Doc
+pprGadtRHS [] ty
+    = ppr ty
+pprGadtRHS sts ty
     = sep (punctuate (space <> arrow) (map pprBangType sts))
-  <+> arrow <+> ppr ty <+> sep (map ppr idx)
+  <+> arrow <+> ppr ty
 
 ------------------------------
 pprVarBangType :: VarBangType -> Doc
@@ -615,6 +615,9 @@ pprParendType WildCardT           = char '_'
 pprParendType (InfixT x n y)      = parens (ppr x <+> pprName' Infix n <+> ppr y)
 pprParendType t@(UInfixT {})      = parens (pprUInfixT t)
 pprParendType (ParensT t)         = ppr t
+pprParendType tuple | (TupleT n, args) <- split tuple
+                    , length args == n
+                    = parens (commaSep args)
 pprParendType other               = parens (ppr other)
 
 pprUInfixT :: Type -> Doc

libraries/template-haskell/Language/Haskell/TH/Syntax.hs

@@ -1632,25 +1632,40 @@ data Con = NormalC Name [BangType]       -- ^ @C Int a@
          | InfixC BangType Name BangType -- ^ @Int :+ a@
          | ForallC [TyVarBndr] Cxt Con   -- ^ @forall a. Eq a => C [a]@
          | GadtC [Name] [BangType]
-                 Name                    -- See Note [GADT return type]
-                 [Type]                  -- Indices of the type constructor
+                 Type                    -- See Note [GADT return type]
                                          -- ^ @C :: a -> b -> T b Int@
          | RecGadtC [Name] [VarBangType]
-                    Name                 -- See Note [GADT return type]
-                    [Type]               -- Indices of the type constructor
+                    Type                 -- See Note [GADT return type]
                                          -- ^ @C :: { v :: Int } -> T b Int@
         deriving (Show, Eq, Ord, Data, Typeable, Generic)
 
 -- Note [GADT return type]
 -- ~~~~~~~~~~~~~~~~~~~~~~~
 --
--- The name of the return type stored by a GADT constructor does not necessarily
--- match the name of the data type:
+-- The return type of a GADT constructor does not necessarily match the name of
+-- the data type:
 --
 -- type S = T
 --
 -- data T a where
 --     MkT :: S Int
+--
+--
+-- type S a = T
+--
+-- data T a where
+--     MkT :: S Char Int
+--
+--
+-- type Id a = a
+-- type S a = T
+--
+-- data T a where
+--     MkT :: Id (S Char Int)
+--
+--
+-- That is why we allow the return type stored by a constructor to be an
+-- arbitrary type. See also #11341
 
 data Bang = Bang SourceUnpackedness SourceStrictness
          -- ^ @C { {\-\# UNPACK \#-\} !}a@

testsuite/tests/th/T10828.hs

@@ -40,8 +40,8 @@ $( return
                      , VarT (mkName "a")
                      )
                    ]
-                   ( mkName "T" )
-                   [ VarT (mkName "a") ]
+                   (AppT (ConT (mkName "T"))
+                         (VarT (mkName "a")))
            , ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")]
                      [AppT (AppT EqualityT (VarT $ mkName "a"  ) )
                                            (ConT $ mkName "Int") ] $
@@ -55,8 +55,8 @@ $( return
                     , VarT (mkName "b")
                     )
                   ]
-                  ( mkName "T" )
-                  [ ConT (mkName "Int") ] ]
+                  (AppT (ConT (mkName "T"))
+                        (ConT (mkName "Int"))) ]
            [] ])
 
 $( do { -- test reification

testsuite/tests/th/T10828.stderr

@@ -15,86 +15,3 @@ data T'_0 a_1 :: * where
     MkT'_2 :: forall a_3 . a_3 -> a_3 -> T'_0 a_3
     MkC'_4 :: forall a_5 b_6 . a_5 ~ GHC.Types.Int => {foo_7 :: a_5,
                                                        bar_8 :: b_6} -> T'_0 GHC.Types.Int
-TYPE SIGNATURES
-TYPE CONSTRUCTORS
-  type role Bar representational phantom
-  newtype Bar a (b :: Bool) where
-    MkBar :: a -> Bar a b
-    Kind: GHC.Types.Type -> Bool -> GHC.Types.Type
-  data family D a0 b
-  data E where
-    MkE :: a0 -> E
-    Kind: *
-  type role Foo representational phantom
-  data Foo a0 b0 where
-    MkFoo :: a0 -> Foo a0 b0
-    MkFoo' :: a0 -> Foo a0 b0
-    Kind: * -> * -> *
-  type role T nominal
-  data T a where
-    MkT :: a -> a -> T a
-    MkC :: a1 ~ Int => {foo :: a1, bar :: b} -> T Int
-    Kind: * -> GHC.Types.Type
-COERCION AXIOMS
-  axiom T10828.NTCo:Bar :: Bar a b = a -- Defined at T10828.hs:9:4
-  axiom T10828.TFCo:R:DIntBool ::
-    D Int Bool = T10828.R:DIntBool -- Defined at T10828.hs:9:4
-FAMILY INSTANCES
-  data instance D Int Bool
-Dependent modules: []
-Dependent packages: [array-<VERSION>, base-<VERSION>, binary-<VERSION>,
-                     bytestring-<VERSION>, containers-<VERSION>, deepseq-<VERSION>,
-                     ghc-boot-<VERSION>, ghc-prim-<VERSION>, integer-<IMPL>-<VERSION>,
-                     pretty-<VERSION>, template-haskell-<VERSION>]
-
-==================== Typechecker ====================
-foo = ()
-bar = ()
-T10828.$tcT
-  = GHC.Types.TyCon 0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "T"#)
-T10828.$tc'MkT
-  = GHC.Types.TyCon
-      0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "'MkT"#)
-T10828.$tc'MkC
-  = GHC.Types.TyCon
-      0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "'MkC"#)
-T10828.$tc'DInt
-  = GHC.Types.TyCon
-      0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "'DInt"#)
-T10828.$tcBar
-  = GHC.Types.TyCon
-      0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "Bar"#)
-T10828.$tc'MkBar
-  = GHC.Types.TyCon
-      0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "'MkBar"#)
-T10828.$tcFoo
-  = GHC.Types.TyCon
-      0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "Foo"#)
-T10828.$tc'MkFoo
-  = GHC.Types.TyCon
-      0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "'MkFoo"#)
-T10828.$tc'MkFoo'
-  = GHC.Types.TyCon
-      0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "'MkFoo'"#)
-T10828.$tcE
-  = GHC.Types.TyCon 0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "E"#)
-T10828.$tc'MkE
-  = GHC.Types.TyCon
-      0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "'MkE"#)
-T10828.$tcD
-  = GHC.Types.TyCon 0## 0## T10828.$trModule
-      (GHC.Types.TrNameS "D"#)
-T10828.$trModule
-  = GHC.Types.Module
-      (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "T10828"#)

testsuite/tests/th/T10828b.hs

@@ -33,7 +33,7 @@ $( return
                    , VarT (mkName "b")
                    )
                  ]
-                 ( mkName "T" )
-                 [ ConT (mkName "Int") ]
+                 (AppT (ConT (mkName "T"))
+                       (ConT (mkName "Int")))
            ]
            [] ])

testsuite/tests/th/T11341.hs

+{-# LANGUAGE GADTs, TemplateHaskell #-}
+module T11341 where
+
+import Language.Haskell.TH
+import System.IO
+
+type S1 = T1
+data T1 a where
+  MkT1 :: S1 Int
+
+type S2 a = T2
+data T2 a where
+  MkT2 :: S2 Char Int
+
+type Id a = a
+type S3 a = T3
+data T3 a where
+      MkT3 :: Id (S3 Char Int)
+
+$( do  -- test reification
+  { TyConI dec <- runQ $ reify (mkName "T1")
+  ; runIO $ putStrLn (pprint dec) >> hFlush stdout
+
+  ; TyConI dec <- runQ $ reify (mkName "T2")
+  ; runIO $ putStrLn (pprint dec) >> hFlush stdout
+
+  ; TyConI dec <- runQ $ reify (mkName "T3")
+  ; runIO $ putStrLn (pprint dec) >> hFlush stdout
+
+  ; return [] } )

testsuite/tests/th/T11341.stderr

+data T11341.T1 (a_0 :: *) where
+    T11341.MkT1 :: T11341.S1 GHC.Types.Int
+data T11341.T2 (a_0 :: *) where
+    T11341.MkT2 :: T11341.S2 GHC.Types.Char GHC.Types.Int
+data T11341.T3 (a_0 :: *) where
+    T11341.MkT3 :: T11341.Id (T11341.S3 GHC.Types.Char GHC.Types.Int)

testsuite/tests/th/T4188.hs

-{-# LANGUAGE TemplateHaskell, GADTs #-}
-
-module T4188 where
-
-import Language.Haskell.TH
-import System.IO
-
-class C a where {}
-
-data T1 a where
-  MkT1 :: a -> b -> T1 a
-
-data T2 a where
-  MkT2 :: (C a, C b) => a -> b -> T2 a
-
-data T3 x where
-  MkT3 :: (C x, C y) => x -> y -> T3 (x,y)
-
-$(do { dec1 <- reify ''T1
-     ; runIO (putStrLn (pprint dec1))
-     ; dec2 <- reify ''T2
-     ; runIO (putStrLn (pprint dec2))
-     ; dec3 <- reify ''T3
-     ; runIO (putStrLn (pprint dec3))
-     ; runIO (hFlush stdout)
-     ; return [] })
-
-   
+{-# LANGUAGE TemplateHaskell, GADTs #-}
+
+module T4188 where
+
+import Language.Haskell.TH
+import System.IO
+
+class C a where {}
+
+data T1 a where
+  MkT1 :: a -> b -> T1 a
+
+data T2 a where
+  MkT2 :: (C a, C b) => a -> b -> T2 a
+
+data T3 x where
+  MkT3 :: (C x, C y) => x -> y -> T3 (x,y)
+
+$(do { dec1 <- reify ''T1
+     ; runIO (putStrLn (pprint dec1))
+     ; dec2 <- reify ''T2
+     ; runIO (putStrLn (pprint dec2))
+     ; dec3 <- reify ''T3
+     ; runIO (putStrLn (pprint dec3))
+     ; runIO (hFlush stdout)
+     ; return [] })

testsuite/tests/th/TH_RichKinds2.stderr

@@ -3,7 +3,7 @@ TH_RichKinds2.hs:24:4: Warning:
     data SMaybe_0 :: (k_0 -> *) -> GHC.Base.Maybe k_0 -> * where
     SNothing_2 :: forall s_3 . SMaybe_0 s_3 'GHC.Base.Nothing
     SJust_4 :: forall s_5 a_6 . (s_5 a_6) -> SMaybe_0 s_5
-                                                      'GHC.Base.Just a_6
+                                                      ('GHC.Base.Just a_6)
 type instance TH_RichKinds2.Map f_7 '[] = '[]
 type instance TH_RichKinds2.Map f_8
                                 ('GHC.Types.: h_9 t_10) = 'GHC.Types.: (f_8 h_9)

testsuite/tests/th/all.T

@@ -381,11 +381,7 @@ test('T10796a', normal, compile, ['-v0'])
 test('T10796b', normal, compile_fail, ['-v0'])
 test('T10811', normal, compile, ['-v0'])
 test('T10810', normal, compile, ['-v0'])
-test('T10828', normalise_version('array', 'base', 'binary', 'bytestring',
-                                 'containers', 'deepseq', 'ghc-boot',
-                                 'ghc-prim', 'integer-gmp', 'pretty',
-                                 'template-haskell'
-                              ), compile, ['-v0 -ddump-tc -dsuppress-uniques'])
+test('T10828', normal, compile, ['-v0 -dsuppress-uniques'])
 test('T10828a', normal, compile_fail, ['-v0'])
 test('T10828b', normal, compile_fail, ['-v0'])
 test('T10891', normal, compile, ['-v0'])
@@ -397,5 +393,6 @@ test('T10819',
      multimod_compile,
      ['T10819.hs', '-v0 ' + config.ghc_th_way_flags])
 test('T10820', normal, compile_and_run, ['-v0'])
+test('T11341', normal, compile, ['-v0 -dsuppress-uniques'])
 
 test('TH_finalizer', normal, compile, ['-v0'])