Do not use defaulting in ambiguity check
[ghc.git] / compiler / deSugar / DsListComp.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Desugaring list comprehensions, monad comprehensions and array comprehensions
7 -}
8
9 {-# LANGUAGE CPP, NamedFieldPuns #-}
10
11 module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
12
13 #include "HsVersions.h"
14
15 import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr )
16
17 import HsSyn
18 import TcHsSyn
19 import CoreSyn
20 import MkCore
21
22 import DsMonad -- the monadery used in the desugarer
23 import DsUtils
24
25 import DynFlags
26 import CoreUtils
27 import Id
28 import Type
29 import TysWiredIn
30 import Match
31 import PrelNames
32 import SrcLoc
33 import Outputable
34 import TcType
35 import ListSetOps( getNth )
36 import Util
37
38 {-
39 List comprehensions may be desugared in one of two ways: ``ordinary''
40 (as you would expect if you read SLPJ's book) and ``with foldr/build
41 turned on'' (if you read Gill {\em et al.}'s paper on the subject).
42
43 There will be at least one ``qualifier'' in the input.
44 -}
45
46 dsListComp :: [ExprLStmt Id]
47 -> Type -- Type of entire list
48 -> DsM CoreExpr
49 dsListComp lquals res_ty = do
50 dflags <- getDynFlags
51 let quals = map unLoc lquals
52 elt_ty = case tcTyConAppArgs res_ty of
53 [elt_ty] -> elt_ty
54 _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
55
56 if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags
57 -- Either rules are switched off, or we are ignoring what there are;
58 -- Either way foldr/build won't happen, so use the more efficient
59 -- Wadler-style desugaring
60 || isParallelComp quals
61 -- Foldr-style desugaring can't handle parallel list comprehensions
62 then deListComp quals (mkNilExpr elt_ty)
63 else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
64 -- Foldr/build should be enabled, so desugar
65 -- into foldrs and builds
66
67 where
68 -- We must test for ParStmt anywhere, not just at the head, because an extension
69 -- to list comprehensions would be to add brackets to specify the associativity
70 -- of qualifier lists. This is really easy to do by adding extra ParStmts into the
71 -- mix of possibly a single element in length, so we do this to leave the possibility open
72 isParallelComp = any isParallelStmt
73
74 isParallelStmt (ParStmt {}) = True
75 isParallelStmt _ = False
76
77
78 -- This function lets you desugar a inner list comprehension and a list of the binders
79 -- of that comprehension that we need in the outer comprehension into such an expression
80 -- and the type of the elements that it outputs (tuples of binders)
81 dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type)
82 dsInnerListComp (ParStmtBlock stmts bndrs _)
83 = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
84
85 -- really use original bndrs below!
86 ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)])
87 (mkListTy bndrs_tuple_type)
88
89 ; return (expr, bndrs_tuple_type) }
90
91 -- This function factors out commonality between the desugaring strategies for GroupStmt.
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 dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id)
95 dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
96 , trS_by = by, trS_using = using }) = do
97 let (from_bndrs, to_bndrs) = unzip binderMap
98
99 let from_bndrs_tys = map idType from_bndrs
100 to_bndrs_tys = map idType to_bndrs
101
102 to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
103
104 -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
105 (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)
106
107 -- Work out what arguments should be supplied to that expression: i.e. is an extraction
108 -- function required? If so, create that desugared function and add to arguments
109 usingExpr' <- dsLExpr using
110 usingArgs' <- case by of
111 Nothing -> return [expr']
112 Just by_e -> do { by_e' <- dsLExpr by_e
113 ; lam' <- matchTuple from_bndrs by_e'
114 ; return [lam', expr'] }
115
116 -- Create an unzip function for the appropriate arity and element types and find "map"
117 unzip_stuff' <- mkUnzipBind form from_bndrs_tys
118 map_id <- dsLookupGlobalId mapName
119
120 -- Generate the expressions to build the grouped list
121 let -- First we apply the grouping function to the inner list
122 inner_list_expr' = mkApps usingExpr' usingArgs'
123 -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
124 -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
125 -- the "b" to be a tuple of "to" lists!
126 -- Then finally we bind the unzip function around that expression
127 bound_unzipped_inner_list_expr'
128 = case unzip_stuff' of
129 Nothing -> inner_list_expr'
130 Just (unzip_fn', unzip_rhs') ->
131 Let (Rec [(unzip_fn', unzip_rhs')]) $
132 mkApps (Var map_id) $
133 [ Type (mkListTy from_tup_ty)
134 , Type to_bndrs_tup_ty
135 , Var unzip_fn'
136 , inner_list_expr' ]
137
138 -- Build a pattern that ensures the consumer binds into the NEW binders,
139 -- which hold lists rather than single values
140 let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '!
141 return (bound_unzipped_inner_list_expr', pat)
142
143 dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"
144
145 {-
146 ************************************************************************
147 * *
148 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
149 * *
150 ************************************************************************
151
152 Just as in Phil's chapter~7 in SLPJ, using the rules for
153 optimally-compiled list comprehensions. This is what Kevin followed
154 as well, and I quite happily do the same. The TQ translation scheme
155 transforms a list of qualifiers (either boolean expressions or
156 generators) into a single expression which implements the list
157 comprehension. Because we are generating 2nd-order polymorphic
158 lambda-calculus, calls to NIL and CONS must be applied to a type
159 argument, as well as their usual value arguments.
160 \begin{verbatim}
161 TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >>
162
163 (Rule C)
164 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
165
166 (Rule B)
167 TQ << [ e | b , qs ] ++ L >> =
168 if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
169
170 (Rule A')
171 TQ << [ e | p <- L1, qs ] ++ L2 >> =
172 letrec
173 h = \ u1 ->
174 case u1 of
175 [] -> TE << L2 >>
176 (u2 : u3) ->
177 (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2)
178 [] (h u3)
179 in
180 h ( TE << L1 >> )
181
182 "h", "u1", "u2", and "u3" are new variables.
183 \end{verbatim}
184
185 @deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@
186 is the TE translation scheme. Note that we carry around the @L@ list
187 already desugared. @dsListComp@ does the top TE rule mentioned above.
188
189 To the above, we add an additional rule to deal with parallel list
190 comprehensions. The translation goes roughly as follows:
191 [ e | p1 <- e11, let v1 = e12, p2 <- e13
192 | q1 <- e21, let v2 = e22, q2 <- e23]
193 =>
194 [ e | ((x1, .., xn), (y1, ..., ym)) <-
195 zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
196 [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
197 where (x1, .., xn) are the variables bound in p1, v1, p2
198 (y1, .., ym) are the variables bound in q1, v2, q2
199
200 In the translation below, the ParStmt branch translates each parallel branch
201 into a sub-comprehension, and desugars each independently. The resulting lists
202 are fed to a zip function, we create a binding for all the variables bound in all
203 the comprehensions, and then we hand things off the the desugarer for bindings.
204 The zip function is generated here a) because it's small, and b) because then we
205 don't have to deal with arbitrary limits on the number of zip functions in the
206 prelude, nor which library the zip function came from.
207 The introduced tuples are Boxed, but only because I couldn't get it to work
208 with the Unboxed variety.
209 -}
210
211 deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr
212
213 deListComp [] _ = panic "deListComp"
214
215 deListComp (LastStmt body _ _ : quals) list
216 = -- Figure 7.4, SLPJ, p 135, rule C above
217 ASSERT( null quals )
218 do { core_body <- dsLExpr body
219 ; return (mkConsExpr (exprType core_body) core_body list) }
220
221 -- Non-last: must be a guard
222 deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above
223 core_guard <- dsLExpr guard
224 core_rest <- deListComp quals list
225 return (mkIfThenElse core_guard core_rest list)
226
227 -- [e | let B, qs] = let B in [e | qs]
228 deListComp (LetStmt (L _ binds) : quals) list = do
229 core_rest <- deListComp quals list
230 dsLocalBinds binds core_rest
231
232 deListComp (stmt@(TransStmt {}) : quals) list = do
233 (inner_list_expr, pat) <- dsTransStmt stmt
234 deBindComp pat inner_list_expr quals list
235
236 deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above
237 core_list1 <- dsLExpr list1
238 deBindComp pat core_list1 quals core_list2
239
240 deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
241 = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
242 ; let (exps, qual_tys) = unzip exps_and_qual_tys
243
244 ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
245
246 -- Deal with [e | pat <- zip l1 .. ln] in example above
247 ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
248 quals list }
249 where
250 bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
251
252 -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
253 pat = mkBigLHsPatTupId pats
254 pats = map mkBigLHsVarPatTupId bndrs_s
255
256 deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
257
258 deListComp (ApplicativeStmt {} : _) _ =
259 panic "deListComp ApplicativeStmt"
260
261 deBindComp :: OutPat Id
262 -> CoreExpr
263 -> [ExprStmt Id]
264 -> CoreExpr
265 -> DsM (Expr Id)
266 deBindComp pat core_list1 quals core_list2 = do
267 let u3_ty@u1_ty = exprType core_list1 -- two names, same thing
268
269 -- u1_ty is a [alpha] type, and u2_ty = alpha
270 let u2_ty = hsLPatType pat
271
272 let res_ty = exprType core_list2
273 h_ty = u1_ty `mkFunTy` res_ty
274
275 [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
276
277 -- the "fail" value ...
278 let
279 core_fail = App (Var h) (Var u3)
280 letrec_body = App (Var h) core_list1
281
282 rest_expr <- deListComp quals core_fail
283 core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
284
285 let
286 rhs = Lam u1 $
287 Case (Var u1) u1 res_ty
288 [(DataAlt nilDataCon, [], core_list2),
289 (DataAlt consDataCon, [u2, u3], core_match)]
290 -- Increasing order of tag
291
292 return (Let (Rec [(h, rhs)]) letrec_body)
293
294 {-
295 ************************************************************************
296 * *
297 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
298 * *
299 ************************************************************************
300
301 @dfListComp@ are the rules used with foldr/build turned on:
302
303 \begin{verbatim}
304 TE[ e | ] c n = c e n
305 TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n
306 TE[ e | p <- l , q ] c n = let
307 f = \ x b -> case x of
308 p -> TE[ e | q ] c b
309 _ -> b
310 in
311 foldr f n l
312 \end{verbatim}
313 -}
314
315 dfListComp :: Id -> Id -- 'c' and 'n'
316 -> [ExprStmt Id] -- the rest of the qual's
317 -> DsM CoreExpr
318
319 dfListComp _ _ [] = panic "dfListComp"
320
321 dfListComp c_id n_id (LastStmt body _ _ : quals)
322 = ASSERT( null quals )
323 do { core_body <- dsLExpr body
324 ; return (mkApps (Var c_id) [core_body, Var n_id]) }
325
326 -- Non-last: must be a guard
327 dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do
328 core_guard <- dsLExpr guard
329 core_rest <- dfListComp c_id n_id quals
330 return (mkIfThenElse core_guard core_rest (Var n_id))
331
332 dfListComp c_id n_id (LetStmt (L _ binds) : quals) = do
333 -- new in 1.3, local bindings
334 core_rest <- dfListComp c_id n_id quals
335 dsLocalBinds binds core_rest
336
337 dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
338 (inner_list_expr, pat) <- dsTransStmt stmt
339 -- Anyway, we bind the newly grouped list via the generic binding function
340 dfBindComp c_id n_id (pat, inner_list_expr) quals
341
342 dfListComp c_id n_id (BindStmt pat list1 _ _ _ : quals) = do
343 -- evaluate the two lists
344 core_list1 <- dsLExpr list1
345
346 -- Do the rest of the work in the generic binding builder
347 dfBindComp c_id n_id (pat, core_list1) quals
348
349 dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
350 dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
351 dfListComp _ _ (ApplicativeStmt {} : _) =
352 panic "dfListComp ApplicativeStmt"
353
354 dfBindComp :: Id -> Id -- 'c' and 'n'
355 -> (LPat Id, CoreExpr)
356 -> [ExprStmt Id] -- the rest of the qual's
357 -> DsM CoreExpr
358 dfBindComp c_id n_id (pat, core_list1) quals = do
359 -- find the required type
360 let x_ty = hsLPatType pat
361 let b_ty = idType n_id
362
363 -- create some new local id's
364 [b, x] <- newSysLocalsDs [b_ty, x_ty]
365
366 -- build rest of the comprehesion
367 core_rest <- dfListComp c_id b quals
368
369 -- build the pattern match
370 core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
371 pat core_rest (Var b)
372
373 -- now build the outermost foldr, and return
374 mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
375
376 {-
377 ************************************************************************
378 * *
379 \subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
380 * *
381 ************************************************************************
382 -}
383
384 mkZipBind :: [Type] -> DsM (Id, CoreExpr)
385 -- mkZipBind [t1, t2]
386 -- = (zip, \as1:[t1] as2:[t2]
387 -- -> case as1 of
388 -- [] -> []
389 -- (a1:as'1) -> case as2 of
390 -- [] -> []
391 -- (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
392
393 mkZipBind elt_tys = do
394 ass <- mapM newSysLocalDs elt_list_tys
395 as' <- mapM newSysLocalDs elt_tys
396 as's <- mapM newSysLocalDs elt_list_tys
397
398 zip_fn <- newSysLocalDs zip_fn_ty
399
400 let inner_rhs = mkConsExpr elt_tuple_ty
401 (mkBigCoreVarTup as')
402 (mkVarApps (Var zip_fn) as's)
403 zip_body = foldr mk_case inner_rhs (zip3 ass as' as's)
404
405 return (zip_fn, mkLams ass zip_body)
406 where
407 elt_list_tys = map mkListTy elt_tys
408 elt_tuple_ty = mkBigCoreTupTy elt_tys
409 elt_tuple_list_ty = mkListTy elt_tuple_ty
410
411 zip_fn_ty = mkFunTys elt_list_tys elt_tuple_list_ty
412
413 mk_case (as, a', as') rest
414 = Case (Var as) as elt_tuple_list_ty
415 [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty),
416 (DataAlt consDataCon, [a', as'], rest)]
417 -- Increasing order of tag
418
419
420 mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
421 -- mkUnzipBind [t1, t2]
422 -- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
423 -- -> case ax of
424 -- (x1, x2) -> case axs of
425 -- (xs1, xs2) -> (x1 : xs1, x2 : xs2))
426 -- ([], [])
427 -- ys)
428 --
429 -- We use foldr here in all cases, even if rules are turned off, because we may as well!
430 mkUnzipBind ThenForm _
431 = return Nothing -- No unzipping for ThenForm
432 mkUnzipBind _ elt_tys
433 = do { ax <- newSysLocalDs elt_tuple_ty
434 ; axs <- newSysLocalDs elt_list_tuple_ty
435 ; ys <- newSysLocalDs elt_tuple_list_ty
436 ; xs <- mapM newSysLocalDs elt_tys
437 ; xss <- mapM newSysLocalDs elt_list_tys
438
439 ; unzip_fn <- newSysLocalDs unzip_fn_ty
440
441 ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
442
443 ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
444 concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
445 tupled_concat_expression = mkBigCoreTup concat_expressions
446
447 folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
448 folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
449 folder_body = mkLams [ax, axs] folder_body_outer_case
450
451 ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
452 ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
453 where
454 elt_tuple_ty = mkBigCoreTupTy elt_tys
455 elt_tuple_list_ty = mkListTy elt_tuple_ty
456 elt_list_tys = map mkListTy elt_tys
457 elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys
458
459 unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
460
461 mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
462
463 {-
464 ************************************************************************
465 * *
466 \subsection[DsPArrComp]{Desugaring of array comprehensions}
467 * *
468 ************************************************************************
469 -}
470
471 -- entry point for desugaring a parallel array comprehension
472 --
473 -- [:e | qss:] = <<[:e | qss:]>> () [:():]
474 --
475 dsPArrComp :: [ExprStmt Id]
476 -> DsM CoreExpr
477
478 -- Special case for parallel comprehension
479 dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
480
481 -- Special case for simple generators:
482 --
483 -- <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e
484 --
485 -- if matching again p cannot fail, or else
486 --
487 -- <<[:e' | p <- e, qs:]>> =
488 -- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
489 --
490 dsPArrComp (BindStmt p e _ _ _ : qs) = do
491 filterP <- dsDPHBuiltin filterPVar
492 ce <- dsLExpr e
493 let ety'ce = parrElemType ce
494 false = Var falseDataConId
495 true = Var trueDataConId
496 v <- newSysLocalDs ety'ce
497 pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
498 let gen | isIrrefutableHsPat p = ce
499 | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
500 dePArrComp qs p gen
501
502 dsPArrComp qs = do -- no ParStmt in `qs'
503 sglP <- dsDPHBuiltin singletonPVar
504 let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
505 dePArrComp qs (noLoc $ WildPat unitTy) unitArray
506
507
508
509 -- the work horse
510 --
511 dePArrComp :: [ExprStmt Id]
512 -> LPat Id -- the current generator pattern
513 -> CoreExpr -- the current generator expression
514 -> DsM CoreExpr
515
516 dePArrComp [] _ _ = panic "dePArrComp"
517
518 --
519 -- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
520 --
521 dePArrComp (LastStmt e' _ _ : quals) pa cea
522 = ASSERT( null quals )
523 do { mapP <- dsDPHBuiltin mapPVar
524 ; let ty = parrElemType cea
525 ; (clam, ty'e') <- deLambda ty pa e'
526 ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
527 --
528 -- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
529 --
530 dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do
531 filterP <- dsDPHBuiltin filterPVar
532 let ty = parrElemType cea
533 (clam,_) <- deLambda ty pa b
534 dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
535
536 --
537 -- <<[:e' | p <- e, qs:]>> pa ea =
538 -- let ef = \pa -> e
539 -- in
540 -- <<[:e' | qs:]>> (pa, p) (crossMap ea ef)
541 --
542 -- if matching again p cannot fail, or else
543 --
544 -- <<[:e' | p <- e, qs:]>> pa ea =
545 -- let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
546 -- in
547 -- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
548 --
549 dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do
550 filterP <- dsDPHBuiltin filterPVar
551 crossMapP <- dsDPHBuiltin crossMapPVar
552 ce <- dsLExpr e
553 let ety'cea = parrElemType cea
554 ety'ce = parrElemType ce
555 false = Var falseDataConId
556 true = Var trueDataConId
557 v <- newSysLocalDs ety'ce
558 pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
559 let cef | isIrrefutableHsPat p = ce
560 | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
561 (clam, _) <- mkLambda ety'cea pa cef
562 let ety'cef = ety'ce -- filter doesn't change the element type
563 pa' = mkLHsPatTup [pa, p]
564
565 dePArrComp qs pa' (mkApps (Var crossMapP)
566 [Type ety'cea, Type ety'cef, cea, clam])
567 --
568 -- <<[:e' | let ds, qs:]>> pa ea =
569 -- <<[:e' | qs:]>> (pa, (x_1, ..., x_n))
570 -- (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)
571 -- where
572 -- {x_1, ..., x_n} = DV (ds) -- Defined Variables
573 --
574 dePArrComp (LetStmt (L _ ds) : qs) pa cea = do
575 mapP <- dsDPHBuiltin mapPVar
576 let xs = collectLocalBinders ds
577 ty'cea = parrElemType cea
578 v <- newSysLocalDs ty'cea
579 clet <- dsLocalBinds ds (mkCoreTup (map Var xs))
580 let'v <- newSysLocalDs (exprType clet)
581 let projBody = mkCoreLet (NonRec let'v clet) $
582 mkCoreTup [Var v, Var let'v]
583 errTy = exprType projBody
584 errMsg = text "DsListComp.dePArrComp: internal error!"
585 cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg
586 ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
587 let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
588 proj = mkLams [v] ccase
589 dePArrComp qs pa' (mkApps (Var mapP)
590 [Type ty'cea, Type errTy, proj, cea])
591 --
592 -- The parser guarantees that parallel comprehensions can only appear as
593 -- singleton qualifier lists, which we already special case in the caller.
594 -- So, encountering one here is a bug.
595 --
596 dePArrComp (ParStmt {} : _) _ _ =
597 panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"
598 dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"
599 dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
600 dePArrComp (ApplicativeStmt {} : _) _ _ =
601 panic "DsListComp.dePArrComp: ApplicativeStmt"
602
603 -- <<[:e' | qs | qss:]>> pa ea =
604 -- <<[:e' | qss:]>> (pa, (x_1, ..., x_n))
605 -- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
606 -- where
607 -- {x_1, ..., x_n} = DV (qs)
608 --
609 dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr
610 dePArrParComp qss quals = do
611 (pQss, ceQss) <- deParStmt qss
612 dePArrComp quals pQss ceQss
613 where
614 deParStmt [] =
615 -- empty parallel statement lists have no source representation
616 panic "DsListComp.dePArrComp: Empty parallel list comprehension"
617 deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement
618 let res_expr = mkLHsVarTuple xs
619 cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
620 parStmts qss (mkLHsVarPatTup xs) cqs
621 ---
622 parStmts [] pa cea = return (pa, cea)
623 parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed)
624 zipP <- dsDPHBuiltin zipPVar
625 let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
626 ty'cea = parrElemType cea
627 res_expr = mkLHsVarTuple xs
628 cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
629 let ty'cqs = parrElemType cqs
630 cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
631 parStmts qss pa' cea'
632
633 -- generate Core corresponding to `\p -> e'
634 --
635 deLambda :: Type -- type of the argument
636 -> LPat Id -- argument pattern
637 -> LHsExpr Id -- body
638 -> DsM (CoreExpr, Type)
639 deLambda ty p e =
640 mkLambda ty p =<< dsLExpr e
641
642 -- generate Core for a lambda pattern match, where the body is already in Core
643 --
644 mkLambda :: Type -- type of the argument
645 -> LPat Id -- argument pattern
646 -> CoreExpr -- desugared body
647 -> DsM (CoreExpr, Type)
648 mkLambda ty p ce = do
649 v <- newSysLocalDs ty
650 let errMsg = text "DsListComp.deLambda: internal error!"
651 ce'ty = exprType ce
652 cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg
653 res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr
654 return (mkLams [v] res, ce'ty)
655
656 -- obtain the element type of the parallel array produced by the given Core
657 -- expression
658 --
659 parrElemType :: CoreExpr -> Type
660 parrElemType e =
661 case splitTyConApp_maybe (exprType e) of
662 Just (tycon, [ty]) | tycon == parrTyCon -> ty
663 _ -> panic
664 "DsListComp.parrElemType: not a parallel array type"
665
666 -- Translation for monad comprehensions
667
668 -- Entry point for monad comprehension desugaring
669 dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr
670 dsMonadComp stmts = dsMcStmts stmts
671
672 dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr
673 dsMcStmts [] = panic "dsMcStmts"
674 dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
675
676 ---------------
677 dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr
678
679 dsMcStmt (LastStmt body _ ret_op) stmts
680 = ASSERT( null stmts )
681 do { body' <- dsLExpr body
682 ; dsSyntaxExpr ret_op [body'] }
683
684 -- [ .. | let binds, stmts ]
685 dsMcStmt (LetStmt (L _ binds)) stmts
686 = do { rest <- dsMcStmts stmts
687 ; dsLocalBinds binds rest }
688
689 -- [ .. | a <- m, stmts ]
690 dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts
691 = do { rhs' <- dsLExpr rhs
692 ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
693
694 -- Apply `guard` to the `exp` expression
695 --
696 -- [ .. | exp, stmts ]
697 --
698 dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
699 = do { exp' <- dsLExpr exp
700 ; rest <- dsMcStmts stmts
701 ; guard_exp' <- dsSyntaxExpr guard_exp [exp']
702 ; dsSyntaxExpr then_exp [guard_exp', rest] }
703
704 -- Group statements desugar like this:
705 --
706 -- [| (q, then group by e using f); rest |]
707 -- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
708 -- case unzip n_tup of qv' -> [| rest |]
709 --
710 -- where variables (v1:t1, ..., vk:tk) are bound by q
711 -- qv = (v1, ..., vk)
712 -- qt = (t1, ..., tk)
713 -- (>>=) :: m2 a -> (a -> m3 b) -> m3 b
714 -- f :: forall a. (a -> t) -> m1 a -> m2 (n a)
715 -- n_tup :: n qt
716 -- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n)
717
718 dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
719 , trS_by = by, trS_using = using
720 , trS_ret = return_op, trS_bind = bind_op
721 , trS_bind_arg_ty = n_tup_ty' -- n (a,b,c)
722 , trS_fmap = fmap_op, trS_form = form }) stmts_rest
723 = do { let (from_bndrs, to_bndrs) = unzip bndrs
724
725 ; let from_bndr_tys = map idType from_bndrs -- Types ty
726
727
728 -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
729 ; expr' <- dsInnerMonadComp stmts from_bndrs return_op
730
731 -- Work out what arguments should be supplied to that expression: i.e. is an extraction
732 -- function required? If so, create that desugared function and add to arguments
733 ; usingExpr' <- dsLExpr using
734 ; usingArgs' <- case by of
735 Nothing -> return [expr']
736 Just by_e -> do { by_e' <- dsLExpr by_e
737 ; lam' <- matchTuple from_bndrs by_e'
738 ; return [lam', expr'] }
739
740 -- Generate the expressions to build the grouped list
741 -- Build a pattern that ensures the consumer binds into the NEW binders,
742 -- which hold monads rather than single values
743 ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs
744
745 ; body <- dsMcStmts stmts_rest
746 ; n_tup_var' <- newSysLocalDs n_tup_ty'
747 ; tup_n_var' <- newSysLocalDs tup_n_ty'
748 ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
749 ; us <- newUniqueSupply
750 ; let rhs' = mkApps usingExpr' usingArgs'
751 body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'
752
753 ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
754
755 -- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
756 -- statements, for example:
757 --
758 -- [ body | qs1 | qs2 | qs3 ]
759 -- -> [ body | (bndrs1, (bndrs2, bndrs3))
760 -- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
761 --
762 -- where `mzip` has type
763 -- mzip :: forall a b. m a -> m b -> m (a,b)
764 -- NB: we need a polymorphic mzip because we call it several times
765
766 dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
767 = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty)
768 ; mzip_op' <- dsExpr mzip_op
769
770 ; let -- The pattern variables
771 pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]
772 -- Pattern with tuples of variables
773 -- [v1,v2,v3] => (v1, (v2, v3))
774 pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
775 (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
776 (mkApps mzip_op' [Type t1, Type t2, e1, e2],
777 mkBoxedTupleTy [t1,t2]))
778 exps_w_tys
779
780 ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
781 where
782 ds_inner (ParStmtBlock stmts bndrs return_op)
783 = do { exp <- dsInnerMonadComp stmts bndrs return_op
784 ; return (exp, mkBigCoreVarTupTy bndrs) }
785
786 dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
787
788
789 matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
790 -- (matchTuple [a,b,c] body)
791 -- returns the Core term
792 -- \x. case x of (a,b,c) -> body
793 matchTuple ids body
794 = do { us <- newUniqueSupply
795 ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
796 ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
797
798 -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
799 -- desugared `CoreExpr`
800 dsMcBindStmt :: LPat Id
801 -> CoreExpr -- ^ the desugared rhs of the bind statement
802 -> SyntaxExpr Id
803 -> SyntaxExpr Id
804 -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T
805 -> [ExprLStmt Id]
806 -> DsM CoreExpr
807 dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
808 = do { body <- dsMcStmts stmts
809 ; var <- selectSimpleMatchVarL pat
810 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
811 res1_ty (cantFailMatchResult body)
812 ; match_code <- handle_failure pat match fail_op
813 ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
814
815 where
816 -- In a monad comprehension expression, pattern-match failure just calls
817 -- the monadic `fail` rather than throwing an exception
818 handle_failure pat match fail_op
819 | matchCanFail match
820 = do { dflags <- getDynFlags
821 ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
822 ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
823 ; extractMatchResult match fail_expr }
824 | otherwise
825 = extractMatchResult match (error "It can't fail")
826
827 mk_fail_msg :: DynFlags -> Located e -> String
828 mk_fail_msg dflags pat
829 = "Pattern match failure in monad comprehension at " ++
830 showPpr dflags (getLoc pat)
831
832 -- Desugar nested monad comprehensions, for example in `then..` constructs
833 -- dsInnerMonadComp quals [a,b,c] ret_op
834 -- returns the desugaring of
835 -- [ (a,b,c) | quals ]
836
837 dsInnerMonadComp :: [ExprLStmt Id]
838 -> [Id] -- Return a tuple of these variables
839 -> SyntaxExpr Id -- The monomorphic "return" operator
840 -> DsM CoreExpr
841 dsInnerMonadComp stmts bndrs ret_op
842 = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)])
843
844 -- The `unzip` function for `GroupStmt` in a monad comprehensions
845 --
846 -- unzip :: m (a,b,..) -> (m a,m b,..)
847 -- unzip m_tuple = ( liftM selN1 m_tuple
848 -- , liftM selN2 m_tuple
849 -- , .. )
850 --
851 -- mkMcUnzipM fmap ys [t1, t2]
852 -- = ( fmap (selN1 :: (t1, t2) -> t1) ys
853 -- , fmap (selN2 :: (t1, t2) -> t2) ys )
854
855 mkMcUnzipM :: TransForm
856 -> HsExpr TcId -- fmap
857 -> Id -- Of type n (a,b,c)
858 -> [Type] -- [a,b,c]
859 -> DsM CoreExpr -- Of type (n a, n b, n c)
860 mkMcUnzipM ThenForm _ ys _
861 = return (Var ys) -- No unzipping to do
862
863 mkMcUnzipM _ fmap_op ys elt_tys
864 = do { fmap_op' <- dsExpr fmap_op
865 ; xs <- mapM newSysLocalDs elt_tys
866 ; let tup_ty = mkBigCoreTupTy elt_tys
867 ; tup_xs <- newSysLocalDs tup_ty
868
869 ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b
870 [ Type tup_ty, Type (getNth elt_tys i)
871 , mk_sel i, Var ys]
872
873 mk_sel n = Lam tup_xs $
874 mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)
875
876 ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }