import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
-import HsSyn ( Stmt(..) )
+import BasicTypes ( Boxity(..) )
+import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..) )
import TcHsSyn ( TypecheckedStmt )
import DsHsSyn ( outPatType )
import CoreSyn
import Var ( Id )
import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type )
import TysPrim ( alphaTyVar )
-import TysWiredIn ( nilDataCon, consDataCon )
+import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, tupleCon, mkListTy, mkTupleTy )
import Match ( matchSimply )
-import PrelNames ( foldrIdKey, buildIdKey )
+import PrelNames ( foldrName, buildName )
+import SrcLoc ( noSrcLoc )
+import List ( zip4 )
\end{code}
List comprehensions may be desugared in one of two ways: ``ordinary''
c_ty = mkFunTys [elt_ty, n_ty] n_ty
in
newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] ->
-
dfListComp c n quals `thenDs` \ result ->
-
- dsLookupGlobalValue buildIdKey `thenDs` \ build_id ->
+ dsLookupGlobalValue buildName `thenDs` \ build_id ->
returnDs (Var build_id `App` Type elt_ty
`App` mkLams [n_tyvar, c, n] result)
\end{code}
is the TE translation scheme. Note that we carry around the @L@ list
already desugared. @dsListComp@ does the top TE rule mentioned above.
+To the above, we add an additional rule to deal with parallel list
+comprehensions. The translation goes roughly as follows:
+ [ e | p1 <- e11, let v1 = e12, p2 <- e13
+ | q1 <- e21, let v2 = e22, q2 <- e23]
+ =>
+ [ e | ((p1,v1,p2), (q1,v2,q2)) <-
+ zip [(p1,v1,p2) | p1 <- e11, let v1 = e12, p2 <- e13]
+ [(q1,v2,q2) | q1 <- e21, let v2 = e22, q2 <- e23]]
+In the translation below, the ParStmtOut branch translates each parallel branch
+into a sub-comprehension, and desugars each independently. The resulting lists
+are fed to a zip function, we create a binding for all the variables bound in all
+the comprehensions, and then we hand things off the the desugarer for bindings.
+The zip function is generated here a) because it's small, and b) because then we
+don't have to deal with arbitrary limits on the number of zip functions in the
+prelude, nor which library the zip function came from.
+The introduced tuples are Boxed, but only because I couldn't get it to work
+with the Unboxed variety.
\begin{code}
+
deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
-deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above
+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
= dsExpr expr `thenDs` \ core_expr ->
returnDs (mkConsExpr (exprType core_expr) core_expr list)
-deListComp (GuardStmt guard locn : quals) list -- rule B above
+ -- Non-last: must be a guard
+deListComp (ExprStmt guard locn : quals) list -- rule B above
= dsExpr guard `thenDs` \ core_guard ->
deListComp quals list `thenDs` \ core_rest ->
returnDs (mkIfThenElse core_guard core_rest list)
deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
= dsExpr list1 `thenDs` \ core_list1 ->
- let
+ deBindComp pat core_list1 quals core_list2
+
+deBindComp pat core_list1 quals core_list2
+ = let
u3_ty@u1_ty = exprType core_list1 -- two names, same thing
-- u1_ty is a [alpha] type, and u2_ty = alpha
letrec_body = App (Var h) core_list1
in
deListComp quals core_fail `thenDs` \ rest_expr ->
- matchSimply (Var u2) ListCompMatch pat
+ matchSimply (Var u2) ListComp pat
rest_expr core_fail `thenDs` \ core_match ->
let
rhs = Lam u1 $
-> [TypecheckedStmt] -- the rest of the qual's
-> DsM CoreExpr
-dfListComp c_id n_id [ReturnStmt expr]
+ -- Last: the one to return
+dfListComp c_id n_id [ExprStmt expr locn]
= dsExpr expr `thenDs` \ core_expr ->
returnDs (mkApps (Var c_id) [core_expr, Var n_id])
-dfListComp c_id n_id (GuardStmt guard locn : quals)
+ -- Non-last: must be a guard
+dfListComp c_id n_id (ExprStmt guard locn : quals)
= dsExpr guard `thenDs` \ core_guard ->
dfListComp c_id n_id quals `thenDs` \ core_rest ->
returnDs (mkIfThenElse core_guard core_rest (Var n_id))
dfListComp c_id b quals `thenDs` \ core_rest ->
-- build the pattern match
- matchSimply (Var x) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr ->
+ matchSimply (Var x) ListComp pat core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
- dsLookupGlobalValue foldrIdKey `thenDs` \ foldr_id ->
+ dsLookupGlobalValue foldrName `thenDs` \ foldr_id ->
returnDs (
Var foldr_id `App` Type x_ty
`App` Type b_ty