+deListComp (ParStmtOut bndrstmtss : quals) list
+ = mapDs doListComp qualss `thenDs` \ exps ->
+ mapDs genAS bndrss `thenDs` \ ass ->
+ mapDs genA bndrss `thenDs` \ as ->
+ mapDs genAS' bndrss `thenDs` \ as's ->
+ let retTy = myTupleTy Boxed (length bndrss) qualTys
+ zipTy = foldr mkFunTy (mkListTy retTy) (map mkListTy qualTys)
+ in
+ newSysLocalDs zipTy `thenDs` \ zipFn ->
+ let target = mkConsExpr retTy (mkTupleExpr as) (foldl App (Var zipFn) (map Var as's))
+ zipExp = mkLet zipFn (zip4 bndrss ass as as's) exps target
+ in
+ deBindComp pat zipExp quals list
+ where (bndrss, stmtss) = unzip bndrstmtss
+ pats = map (\ps -> mkTuplePat (map VarPat ps)) bndrss
+ mkTuplePat [p] = p
+ mkTuplePat ps = TuplePat ps Boxed
+ pat = TuplePat pats Boxed
+
+ qualss = map mkQuals bndrstmtss
+ mkQuals (bndrs, stmts) = (bndrs, stmts ++ [ExprStmt (myTupleExpr bndrs) noSrcLoc])
+
+ qualTys = map mkBndrsTy bndrss
+ mkBndrsTy bndrs = myTupleTy Boxed (length bndrs) (map idType bndrs)
+
+ doListComp (bndrs, stmts)
+ = dsListComp stmts (mkBndrsTy bndrs)
+ genA bndrs = newSysLocalDs (mkBndrsTy bndrs)
+ genAS bndrs = newSysLocalDs (mkListTy (mkBndrsTy bndrs))
+ genAS' bndrs = newSysLocalDs (mkListTy (mkBndrsTy bndrs))
+
+ mkLet zipFn vars exps target
+ = Let (Rec [(zipFn,
+ foldr Lam (mkBody target vars) (map getAs vars))])
+ (foldl App (Var zipFn) exps)
+ getAs (_, as, _, _) = as
+ mkBody target vars
+ = foldr mkCase (foldr mkTuplCase target vars) vars
+ mkCase (ps, as, a, as') rest
+ = Case (Var as) as [(DataAlt nilDataCon, [], mkConApp nilDataCon []),
+ (DataAlt consDataCon, [a, as'], rest)]
+ mkTuplCase ([p], as, a, as') rest
+ = App (Lam p rest) (Var a)
+ mkTuplCase (ps, as, a, as') rest
+ = Case (Var a) a [(DataAlt (tupleCon Boxed (length ps)), ps, rest)]
+
+ myTupleTy boxity arity [ty] = ty
+ myTupleTy boxity arity tys = mkTupleTy boxity arity tys
+ myTupleExpr [] = HsVar unitDataConId
+ myTupleExpr [id] = HsVar id
+ myTupleExpr ids = ExplicitTuple [ HsVar i | i <- ids ] Boxed
+
+ -- Last: the one to return
+deListComp [ExprStmt expr locn] list -- Figure 7.4, SLPJ, p 135, rule C above