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

!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.

7 files changed, 86 insertions, 39 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