Clean up TH's treatment of unary tuples (or, #16881 part two)wip/T17380

!1906 left some loose ends in regards to Template Haskell's treatment
of unary tuples. This patch ends to tie up those loose ends:

* In addition to having `TupleT 1` produce unary tuples, `TupE [exp]`
  and `TupP [pat]` also now produce unary tuples.
* I have added various special cases in GHC's pretty-printers to
  ensure that explicit 1-tuples are printed using the `Unit` type.
  See `testsuite/tests/th/T17380`.
* The GHC 8.10.1 release notes entry has been tidied up a little.

Fixes #16881. Fixes #17371. Fixes #17380.

20 files changed, 210 insertions, 76 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 7a9caa8c6e..847ecd1743 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -13,6 +13,7 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | Abstract Haskell syntax for expressions.
 module GHC.Hs.Expr where
@@ -43,6 +44,7 @@ import Util
 import Outputable
 import FastString
 import Type
+import TysWiredIn (mkTupleStr)
 import TcType (TcType)
 import {-# SOURCE #-} TcRnTypes (TcLclEnv)
 
@@ -908,6 +910,12 @@ ppr_expr (SectionR _ op expr)
     pp_infixly v = sep [v, pp_expr]
 
 ppr_expr (ExplicitTuple _ exprs boxity)
+    -- Special-case unary boxed tuples so that they are pretty-printed as
+    -- `Unit x`, not `(x)`
+  | [dL -> L _ (Present _ expr)] <- exprs
+  , Boxed <- boxity
+  = hsep [text (mkTupleStr Boxed 1), ppr expr]
+  | otherwise
   = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
   where
     ppr_tup_args []               = []
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 0fa6dca7b8..cae7144a8c 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -529,8 +529,14 @@ pprPat (CoPat _ co pat _)       = pprHsWrapper co $ \parens
                                                  else pprPat pat
 pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr ty
 pprPat (ListPat _ pats)         = brackets (interpp'SP pats)
-pprPat (TuplePat _ pats bx)     = tupleParens (boxityTupleSort bx)
-                                              (pprWithCommas ppr pats)
+pprPat (TuplePat _ pats bx)
+    -- Special-case unary boxed tuples so that they are pretty-printed as
+    -- `Unit x`, not `(x)`
+  | [pat] <- pats
+  , Boxed <- bx
+  = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat]
+  | otherwise
+  = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
 pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
 pprPat (ConPatIn con details)   = pprUserCon (unLoc con) details
 pprPat (ConPatOut { pat_con = con
diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs
index cd5e59745b..fcf22584cb 100644
--- a/compiler/GHC/Hs/Types.hs
+++ b/compiler/GHC/Hs/Types.hs
@@ -85,6 +85,7 @@ import RdrName ( RdrName )
 import DataCon( HsSrcBang(..), HsImplBang(..),
                 SrcStrictness(..), SrcUnpackedness(..) )
 import TysPrim( funTyConName )
+import TysWiredIn( mkTupleStr )
 import Type
 import GHC.Hs.Doc
 import BasicTypes
@@ -1600,7 +1601,14 @@ ppr_mono_ty (HsTyVar _ prom (L _ name))
   | isPromoted prom = quote (pprPrefixOcc name)
   | otherwise       = pprPrefixOcc name
 ppr_mono_ty (HsFunTy _ ty1 ty2)   = ppr_fun_ty ty1 ty2
-ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys)
+ppr_mono_ty (HsTupleTy _ con tys)
+    -- Special-case unary boxed tuples so that they are pretty-printed as
+    -- `Unit x`, not `(x)`
+  | [ty] <- tys
+  , BoxedTuple <- std_con
+  = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]
+  | otherwise
+  = tupleParens std_con (pprWithCommas ppr tys)
   where std_con = case con of
                     HsUnboxedTuple -> UnboxedTuple
                     _              -> BoxedTuple
@@ -1615,6 +1623,11 @@ ppr_mono_ty (HsExplicitListTy _ prom tys)
   | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)
   | otherwise       = brackets (interpp'SP tys)
 ppr_mono_ty (HsExplicitTupleTy _ tys)
+    -- Special-case unary boxed tuples so that they are pretty-printed as
+    -- `'Unit x`, not `'(x)`
+  | [ty] <- tys
+  = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]
+  | otherwise
   = quote $ parens (maybeAddSpace tys $ interpp'SP tys)
 ppr_mono_ty (HsTyLit _ t)       = ppr_tylit t
 ppr_mono_ty (HsWildCardTy {})   = char '_'
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 7df5aee397..7d913ff4bf 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -908,9 +908,6 @@ cvtl e = wrapL (cvt e)
                             ; return $ HsLamCase noExtField
                                                    (mkMatchGroup FromSource ms')
                             }
-    cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExtField e' }
-                                 -- Note [Dropping constructors]
-                                 -- Singleton tuples treated like nothing (just parens)
     cvt (TupE es)        = cvt_tup es Boxed
     cvt (UnboxedTupE es) = cvt_tup es Unboxed
     cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
@@ -1018,14 +1015,13 @@ ensureValidOpExp _e _m =
 
 {- Note [Dropping constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
-we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
-could meet @UInfix@ constructors containing the @TupE [e]@. For example:
+When we drop constructors from the input, we must insert parentheses around the
+argument. For example:
 
-  UInfixE x * (TupE [UInfixE y + z])
+  UInfixE x * (AppE (InfixE (Just y) + Nothing) z)
 
-If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
-and the above expression would be reassociated to
+If we convert the InfixE expression to an operator section but don't insert
+parentheses, the above expression would be reassociated to
 
   OpApp (OpApp x * y) + z
 
@@ -1254,8 +1250,6 @@ cvtp (TH.LitP l)
   | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' }
 cvtp (TH.VarP s)       = do { s' <- vName s
                             ; return $ Hs.VarPat noExtField (noLoc s') }
-cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat noExtField p' }
-                                         -- Note [Dropping constructors]
 cvtp (TupP ps)         = do { ps' <- cvtPats ps
                             ; return $ TuplePat noExtField ps' Boxed }
 cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 2ca9319b34..09e7c1a3a8 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -62,7 +62,7 @@ module IfaceType (
 import GhcPrelude
 
 import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon
-                                 , liftedRepDataConTyCon )
+                                 , liftedRepDataConTyCon, tupleTyConName )
 import {-# SOURCE #-} TyCoRep    ( isRuntimeRepTy )
 
 import DynFlags
@@ -1466,30 +1466,47 @@ pprSum _arity is_promoted args
        <> sumParens (pprWithBars (ppr_ty topPrec) args')
 
 pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc
-pprTuple ctxt_prec ConstraintTuple NotPromoted IA_Nil
-  = maybeParen ctxt_prec sigPrec $
-    text "() :: Constraint"
+pprTuple ctxt_prec sort promoted args =
+  case promoted of
+    IsPromoted
+      -> let tys = appArgsIfaceTypes args
+             args' = drop (length tys `div` 2) tys
+             spaceIfPromoted = case args' of
+               arg0:_ -> pprSpaceIfPromotedTyCon arg0
+               _ -> id
+         in ppr_tuple_app args' $
+            pprPromotionQuoteI IsPromoted <>
+            tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args'))
+
+    NotPromoted
+      |  ConstraintTuple <- sort
+      ,  IA_Nil <- args
+      -> maybeParen ctxt_prec sigPrec $
+         text "() :: Constraint"
 
--- All promoted constructors have kind arguments
-pprTuple _ sort IsPromoted args
-  = let tys = appArgsIfaceTypes args
-        args' = drop (length tys `div` 2) tys
-        spaceIfPromoted = case args' of
-          arg0:_ -> pprSpaceIfPromotedTyCon arg0
-          _ -> id
-    in pprPromotionQuoteI IsPromoted <>
-       tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args'))
-
-pprTuple _ sort promoted args
-  =   -- drop the RuntimeRep vars.
-      -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-    let tys   = appArgsIfaceTypes args
-        args' = case sort of
-                  UnboxedTuple -> drop (length tys `div` 2) tys
-                  _            -> tys
-    in
-    pprPromotionQuoteI promoted <>
-    tupleParens sort (pprWithCommas pprIfaceType args')
+      | otherwise
+      ->   -- drop the RuntimeRep vars.
+           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+         let tys   = appArgsIfaceTypes args
+             args' = case sort of
+                       UnboxedTuple -> drop (length tys `div` 2) tys
+                       _            -> tys
+         in
+         ppr_tuple_app args' $
+         pprPromotionQuoteI promoted <>
+         tupleParens sort (pprWithCommas pprIfaceType args')
+  where
+    ppr_tuple_app :: [IfaceType] -> SDoc -> SDoc
+    ppr_tuple_app args_wo_runtime_reps ppr_args_w_parens
+        -- Special-case unary boxed tuples so that they are pretty-printed as
+        -- `Unit x`, not `(x)`
+      | [_] <- args_wo_runtime_reps
+      , BoxedTuple <- sort
+      = let unit_tc_info = IfaceTyConInfo promoted IfaceNormalTyCon
+            unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in
+        pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args
+      | otherwise
+      = ppr_args_w_parens
 
 pprIfaceTyLit :: IfaceTyLit -> SDoc
 pprIfaceTyLit (IfaceNumTyLit n) = integer n
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index e42009fa61..74556b5323 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -68,7 +68,7 @@ module TysWiredIn (
         justDataCon, justDataConName, promotedJustDataCon,
 
         -- * Tuples
-        mkTupleTy, mkTupleTy1, mkBoxedTupleTy,
+        mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,
         tupleTyCon, tupleDataCon, tupleTyConName,
         promotedTupleDataCon,
         unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,
@@ -783,6 +783,10 @@ mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar)
 mkCTupleOcc :: NameSpace -> Arity -> OccName
 mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)
 
+mkTupleStr :: Boxity -> Arity -> String
+mkTupleStr Boxed   = mkBoxedTupleStr
+mkTupleStr Unboxed = mkUnboxedTupleStr
+
 mkBoxedTupleStr :: Arity -> String
 mkBoxedTupleStr 0  = "()"
 mkBoxedTupleStr 1  = "Unit"   -- See Note [One-tuples]
diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot
index 0a09be172f..023682fe5b 100644
--- a/compiler/prelude/TysWiredIn.hs-boot
+++ b/compiler/prelude/TysWiredIn.hs-boot
@@ -3,6 +3,9 @@ module TysWiredIn where
 import {-# SOURCE #-} TyCon      ( TyCon )
 import {-# SOURCE #-} TyCoRep    (Type, Kind)
 
+import BasicTypes (Arity, TupleSort)
+import Name (Name)
+
 listTyCon :: TyCon
 typeNatKind, typeSymbolKind :: Type
 mkBoxedTupleTy :: [Type] -> Type
@@ -38,3 +41,5 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
 anyTypeOfKind :: Kind -> Type
 unboxedTupleKind :: [Type] -> Type
 mkPromotedListTy :: Type -> [Type] -> Type
+
+tupleTyConName :: TupleSort -> Arity -> Name
diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst
index b405520c70..5e7356ab2c 100644
--- a/docs/users_guide/8.10.1-notes.rst
+++ b/docs/users_guide/8.10.1-notes.rst
@@ -219,9 +219,12 @@ Template Haskell
   :extension:`DeriveLift` has been simplified to take advantage of expression
   quotations.
 
-- Explicit boxed 1-tuples from ``HsSyn`` are now treated as actual 1-tuples,
-  without flattening. In most of the cases these will be obtained using
-  Template Haskell since it is uncommon to deal with 1-tuples in the source.
+- Using ``TupleT 1``, ``TupE [exp]``, or ``TupP [pat]`` will now produce unary
+  tuples (i.e., involving the ``Unit`` type from ``GHC.Tuple``) instead of
+  silently dropping the parentheses. This brings Template Haskell's treatment
+  of boxed tuples in line with that of unboxed tuples, as ``UnboxedTupleT`,
+  ``UnboxedTupE``, and ``UnboxedTupP`` also produce unary unboxed tuples
+  (i.e., ``Unit#``) when applied to only one argument.
 
 - GHC's constraint solver now solves constraints in each top-level group
   sooner. This has practical consequences for Template Haskell, as TH splices
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 98ddd1c2ca..461f213813 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -153,7 +153,11 @@ pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat ap
                                            <+> text "->" <+> ppr e
 pprExp i (LamCaseE ms) = parensIf (i > noPrec)
                        $ text "\\case" $$ nest nestDepth (ppr ms)
-pprExp _ (TupE es) = parens (commaSepWith (pprMaybeExp noPrec) es)
+pprExp i (TupE es)
+  | [Just e] <- es
+  = pprExp i (ConE (tupleDataName 1) `AppE` e)
+  | otherwise
+  = parens (commaSepWith (pprMaybeExp noPrec) es)
 pprExp _ (UnboxedTupE es) = hashParens (commaSepWith (pprMaybeExp noPrec) es)
 pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity
 -- Nesting in Cond is to avoid potential problems in do statements
@@ -291,7 +295,11 @@ instance Ppr Pat where
 pprPat :: Precedence -> Pat -> Doc
 pprPat i (LitP l)     = pprLit i l
 pprPat _ (VarP v)     = pprName' Applied v
-pprPat _ (TupP ps)    = parens (commaSep ps)
+pprPat i (TupP ps)
+  | [_] <- ps
+  = pprPat i (ConP (tupleDataName 1) ps)
+  | otherwise
+  = parens (commaSep ps)
 pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)
 pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity
 pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s
@@ -742,6 +750,7 @@ pprParendType (VarT v)            = pprName' Applied v
 -- `Applied` is used here instead of `ppr` because of infix names (#13887)
 pprParendType (ConT c)            = pprName' Applied c
 pprParendType (TupleT 0)          = text "()"
+pprParendType (TupleT 1)          = pprParendType (ConT (tupleTypeName 1))
 pprParendType (TupleT n)          = parens (hcat (replicate (n-1) comma))
 pprParendType (UnboxedTupleT n)   = hashParens $ hcat $ replicate (n-1) comma
 pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
@@ -750,6 +759,7 @@ pprParendType ListT               = text "[]"
 pprParendType (LitT l)            = pprTyLit l
 pprParendType (PromotedT c)       = text "'" <> pprName' Applied c
 pprParendType (PromotedTupleT 0)  = text "'()"
+pprParendType (PromotedTupleT 1)  = pprParendType (PromotedT (tupleDataName 1))
 pprParendType (PromotedTupleT n)  = quoteParens (hcat (replicate (n-1) comma))
 pprParendType PromotedNilT        = text "'[]"
 pprParendType PromotedConsT       = text "'(:)"
@@ -801,9 +811,15 @@ pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) =
     sep [pprFunArgType arg1 <+> text "~", ppr arg2]
 pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg)
 pprTyApp (TupleT n, args)
- | length args == n = parens (commaSep args)
+ | length args == n
+ = if n == 1
+   then pprTyApp (ConT (tupleTypeName 1), args)
+   else parens (commaSep args)
 pprTyApp (PromotedTupleT n, args)
- | length args == n = quoteParens (commaSep args)
+ | length args == n
+ = if n == 1
+   then pprTyApp (PromotedT (tupleDataName 1), args)
+   else quoteParens (commaSep args)
 pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args)
 
 pprFunArgType :: Type -> Doc    -- Should really use a precedence argument
diff --git a/testsuite/tests/ghc-api/annotations/parseTree.stdout b/testsuite/tests/ghc-api/annotations/parseTree.stdout
index 092ba971d2..e216ba96fa 100644
--- a/testsuite/tests/ghc-api/annotations/parseTree.stdout
+++ b/testsuite/tests/ghc-api/annotations/parseTree.stdout
@@ -1,11 +1,11 @@
-[(AnnotationTuple.hs:14:20, [p], (1)),
- (AnnotationTuple.hs:14:23-29, [p], ("hello")),
- (AnnotationTuple.hs:14:35-37, [p], (6.5)),
+[(AnnotationTuple.hs:14:20, [p], Unit 1),
+ (AnnotationTuple.hs:14:23-29, [p], Unit "hello"),
+ (AnnotationTuple.hs:14:35-37, [p], Unit 6.5),
  (AnnotationTuple.hs:14:39, [m], ()),
- (AnnotationTuple.hs:14:41-52, [p], ([5, 5, 6, 7])),
- (AnnotationTuple.hs:16:8, [p], (1)),
- (AnnotationTuple.hs:16:11-17, [p], ("hello")),
- (AnnotationTuple.hs:16:20-22, [p], (6.5)),
+ (AnnotationTuple.hs:14:41-52, [p], Unit [5, 5, 6, 7]),
+ (AnnotationTuple.hs:16:8, [p], Unit 1),
+ (AnnotationTuple.hs:16:11-17, [p], Unit "hello"),
+ (AnnotationTuple.hs:16:20-22, [p], Unit 6.5),
  (AnnotationTuple.hs:16:24, [m], ()),
  (AnnotationTuple.hs:16:25, [m], ()),
  (AnnotationTuple.hs:16:26, [m], ()), (<no location info>, [m], ())]
diff --git a/testsuite/tests/th/T16881.hs b/testsuite/tests/th/T16881.hs
new file mode 100644
index 0000000000..eed4f2670d
--- /dev/null
+++ b/testsuite/tests/th/T16881.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH
+
+foo :: String -> $(tupleT 1 `appT` conT ''String)
+foo x = $(tupE [[| x |]])
+
+bar :: $(tupleT 1 `appT` conT ''String) -> String
+bar $(tupP [[p| x |]]) = x
+
+main :: IO ()
+main = do
+  foo undefined `seq` putStrLn "hello"
+  putStrLn $ bar $ foo "world"
diff --git a/testsuite/tests/th/T16881.stdout b/testsuite/tests/th/T16881.stdout
new file mode 100644
index 0000000000..94954abda4
--- /dev/null
+++ b/testsuite/tests/th/T16881.stdout
@@ -0,0 +1,2 @@
+hello
+world
diff --git a/testsuite/tests/th/T17380.hs b/testsuite/tests/th/T17380.hs
new file mode 100644
index 0000000000..c0908532a1
--- /dev/null
+++ b/testsuite/tests/th/T17380.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T17380 where
+
+import Data.Proxy
+import Language.Haskell.TH
+
+foo :: $(tupleT 1 `appT` (conT ''Maybe `appT` conT ''String))
+foo = Just "wat"
+
+bar :: Maybe String
+bar = $(tupE [[| Just "wat" |]])
+
+baz :: $(tupleT 1 `appT` (conT ''Maybe `appT` conT ''String)) -> Maybe String
+baz (Just "wat") = Just "frerf"
+
+quux :: Maybe String -> Maybe String
+quux $(tupP [[p| Just "wat" |]]) = Just "frerf"
+
+quuz :: Proxy $(promotedTupleT 1 `appT` (conT ''Maybe `appT` conT ''String))
+quuz = Proxy :: Proxy (Maybe String)
+
+fred :: Proxy (Maybe String)
+fred = Proxy :: Proxy $(promotedTupleT 1 `appT` (conT ''Maybe `appT` conT ''String))
diff --git a/testsuite/tests/th/T17380.stderr b/testsuite/tests/th/T17380.stderr
new file mode 100644
index 0000000000..7e1977b6e4
--- /dev/null
+++ b/testsuite/tests/th/T17380.stderr
@@ -0,0 +1,39 @@
+
+T17380.hs:9:7: error:
+    • Couldn't match expected type ‘Unit (Maybe String)’
+                  with actual type ‘Maybe [Char]’
+    • In the expression: Just "wat"
+      In an equation for ‘foo’: foo = Just "wat"
+
+T17380.hs:12:9: error:
+    • Couldn't match expected type ‘Maybe String’
+                  with actual type ‘Unit (Maybe [Char])’
+    • In the expression: (Unit Just "wat")
+      In an equation for ‘bar’: bar = (Unit Just "wat")
+
+T17380.hs:15:6: error:
+    • Couldn't match expected type ‘Unit (Maybe String)’
+                  with actual type ‘Maybe [Char]’
+    • In the pattern: Just "wat"
+      In an equation for ‘baz’: baz (Just "wat") = Just "frerf"
+
+T17380.hs:18:8: error:
+    • Couldn't match expected type ‘Maybe String’
+                  with actual type ‘Unit (Maybe [Char])’
+    • In the pattern: Unit(Just "wat")
+      In an equation for ‘quux’: quux (Unit(Just "wat")) = Just "frerf"
+
+T17380.hs:21:8: error:
+    • Couldn't match type ‘Maybe String’ with ‘'Unit (Maybe String)’
+      Expected type: Proxy ('Unit (Maybe String))
+        Actual type: Proxy (Maybe String)
+    • In the expression: Proxy :: Proxy (Maybe String)
+      In an equation for ‘quuz’: quuz = Proxy :: Proxy (Maybe String)
+
+T17380.hs:24:8: error:
+    • Couldn't match type ‘'Unit (Maybe String)’ with ‘Maybe String’
+      Expected type: Proxy (Maybe String)
+        Actual type: Proxy ('Unit (Maybe String))
+    • In the expression: Proxy :: Proxy ('Unit Maybe String)
+      In an equation for ‘fred’:
+          fred = Proxy :: Proxy ('Unit Maybe String)
diff --git a/testsuite/tests/th/T8761.stderr b/testsuite/tests/th/T8761.stderr
index bb01475722..79163dec51 100644
--- a/testsuite/tests/th/T8761.stderr
+++ b/testsuite/tests/th/T8761.stderr
@@ -1,5 +1,5 @@
 pattern Q1 x1_0 x2_1 x3_2 <- ((x1_0, x2_1), [x3_2], _, _)
-pattern x1_0 Q2 x2_1 = ((x1_0, x2_1))
+pattern x1_0 Q2 x2_1 = GHC.Tuple.Unit (x1_0, x2_1)
 pattern Q3 {qx3, qy3, qz3} <- ((qx3, qy3), [qz3]) where
                                   Q3 qx3 qy3 qz3 = ((qx3, qy3), [qz3])
 T8761.hs:(16,1)-(39,13): Splicing declarations
@@ -8,17 +8,13 @@ T8761.hs:(16,1)-(39,13): Splicing declarations
        let nm1 = mkName "Q1"
            prefixPat
              = patSynD
-                 nm1
-                 (prefixPatSyn [qx1, qy1, qz1])
-                 unidir
+                 nm1 (prefixPatSyn [qx1, qy1, qz1]) unidir
                  (tupP [tupP [varP qx1, varP qy1], listP [varP qz1], wildP, wildP])
        [qx2, qy2] <- mapM (\ i -> newName $ "x" ++ show i) [1, 2]
        let nm2 = mkName "Q2"
            infixPat
              = patSynD
-                 nm2
-                 (infixPatSyn qx2 qy2)
-                 implBidir
+                 nm2 (infixPatSyn qx2 qy2) implBidir
                  (tupP [tupP [varP qx2, varP qy2]])
        let nm3 = mkName "Q3"
            [qx3, qy3, qz3] = map mkName ["qx3", "qy3", "qz3"]
@@ -32,7 +28,7 @@ T8761.hs:(16,1)-(39,13): Splicing declarations
        return pats
   ======>
     pattern Q1 x1 x2 x3 <- ((x1, x2), [x3], _, _)
-    pattern x1 `Q2` x2 = ((x1, x2))
+    pattern x1 `Q2` x2 = Unit(x1, x2)
     pattern Q3{qx3, qy3, qz3} <- ((qx3, qy3), [qz3]) where
                                 Q3 qx3 qy3 qz3 = ((qx3, qy3), [qz3])
 T8761.hs:(42,1)-(46,29): Splicing declarations
diff --git a/testsuite/tests/th/TH_Promoted1Tuple.stderr b/testsuite/tests/th/TH_Promoted1Tuple.stderr
index a996623c30..495fb1c386 100644
--- a/testsuite/tests/th/TH_Promoted1Tuple.stderr
+++ b/testsuite/tests/th/TH_Promoted1Tuple.stderr
@@ -1,3 +1,3 @@
 
 TH_Promoted1Tuple.hs:7:3: error:
-    Illegal type: ‘'(Int)’ Perhaps you intended to use DataKinds
+    Illegal type: ‘'Unit Int’ Perhaps you intended to use DataKinds
diff --git a/testsuite/tests/th/TH_unresolvedInfix.hs b/testsuite/tests/th/TH_unresolvedInfix.hs
index aa684f7f23..49a6b03871 100644
--- a/testsuite/tests/th/TH_unresolvedInfix.hs
+++ b/testsuite/tests/th/TH_unresolvedInfix.hs
@@ -42,10 +42,7 @@ exprs = [
 -------------- Sections
   $( infixE (Just $ n +? n) plus Nothing ) N,
   -- see B.hs for the (non-compiling) other version of the above
-  $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N,
-
--------------- Dropping constructors
-  $( n *? tupE [n +? n] )
+  $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N
   ]
 
 --------------------------------------------------------------------------------
@@ -85,10 +82,7 @@ patterns = [
   case (N :+ N) :* (N :+ N) of
     [p14|unused|] -> True,
   case (N :+ (N :* N)) :+ N of
-    [p15|unused|] -> True,
--------------- Dropping constructors
-  case (N :* (N :+ N)) of
-    [p16|unused|] -> True
+    [p15|unused|] -> True
  ]
 
 --------------------------------------------------------------------------------
diff --git a/testsuite/tests/th/TH_unresolvedInfix.stdout b/testsuite/tests/th/TH_unresolvedInfix.stdout
index 7790e7b4c6..4f81fdafa9 100644
--- a/testsuite/tests/th/TH_unresolvedInfix.stdout
+++ b/testsuite/tests/th/TH_unresolvedInfix.stdout
@@ -19,8 +19,6 @@
 ((N :+ (N :* N)) :+ N)
 ((N :+ N) :+ N)
 (N :+ (N :+ N))
-(N :* (N :+ N))
-True
 True
 True
 True
diff --git a/testsuite/tests/th/TH_unresolvedInfix_Lib.hs b/testsuite/tests/th/TH_unresolvedInfix_Lib.hs
index a88b93fc8a..56930be3b7 100644
--- a/testsuite/tests/th/TH_unresolvedInfix_Lib.hs
+++ b/testsuite/tests/th/TH_unresolvedInfix_Lib.hs
@@ -11,8 +11,8 @@ infixl 6 :+
 infixl 7 :*
 
 data Tree = N
-  | Tree :+ Tree 
-  | Tree :* Tree 
+  | Tree :+ Tree
+  | Tree :* Tree
 
 -- custom instance, including redundant parentheses
 instance Show Tree where
@@ -73,8 +73,6 @@ p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) )
 p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p )
 p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) )
 p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) )
--------------- Dropping constructors
-p16 = mkQQ ( p ^*? (tupP [p ^+? p]) )
 
 --------------------------------------------------------------------------------
 --                                  Types                                     --
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 2a54cc9956..a75703dd83 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -475,6 +475,7 @@ test('T16293b', normal, compile, [''])
 test('T16326_TH', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T14741', normal, compile_and_run, [''])
 test('T16666', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T16881', normal, compile_and_run, [''])
 test('T16895a', normal, compile_fail, [''])
 test('T16895b', normal, compile_fail, [''])
 test('T16895c', normal, compile_fail, [''])
@@ -486,6 +487,7 @@ test('T16976z', normal, compile_fail, [''])
 test('T16980', normal, compile, [''])
 test('T16980a', normal, compile_fail, [''])
 test('T17296', normal, compile, ['-v0'])
+test('T17380', normal, compile_fail, [''])
 test('T17394', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T17379a', normal, compile_fail, [''])
 test('T17379b', normal, compile_fail, [''])