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.

4 files changed, 35 insertions, 14 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