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 <[email protected]> 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
