diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-01-17 16:40:03 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-01-17 16:40:03 +0000 |
| commit | bb50135b1c35fda5289c88dbcb6ed7fb936d92c0 (patch) | |
| tree | ac7ecb8eed21b121f73bb96a158709d90d98cd81 | |
| parent | 51ba3c27b88ba9bec175342d22e17fe0bfc547d2 (diff) | |
| download | haskell-bb50135b1c35fda5289c88dbcb6ed7fb936d92c0.tar.gz | |
Use nested tuples to desugar recursive do-notation
Easy fix for Trac #5742.
| -rw-r--r-- | compiler/deSugar/DsExpr.lhs | 8 | ||||
| -rw-r--r-- | 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 a47e617a7c..157754bdfb 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 333c2d0984..acdc8389be 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -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 |