[commit: ghc] ghc-7.4: Use nested tuples to desugar recursive do-notation (d87990f)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-7.4

http://hackage.haskell.org/trac/ghc/changeset/d87990feec8a9fb360b4d92ea7b5cfa36152b8ca

>---------------------------------------------------------------

commit d87990feec8a9fb360b4d92ea7b5cfa36152b8ca
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Jan 17 16:40:03 2012 +0000

    Use nested tuples to desugar recursive do-notation
    
    Easy fix for Trac #5742.

>---------------------------------------------------------------

 compiler/deSugar/DsExpr.lhs      |    8 ++++----
 compiler/typecheck/TcMatches.lhs |    2 +-
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index a47e617..157754b 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -758,21 +758,21 @@ dsDo stmts
       = ASSERT( length rec_ids > 0 )
         goL (new_bind_stmt : stmts)
       where
-        new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
+        new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)
                                          mfix_app bind_op 
                                          noSyntaxExpr  -- Tuple cannot fail
 
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
-        tup_ty       = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
+        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
         rec_tup_pats = map nlVarPat tup_ids
         later_pats   = rec_tup_pats
         rets         = map noLoc rec_rets
         mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg
         mfix_arg     = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
                                                  (mkFunTy tup_ty body_ty))
-        mfix_pat     = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
+        mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
         body         = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
-        ret_app      = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
+        ret_app      = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
         ret_stmt     = noLoc $ mkLastStmt ret_app
                      -- This LastStmt will be desugared with dsDo, 
                      -- which ignores the return_op in the LastStmt,
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 1474686..1af3de9 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -803,7 +803,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
         ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
-	      tup_ty  = mkBoxedTupleTy tup_elt_tys
+	      tup_ty  = mkBigCoreTupTy tup_elt_tys
 
         ; tcExtendIdEnv tup_ids $ do
         { stmts_ty <- newFlexiTyVarTy liftedTypeKind