Use nested tuples to desugar recursive do-notation
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 17 Jan 2012 16:40:03 +0000 (16:40 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 17 Jan 2012 16:40:03 +0000 (16:40 +0000)
Easy fix for Trac #5742.

compiler/deSugar/DsExpr.lhs
compiler/typecheck/TcMatches.lhs

index a47e617..157754b 100644 (file)
@@ -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,
index 333c2d0..acdc838 100644 (file)
@@ -804,7 +804,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