Skip to content
Snippets Groups Projects
Commit d87990fe authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ian Lynagh
Browse files

Use nested tuples to desugar recursive do-notation

Easy fix for Trac #5742.
parent e3b7e335
No related branches found
No related tags found
No related merge requests found
...@@ -758,21 +758,21 @@ dsDo stmts ...@@ -758,21 +758,21 @@ dsDo stmts
= ASSERT( length rec_ids > 0 ) = ASSERT( length rec_ids > 0 )
goL (new_bind_stmt : stmts) goL (new_bind_stmt : stmts)
where where
new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)
mfix_app bind_op mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail noSyntaxExpr -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids 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 rec_tup_pats = map nlVarPat tup_ids
later_pats = rec_tup_pats later_pats = rec_tup_pats
rets = map noLoc rec_rets rets = map noLoc rec_rets
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty)) (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 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 ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo, -- This LastStmt will be desugared with dsDo,
-- which ignores the return_op in the LastStmt, -- which ignores the return_op in the LastStmt,
......
...@@ -803,7 +803,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ...@@ -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 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys ; 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 ; tcExtendIdEnv tup_ids $ do
{ stmts_ty <- newFlexiTyVarTy liftedTypeKind { stmts_ty <- newFlexiTyVarTy liftedTypeKind
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment