Note [Don't flatten tuples from HsSyn] in MkCore

Previously, we would sometimes flatten 1-tuples and sometimes
not. This didn't cause damage because there is no way to
generate HsSyn with 1-tuples. But, with the upcoming fix to #16881,
there will be. Without this patch, obscure lint errors would
have resulted.

No test case, as there is not yet a way to tickle this.

7 files changed, 58 insertions, 21 deletions

diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index b451e61a63..c9665ec8d7 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -21,7 +21,7 @@ module MkCore (
         FloatBind(..), wrapFloat, wrapFloats, floatBindings,
 
         -- * Constructing small tuples
-        mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,
+        mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,
         mkCoreTupBoxity, unitExpr,
 
         -- * Constructing big tuples
@@ -344,12 +344,22 @@ We could do one of two things:
   We use a suffix "1" to indicate this.
 
 Usually we want the former, but occasionally the latter.
--}
 
--- | Build a small tuple holding the specified variables
--- One-tuples are flattened; see Note [Flattening one-tuples]
-mkCoreVarTup :: [Id] -> CoreExpr
-mkCoreVarTup ids = mkCoreTup (map Var ids)
+NB: The logic in tupleDataCon knows about () and Unit and (,), etc.
+
+Note [Don't flatten tuples from HsSyn]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we get an explicit 1-tuple from HsSyn somehow (likely: Template Haskell),
+we should treat it really as a 1-tuple, without flattening. Note that a
+1-tuple and a flattened value have different performance and laziness
+characteristics, so should just do what we're asked.
+
+This arose from discussions in #16881.
+
+One-tuples that arise internally depend on the circumstance; often flattening
+is a good idea. Decisions are made on a case-by-case basis.
+
+-}
 
 -- | Build the type of a small tuple that holds the specified variables
 -- One-tuples are flattened; see Note [Flattening one-tuples]
@@ -359,9 +369,14 @@ mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
 -- | Build a small tuple holding the specified expressions
 -- One-tuples are flattened; see Note [Flattening one-tuples]
 mkCoreTup :: [CoreExpr] -> CoreExpr
-mkCoreTup []  = Var unitDataConId
 mkCoreTup [c] = c
-mkCoreTup cs  = mkCoreConApps (tupleDataCon Boxed (length cs))
+mkCoreTup cs  = mkCoreTup1 cs   -- non-1-tuples are uniform
+
+-- | Build a small tuple holding the specified expressions
+-- One-tuples are *not* flattened; see Note [Flattening one-tuples]
+-- See also Note [Don't flatten tuples from HsSyn]
+mkCoreTup1 :: [CoreExpr] -> CoreExpr
+mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs))
                               (map (Type . exprType) cs ++ cs)
 
 -- | Build a small unboxed tuple holding the specified expressions,
@@ -375,9 +390,9 @@ mkCoreUbxTup tys exps
     mkCoreConApps (tupleDataCon Unboxed (length tys))
              (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)
 
--- | Make a core tuple of the given boxity
+-- | Make a core tuple of the given boxity; don't flatten 1-tuples
 mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
-mkCoreTupBoxity Boxed   exps = mkCoreTup exps
+mkCoreTupBoxity Boxed   exps = mkCoreTup1 exps
 mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps
 
 -- | Build a big tuple holding the specified variables
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index f3b4ba5d6d..1cf981cddd 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -393,6 +393,7 @@ ds_expr _ (ExplicitTuple _ tup_args boxity)
                 -- The reverse is because foldM goes left-to-right
                       (\(lam_vars, args) -> mkCoreLams lam_vars $
                                             mkCoreTupBoxity boxity args) }
