2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Desugaring list comprehensions and array comprehensions
9 {-# OPTIONS -fno-warn-incomplete-patterns #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module DsListComp ( dsListComp, dsPArrComp ) where
18 #include "HsVersions.h"
20 import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
27 import DsMonad -- the monadery used in the desugarer
42 List comprehensions may be desugared in one of two ways: ``ordinary''
43 (as you would expect if you read SLPJ's book) and ``with foldr/build
44 turned on'' (if you read Gill {\em et al.}'s paper on the subject).
46 There will be at least one ``qualifier'' in the input.
49 dsListComp :: [LStmt Id]
51 -> Type -- Type of list elements
53 dsListComp lquals body elt_ty = do
55 let quals = map unLoc lquals
57 if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
58 -- Either rules are switched off, or we are ignoring what there are;
59 -- Either way foldr/build won't happen, so use the more efficient
60 -- Wadler-style desugaring
61 || isParallelComp quals
62 -- Foldr-style desugaring can't handle parallel list comprehensions
63 then deListComp quals body (mkNilExpr elt_ty)
64 else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body)
65 -- Foldr/build should be enabled, so desugar
66 -- into foldrs and builds
69 -- We must test for ParStmt anywhere, not just at the head, because an extension
70 -- to list comprehensions would be to add brackets to specify the associativity
71 -- of qualifier lists. This is really easy to do by adding extra ParStmts into the
72 -- mix of possibly a single element in length, so we do this to leave the possibility open
73 isParallelComp = any isParallelStmt
75 isParallelStmt (ParStmt _) = True
76 isParallelStmt _ = False
79 -- This function lets you desugar a inner list comprehension and a list of the binders
80 -- of that comprehension that we need in the outer comprehension into such an expression
81 -- and the type of the elements that it outputs (tuples of binders)
82 dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
83 dsInnerListComp (stmts, bndrs) = do
84 expr <- dsListComp stmts (mkBigLHsVarTup bndrs) bndrs_tuple_type
85 return (expr, bndrs_tuple_type)
87 bndrs_types = map idType bndrs
88 bndrs_tuple_type = mkBigCoreTupTy bndrs_types
91 -- This function factors out commonality between the desugaring strategies for TransformStmt.
92 -- Given such a statement it gives you back an expression representing how to compute the transformed
93 -- list and the tuple that you need to bind from that list in order to proceed with your desugaring
94 dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
95 dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr)
96 = do { (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
97 ; usingExpr' <- dsLExpr usingExpr
101 Nothing -> return [expr]
103 byExpr' <- dsLExpr byExpr
105 us <- newUniqueSupply
106 [tuple_binder] <- newSysLocalsDs [binders_tuple_type]
107 let byExprWrapper = mkTupleCase us binders byExpr' tuple_binder (Var tuple_binder)
109 return [Lam tuple_binder byExprWrapper, expr]
111 ; let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
112 pat = mkBigLHsVarPatTup binders
113 ; return (inner_list_expr, pat) }
115 -- This function factors out commonality between the desugaring strategies for GroupStmt.
116 -- Given such a statement it gives you back an expression representing how to compute the transformed
117 -- list and the tuple that you need to bind from that list in order to proceed with your desugaring
118 dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
119 dsGroupStmt (GroupStmt stmts binderMap by using) = do
120 let (fromBinders, toBinders) = unzip binderMap
122 fromBindersTypes = map idType fromBinders
123 toBindersTypes = map idType toBinders
125 toBindersTupleType = mkBigCoreTupTy toBindersTypes
127 -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
128 (expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders)
130 -- Work out what arguments should be supplied to that expression: i.e. is an extraction
131 -- function required? If so, create that desugared function and add to arguments
132 usingExpr' <- dsLExpr (either id noLoc using)
133 usingArgs <- case by of
134 Nothing -> return [expr]
135 Just by_e -> do { by_e' <- dsLExpr by_e
136 ; us <- newUniqueSupply
137 ; [from_tup_id] <- newSysLocalsDs [from_tup_ty]
138 ; let by_wrap = mkTupleCase us fromBinders by_e'
139 from_tup_id (Var from_tup_id)
140 ; return [Lam from_tup_id by_wrap, expr] }
142 -- Create an unzip function for the appropriate arity and element types and find "map"
143 (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes
144 map_id <- dsLookupGlobalId mapName
146 -- Generate the expressions to build the grouped list
147 let -- First we apply the grouping function to the inner list
148 inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs)
149 -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
150 -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
151 -- the "b" to be a tuple of "to" lists!
152 unzipped_inner_list_expr = mkApps (Var map_id)
153 [Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr]
154 -- Then finally we bind the unzip function around that expression
155 bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr
157 -- Build a pattern that ensures the consumer binds into the NEW binders, which hold lists rather than single values
158 let pat = mkBigLHsVarPatTup toBinders
159 return (bound_unzipped_inner_list_expr, pat)
163 %************************************************************************
165 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
167 %************************************************************************
169 Just as in Phil's chapter~7 in SLPJ, using the rules for
170 optimally-compiled list comprehensions. This is what Kevin followed
171 as well, and I quite happily do the same. The TQ translation scheme
172 transforms a list of qualifiers (either boolean expressions or
173 generators) into a single expression which implements the list
174 comprehension. Because we are generating 2nd-order polymorphic
175 lambda-calculus, calls to NIL and CONS must be applied to a type
176 argument, as well as their usual value arguments.
178 TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >>
181 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
184 TQ << [ e | b , qs ] ++ L >> =
185 if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
188 TQ << [ e | p <- L1, qs ] ++ L2 >> =
194 (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2)
199 "h", "u1", "u2", and "u3" are new variables.
202 @deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@
203 is the TE translation scheme. Note that we carry around the @L@ list
204 already desugared. @dsListComp@ does the top TE rule mentioned above.
206 To the above, we add an additional rule to deal with parallel list
207 comprehensions. The translation goes roughly as follows:
208 [ e | p1 <- e11, let v1 = e12, p2 <- e13
209 | q1 <- e21, let v2 = e22, q2 <- e23]
211 [ e | ((x1, .., xn), (y1, ..., ym)) <-
212 zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
213 [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
214 where (x1, .., xn) are the variables bound in p1, v1, p2
215 (y1, .., ym) are the variables bound in q1, v2, q2
217 In the translation below, the ParStmt branch translates each parallel branch
218 into a sub-comprehension, and desugars each independently. The resulting lists
219 are fed to a zip function, we create a binding for all the variables bound in all
220 the comprehensions, and then we hand things off the the desugarer for bindings.
221 The zip function is generated here a) because it's small, and b) because then we
222 don't have to deal with arbitrary limits on the number of zip functions in the
223 prelude, nor which library the zip function came from.
224 The introduced tuples are Boxed, but only because I couldn't get it to work
225 with the Unboxed variety.
229 deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
231 deListComp (ParStmt stmtss_w_bndrs : quals) body list
233 exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
234 let (exps, qual_tys) = unzip exps_and_qual_tys
236 (zip_fn, zip_rhs) <- mkZipBind qual_tys
238 -- Deal with [e | pat <- zip l1 .. ln] in example above
239 deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
243 bndrs_s = map snd stmtss_w_bndrs
245 -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
246 pat = mkBigLHsPatTup pats
247 pats = map mkBigLHsVarPatTup bndrs_s
249 -- Last: the one to return
250 deListComp [] body list = do -- Figure 7.4, SLPJ, p 135, rule C above
251 core_body <- dsLExpr body
252 return (mkConsExpr (exprType core_body) core_body list)
254 -- Non-last: must be a guard
255 deListComp (ExprStmt guard _ _ : quals) body list = do -- rule B above
256 core_guard <- dsLExpr guard
257 core_rest <- deListComp quals body list
258 return (mkIfThenElse core_guard core_rest list)
260 -- [e | let B, qs] = let B in [e | qs]
261 deListComp (LetStmt binds : quals) body list = do
262 core_rest <- deListComp quals body list
263 dsLocalBinds binds core_rest
265 deListComp (stmt@(TransformStmt {}) : quals) body list = do
266 (inner_list_expr, pat) <- dsTransformStmt stmt
267 deBindComp pat inner_list_expr quals body list
269 deListComp (stmt@(GroupStmt {}) : quals) body list = do
270 (inner_list_expr, pat) <- dsGroupStmt stmt
271 deBindComp pat inner_list_expr quals body list
273 deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' above
274 core_list1 <- dsLExpr list1
275 deBindComp pat core_list1 quals body core_list2
280 deBindComp :: OutPat Id
286 deBindComp pat core_list1 quals body core_list2 = do
288 u3_ty@u1_ty = exprType core_list1 -- two names, same thing
290 -- u1_ty is a [alpha] type, and u2_ty = alpha
291 u2_ty = hsLPatType pat
293 res_ty = exprType core_list2
294 h_ty = u1_ty `mkFunTy` res_ty
296 [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
298 -- the "fail" value ...
300 core_fail = App (Var h) (Var u3)
301 letrec_body = App (Var h) core_list1
303 rest_expr <- deListComp quals body core_fail
304 core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
308 Case (Var u1) u1 res_ty
309 [(DataAlt nilDataCon, [], core_list2),
310 (DataAlt consDataCon, [u2, u3], core_match)]
311 -- Increasing order of tag
313 return (Let (Rec [(h, rhs)]) letrec_body)
316 %************************************************************************
318 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
320 %************************************************************************
322 @dfListComp@ are the rules used with foldr/build turned on:
325 TE[ e | ] c n = c e n
326 TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n
327 TE[ e | p <- l , q ] c n = let
328 f = \ x b -> case x of
336 dfListComp :: Id -> Id -- 'c' and 'n'
337 -> [Stmt Id] -- the rest of the qual's
341 -- Last: the one to return
342 dfListComp c_id n_id [] body = do
343 core_body <- dsLExpr body
344 return (mkApps (Var c_id) [core_body, Var n_id])
346 -- Non-last: must be a guard
347 dfListComp c_id n_id (ExprStmt guard _ _ : quals) body = do
348 core_guard <- dsLExpr guard
349 core_rest <- dfListComp c_id n_id quals body
350 return (mkIfThenElse core_guard core_rest (Var n_id))
352 dfListComp c_id n_id (LetStmt binds : quals) body = do
353 -- new in 1.3, local bindings
354 core_rest <- dfListComp c_id n_id quals body
355 dsLocalBinds binds core_rest
357 dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do
358 (inner_list_expr, pat) <- dsTransformStmt stmt
359 -- Anyway, we bind the newly transformed list via the generic binding function
360 dfBindComp c_id n_id (pat, inner_list_expr) quals body
362 dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do
363 (inner_list_expr, pat) <- dsGroupStmt stmt
364 -- Anyway, we bind the newly grouped list via the generic binding function
365 dfBindComp c_id n_id (pat, inner_list_expr) quals body
367 dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = do
368 -- evaluate the two lists
369 core_list1 <- dsLExpr list1
371 -- Do the rest of the work in the generic binding builder
372 dfBindComp c_id n_id (pat, core_list1) quals body
374 dfBindComp :: Id -> Id -- 'c' and 'n'
375 -> (LPat Id, CoreExpr)
376 -> [Stmt Id] -- the rest of the qual's
379 dfBindComp c_id n_id (pat, core_list1) quals body = do
380 -- find the required type
381 let x_ty = hsLPatType pat
384 -- create some new local id's
385 [b, x] <- newSysLocalsDs [b_ty, x_ty]
387 -- build rest of the comprehesion
388 core_rest <- dfListComp c_id b quals body
390 -- build the pattern match
391 core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
392 pat core_rest (Var b)
394 -- now build the outermost foldr, and return
395 mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
398 %************************************************************************
400 \subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
402 %************************************************************************
406 mkZipBind :: [Type] -> DsM (Id, CoreExpr)
407 -- mkZipBind [t1, t2]
408 -- = (zip, \as1:[t1] as2:[t2]
411 -- (a1:as'1) -> case as2 of
413 -- (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
415 mkZipBind elt_tys = do
416 ass <- mapM newSysLocalDs elt_list_tys
417 as' <- mapM newSysLocalDs elt_tys
418 as's <- mapM newSysLocalDs elt_list_tys
420 zip_fn <- newSysLocalDs zip_fn_ty
422 let inner_rhs = mkConsExpr elt_tuple_ty
423 (mkBigCoreVarTup as')
424 (mkVarApps (Var zip_fn) as's)
425 zip_body = foldr mk_case inner_rhs (zip3 ass as' as's)
427 return (zip_fn, mkLams ass zip_body)
429 elt_list_tys = map mkListTy elt_tys
430 elt_tuple_ty = mkBigCoreTupTy elt_tys
431 elt_tuple_list_ty = mkListTy elt_tuple_ty
433 zip_fn_ty = mkFunTys elt_list_tys elt_tuple_list_ty
435 mk_case (as, a', as') rest
436 = Case (Var as) as elt_tuple_list_ty
437 [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty),
438 (DataAlt consDataCon, [a', as'], rest)]
439 -- Increasing order of tag
442 mkUnzipBind :: [Type] -> DsM (Id, CoreExpr)
443 -- mkUnzipBind [t1, t2]
444 -- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
446 -- (x1, x2) -> case axs of
447 -- (xs1, xs2) -> (x1 : xs1, x2 : xs2))
451 -- We use foldr here in all cases, even if rules are turned off, because we may as well!
452 mkUnzipBind elt_tys = do
453 ax <- newSysLocalDs elt_tuple_ty
454 axs <- newSysLocalDs elt_list_tuple_ty
455 ys <- newSysLocalDs elt_tuple_list_ty
456 xs <- mapM newSysLocalDs elt_tys
457 xss <- mapM newSysLocalDs elt_list_tys
459 unzip_fn <- newSysLocalDs unzip_fn_ty
461 [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
463 let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
465 concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
466 tupled_concat_expression = mkBigCoreTup concat_expressions
468 folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
469 folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
470 folder_body = mkLams [ax, axs] folder_body_outer_case
472 unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
473 return (unzip_fn, mkLams [ys] unzip_body)
475 elt_tuple_ty = mkBigCoreTupTy elt_tys
476 elt_tuple_list_ty = mkListTy elt_tuple_ty
477 elt_list_tys = map mkListTy elt_tys
478 elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys
480 unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
482 mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
488 %************************************************************************
490 \subsection[DsPArrComp]{Desugaring of array comprehensions}
492 %************************************************************************
496 -- entry point for desugaring a parallel array comprehension
498 -- [:e | qss:] = <<[:e | qss:]>> () [:():]
500 dsPArrComp :: [Stmt Id]
502 -> Type -- Don't use; called with `undefined' below
504 dsPArrComp [ParStmt qss] body _ = -- parallel comprehension
505 dePArrParComp qss body
507 -- Special case for simple generators:
509 -- <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e
511 -- if matching again p cannot fail, or else
513 -- <<[:e' | p <- e, qs:]>> =
514 -- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
516 dsPArrComp (BindStmt p e _ _ : qs) body _ = do
517 filterP <- dsLookupDPHId filterPName
519 let ety'ce = parrElemType ce
520 false = Var falseDataConId
521 true = Var trueDataConId
522 v <- newSysLocalDs ety'ce
523 pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
524 let gen | isIrrefutableHsPat p = ce
525 | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
526 dePArrComp qs body p gen
528 dsPArrComp qs body _ = do -- no ParStmt in `qs'
529 sglP <- dsLookupDPHId singletonPName
530 let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
531 dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
537 dePArrComp :: [Stmt Id]
539 -> LPat Id -- the current generator pattern
540 -> CoreExpr -- the current generator expression
543 -- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
545 dePArrComp [] e' pa cea = do
546 mapP <- dsLookupDPHId mapPName
547 let ty = parrElemType cea
548 (clam, ty'e') <- deLambda ty pa e'
549 return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
551 -- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
553 dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
554 filterP <- dsLookupDPHId filterPName
555 let ty = parrElemType cea
556 (clam,_) <- deLambda ty pa b
557 dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
560 -- <<[:e' | p <- e, qs:]>> pa ea =
563 -- <<[:e' | qs:]>> (pa, p) (crossMap ea ef)
565 -- if matching again p cannot fail, or else
567 -- <<[:e' | p <- e, qs:]>> pa ea =
568 -- let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
570 -- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
572 dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
573 filterP <- dsLookupDPHId filterPName
574 crossMapP <- dsLookupDPHId crossMapPName
576 let ety'cea = parrElemType cea
577 ety'ce = parrElemType ce
578 false = Var falseDataConId
579 true = Var trueDataConId
580 v <- newSysLocalDs ety'ce
581 pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
582 let cef | isIrrefutableHsPat p = ce
583 | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
584 (clam, _) <- mkLambda ety'cea pa cef
585 let ety'cef = ety'ce -- filter doesn't change the element type
586 pa' = mkLHsPatTup [pa, p]
588 dePArrComp qs body pa' (mkApps (Var crossMapP)
589 [Type ety'cea, Type ety'cef, cea, clam])
591 -- <<[:e' | let ds, qs:]>> pa ea =
592 -- <<[:e' | qs:]>> (pa, (x_1, ..., x_n))
593 -- (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)
595 -- {x_1, ..., x_n} = DV (ds) -- Defined Variables
597 dePArrComp (LetStmt ds : qs) body pa cea = do
598 mapP <- dsLookupDPHId mapPName
599 let xs = collectLocalBinders ds
600 ty'cea = parrElemType cea
601 v <- newSysLocalDs ty'cea
602 clet <- dsLocalBinds ds (mkCoreTup (map Var xs))
603 let'v <- newSysLocalDs (exprType clet)
604 let projBody = mkCoreLet (NonRec let'v clet) $
605 mkCoreTup [Var v, Var let'v]
606 errTy = exprType projBody
607 errMsg = ptext (sLit "DsListComp.dePArrComp: internal error!")
608 cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg
609 ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
610 let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
611 proj = mkLams [v] ccase
612 dePArrComp qs body pa' (mkApps (Var mapP)
613 [Type ty'cea, Type errTy, proj, cea])
615 -- The parser guarantees that parallel comprehensions can only appear as
616 -- singeltons qualifier lists, which we already special case in the caller.
617 -- So, encountering one here is a bug.
619 dePArrComp (ParStmt _ : _) _ _ _ =
620 panic "DsListComp.dePArrComp: malformed comprehension AST"
622 -- <<[:e' | qs | qss:]>> pa ea =
623 -- <<[:e' | qss:]>> (pa, (x_1, ..., x_n))
624 -- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
626 -- {x_1, ..., x_n} = DV (qs)
628 dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr
629 dePArrParComp qss body = do
630 (pQss, ceQss) <- deParStmt qss
631 dePArrComp [] body pQss ceQss
634 -- empty parallel statement lists have no source representation
635 panic "DsListComp.dePArrComp: Empty parallel list comprehension"
636 deParStmt ((qs, xs):qss) = do -- first statement
637 let res_expr = mkLHsVarTuple xs
638 cqs <- dsPArrComp (map unLoc qs) res_expr undefined
639 parStmts qss (mkLHsVarPatTup xs) cqs
641 parStmts [] pa cea = return (pa, cea)
642 parStmts ((qs, xs):qss) pa cea = do -- subsequent statements (zip'ed)
643 zipP <- dsLookupDPHId zipPName
644 let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
645 ty'cea = parrElemType cea
646 res_expr = mkLHsVarTuple xs
647 cqs <- dsPArrComp (map unLoc qs) res_expr undefined
648 let ty'cqs = parrElemType cqs
649 cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
650 parStmts qss pa' cea'
652 -- generate Core corresponding to `\p -> e'
654 deLambda :: Type -- type of the argument
655 -> LPat Id -- argument pattern
656 -> LHsExpr Id -- body
657 -> DsM (CoreExpr, Type)
659 mkLambda ty p =<< dsLExpr e
661 -- generate Core for a lambda pattern match, where the body is already in Core
663 mkLambda :: Type -- type of the argument
664 -> LPat Id -- argument pattern
665 -> CoreExpr -- desugared body
666 -> DsM (CoreExpr, Type)
667 mkLambda ty p ce = do
668 v <- newSysLocalDs ty
669 let errMsg = ptext (sLit "DsListComp.deLambda: internal error!")
671 cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg
672 res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr
673 return (mkLams [v] res, ce'ty)
675 -- obtain the element type of the parallel array produced by the given Core
678 parrElemType :: CoreExpr -> Type
680 case splitTyConApp_maybe (exprType e) of
681 Just (tycon, [ty]) | tycon == parrTyCon -> ty
683 "DsListComp.parrElemType: not a parallel array type"