+                        -- See Note [Don't flatten tuples from HsSyn] in MkCore
 
 ds_expr _ (ExplicitSum types alt arity expr)
   = do { dsWhenNoErrs (dsLExprNoLP expr)
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index 14dab29b30..8559e9ae85 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -32,7 +32,7 @@ module DsUtils (
         seqVar,
 
         -- LHs tuples
-        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
+        mkLHsPatTup, mkVanillaTuplePat,
         mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
 
         mkSelectorBinds,
@@ -756,9 +756,6 @@ mkLHsPatTup [lpat] = lpat
 mkLHsPatTup lpats  = cL (getLoc (head lpats)) $
                      mkVanillaTuplePat lpats Boxed
 
-mkLHsVarPatTup :: [Id] -> LPat GhcTc
-mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
-
 mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
 -- A vanilla tuple pattern simply gets its type from its sub-patterns
 mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index be4bfe1ce9..4d6b7f8027 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -68,7 +68,7 @@ module TysWiredIn (
         justDataCon, justDataConName, promotedJustDataCon,
 
         -- * Tuples
-        mkTupleTy, mkBoxedTupleTy,
+        mkTupleTy, mkTupleTy1, mkBoxedTupleTy,
         tupleTyCon, tupleDataCon, tupleTyConName,
         promotedTupleDataCon,
         unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,
@@ -695,9 +695,18 @@ for one-tuples.  So in ghc-prim:GHC.Tuple we see the declarations:
   data Unit a = Unit a
   data (a,b)  = (a,b)
 
+There is no way to write a boxed one-tuple in Haskell, but it can be
+created in Template Haskell or in, e.g., `deriving` code. There is
+nothing special about one-tuples in Core; in particular, they have no
+custom pretty-printing, just using `Unit`.
+
 NB (Feb 16): for /constraint/ one-tuples I have 'Unit%' but no class
 decl in GHC.Classes, so I think this part may not work properly. But
 it's unused I think.
+
+See also Note [Flattening one-tuples] in MkCore and
+Note [Don't flatten tuples from HsSyn] in MkCore.
+
 -}
 
 -- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names
@@ -1556,15 +1565,24 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}.
 -}
 
 -- | Make a tuple type. The list of types should /not/ include any
--- RuntimeRep specifications.
+-- RuntimeRep specifications. Boxed 1-tuples are flattened.
+-- See Note [One-tuples]
 mkTupleTy :: Boxity -> [Type] -> Type
 -- Special case for *boxed* 1-tuples, which are represented by the type itself
 mkTupleTy Boxed   [ty] = ty
-mkTupleTy Boxed   tys  = mkTyConApp (tupleTyCon Boxed (length tys)) tys
-mkTupleTy Unboxed tys  = mkTyConApp (tupleTyCon Unboxed (length tys))
-                                        (map getRuntimeRep tys ++ tys)
+mkTupleTy boxity  tys  = mkTupleTy1 boxity tys
+
+-- | Make a tuple type. The list of types should /not/ include any
+-- RuntimeRep specifications. Boxed 1-tuples are *not* flattened.
+-- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn]
+-- in MkCore
+mkTupleTy1 :: Boxity -> [Type] -> Type
+mkTupleTy1 Boxed   tys  = mkTyConApp (tupleTyCon Boxed (length tys)) tys
+mkTupleTy1 Unboxed tys  = mkTyConApp (tupleTyCon Unboxed (length tys))
+                                         (map getRuntimeRep tys ++ tys)
 
 -- | Build the type of a small tuple that holds the specified type of thing
+-- Flattens 1-tuples. See Note [One-tuples].
 mkBoxedTupleTy :: [Type] -> Type
 mkBoxedTupleTy tys = mkTupleTy Boxed tys
 
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index c195576c39..88896fc266 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -467,6 +467,8 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
   | all tupArgPresent tup_args
   = do { let arity  = length tup_args
              tup_tc = tupleTyCon boxity arity
+               -- NB: tupleTyCon doesn't flatten 1-tuples
+               -- See Note [Don't flatten tuples from HsSyn] in MkCore
        ; res_ty <- expTypeToType res_ty
        ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
                            -- Unboxed tuples have RuntimeRep vars, which we
@@ -486,7 +488,8 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
            ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
        ; let actual_res_ty
                  = mkVisFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]
-                            (mkTupleTy boxity arg_tys)
+                            (mkTupleTy1 boxity arg_tys)
+                   -- See Note [Don't flatten tuples from HsSyn] in MkCore
 
        ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")
                              (Just expr)
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index cd15db5bfd..fb7dc117c1 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -110,7 +110,8 @@ hsPatType (AsPat _ var _)               = idType (unLoc var)
 hsPatType (ViewPat ty _ _)              = ty
 hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty
 hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
-hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys
+hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys
+                  -- See Note [Don't flatten tuples from HsSyn] in MkCore
 hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
 hsPatType (ConPatOut { pat_con = lcon
                      , pat_arg_tys = tys })
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 7ecfb61d7d..1a7adde878 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -446,6 +446,8 @@ tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside
 tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside
   = do  { let arity = length pats
               tc = tupleTyCon boxity arity
+              -- NB: tupleTyCon does not flatten 1-tuples
+              -- See Note [Don't flatten tuples from HsSyn] in MkCore
         ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
                                                penv pat_ty
                      -- Unboxed tuples have RuntimeRep vars, which we discard: