Fix comment typos
[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 {-# LANGUAGE TypeFamilies #-}
11 {-# LANGUAGE ViewPatterns #-}
12
13 module DsListComp ( dsListComp, dsMonadComp ) where
14
15 #include "HsVersions.h"
16
17 import GhcPrelude
18
19 import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
20
21 import GHC.Hs
22 import TcHsSyn
23 import CoreSyn
24 import MkCore
25
26 import DsMonad -- the monadery used in the desugarer
27 import DsUtils
28
29 import DynFlags
30 import CoreUtils
31 import Id
32 import Type
33 import TysWiredIn
34 import Match
35 import PrelNames
36 import SrcLoc
37 import Outputable
38 import TcType
39 import ListSetOps( getNth )
40 import Util
41
42 {-
43 List comprehensions may be desugared in one of two ways: ``ordinary''
44 (as you would expect if you read SLPJ's book) and ``with foldr/build
45 turned on'' (if you read Gill {\em et al.}'s paper on the subject).
46
47 There will be at least one ``qualifier'' in the input.
48 -}
49
50 dsListComp :: [ExprLStmt GhcTc]
51 -> Type -- Type of entire list
52 -> DsM CoreExpr
53 dsListComp lquals res_ty = do
54 dflags <- getDynFlags
55 let quals = map unLoc lquals
56 elt_ty = case tcTyConAppArgs res_ty of
57 [elt_ty] -> elt_ty
58 _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
59
60 if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags
61 -- Either rules are switched off, or we are ignoring what there are;
62 -- Either way foldr/build won't happen, so use the more efficient
63 -- Wadler-style desugaring
64 || isParallelComp quals
65 -- Foldr-style desugaring can't handle parallel list comprehensions
66 then deListComp quals (mkNilExpr elt_ty)
67 else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
68 -- Foldr/build should be enabled, so desugar
69 -- into foldrs and builds
70
71 where
72 -- We must test for ParStmt anywhere, not just at the head, because an extension
73 -- to list comprehensions would be to add brackets to specify the associativity
74 -- of qualifier lists. This is really easy to do by adding extra ParStmts into the
75 -- mix of possibly a single element in length, so we do this to leave the possibility open
76 isParallelComp = any isParallelStmt
77
78 isParallelStmt (ParStmt {}) = True
79 isParallelStmt _ = False
80
81
82 -- This function lets you desugar a inner list comprehension and a list of the binders
83 -- of that comprehension that we need in the outer comprehension into such an expression
84 -- and the type of the elements that it outputs (tuples of binders)
85 dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
86 dsInnerListComp (ParStmtBlock _ stmts bndrs _)
87 = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
88 list_ty = mkListTy bndrs_tuple_type
89
90 -- really use original bndrs below!
91 ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
92
93 ; return (expr, bndrs_tuple_type) }
94 dsInnerListComp (XParStmtBlock nec) = noExtCon nec
95
96 -- This function factors out commonality between the desugaring strategies for GroupStmt.
97 -- Given such a statement it gives you back an expression representing how to compute the transformed
98 -- list and the tuple that you need to bind from that list in order to proceed with your desugaring
99 dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc)
100 dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
101 , trS_by = by, trS_using = using }) = do
102 let (from_bndrs, to_bndrs) = unzip binderMap
103
104 let from_bndrs_tys = map idType from_bndrs
105 to_bndrs_tys = map idType to_bndrs
106
107 to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
108
109 -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
110 (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts
111 from_bndrs noSyntaxExpr)
112
113 -- Work out what arguments should be supplied to that expression: i.e. is an extraction
114 -- function required? If so, create that desugared function and add to arguments
115 usingExpr' <- dsLExpr using
116 usingArgs' <- case by of
117 Nothing -> return [expr']
118 Just by_e -> do { by_e' <- dsLExpr by_e
119 ; lam' <- matchTuple from_bndrs by_e'
120 ; return [lam', expr'] }
121
122 -- Create an unzip function for the appropriate arity and element types and find "map"
123 unzip_stuff' <- mkUnzipBind form from_bndrs_tys
124 map_id <- dsLookupGlobalId mapName
125
126 -- Generate the expressions to build the grouped list
127 let -- First we apply the grouping function to the inner list
128 inner_list_expr' = mkApps usingExpr' usingArgs'
129 -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
130 -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
131 -- the "b" to be a tuple of "to" lists!
132 -- Then finally we bind the unzip function around that expression
133 bound_unzipped_inner_list_expr'
134 = case unzip_stuff' of
135 Nothing -> inner_list_expr'
136 Just (unzip_fn', unzip_rhs') ->
137 Let (Rec [(unzip_fn', unzip_rhs')]) $
138 mkApps (Var map_id) $
139 [ Type (mkListTy from_tup_ty)
140 , Type to_bndrs_tup_ty
141 , Var unzip_fn'
142 , inner_list_expr' ]
143
144 dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))
145 (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)
146
147 -- Build a pattern that ensures the consumer binds into the NEW binders,
148 -- which hold lists rather than single values
149 let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '!
150 return (bound_unzipped_inner_list_expr', pat)
151
152 dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"
153
154 {-
155 ************************************************************************
156 * *
157 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
158 * *
159 ************************************************************************
160
161 Just as in Phil's chapter~7 in SLPJ, using the rules for
162 optimally-compiled list comprehensions. This is what Kevin followed
163 as well, and I quite happily do the same. The TQ translation scheme
164 transforms a list of qualifiers (either boolean expressions or
165 generators) into a single expression which implements the list
166 comprehension. Because we are generating 2nd-order polymorphic
167 lambda-calculus, calls to NIL and CONS must be applied to a type
168 argument, as well as their usual value arguments.
169 \begin{verbatim}
170 TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >>
171
172 (Rule C)
173 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
174
175 (Rule B)
176 TQ << [ e | b , qs ] ++ L >> =
177 if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
178
179 (Rule A')
180 TQ << [ e | p <- L1, qs ] ++ L2 >> =
181 letrec
182 h = \ u1 ->
183 case u1 of
184 [] -> TE << L2 >>
185 (u2 : u3) ->
186 (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2)
187 [] (h u3)
188 in
189 h ( TE << L1 >> )
190
191 "h", "u1", "u2", and "u3" are new variables.
192 \end{verbatim}
193
194 @deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@
195 is the TE translation scheme. Note that we carry around the @L@ list
196 already desugared. @dsListComp@ does the top TE rule mentioned above.
197
198 To the above, we add an additional rule to deal with parallel list
199 comprehensions. The translation goes roughly as follows:
200 [ e | p1 <- e11, let v1 = e12, p2 <- e13
201 | q1 <- e21, let v2 = e22, q2 <- e23]
202 =>
203 [ e | ((x1, .., xn), (y1, ..., ym)) <-
204 zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
205 [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
206 where (x1, .., xn) are the variables bound in p1, v1, p2
207 (y1, .., ym) are the variables bound in q1, v2, q2
208
209 In the translation below, the ParStmt branch translates each parallel branch
210 into a sub-comprehension, and desugars each independently. The resulting lists
211 are fed to a zip function, we create a binding for all the variables bound in all
212 the comprehensions, and then we hand things off the desugarer for bindings.
213 The zip function is generated here a) because it's small, and b) because then we
214 don't have to deal with arbitrary limits on the number of zip functions in the
215 prelude, nor which library the zip function came from.
216 The introduced tuples are Boxed, but only because I couldn't get it to work
217 with the Unboxed variety.
218 -}
219
220 deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr
221
222 deListComp [] _ = panic "deListComp"
223
224 deListComp (LastStmt _ body _ _ : quals) list
225 = -- Figure 7.4, SLPJ, p 135, rule C above
226 ASSERT( null quals )
227 do { core_body <- dsLExpr body
228 ; return (mkConsExpr (exprType core_body) core_body list) }
229
230 -- Non-last: must be a guard
231 deListComp (BodyStmt _ guard _ _ : quals) list = do -- rule B above
232 core_guard <- dsLExpr guard
233 core_rest <- deListComp quals list
234 return (mkIfThenElse core_guard core_rest list)
235
236 -- [e | let B, qs] = let B in [e | qs]
237 deListComp (LetStmt _ binds : quals) list = do
238 core_rest <- deListComp quals list
239 dsLocalBinds binds core_rest
240
241 deListComp (stmt@(TransStmt {}) : quals) list = do
242 (inner_list_expr, pat) <- dsTransStmt stmt
243 deBindComp pat inner_list_expr quals list
244
245 deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above
246 core_list1 <- dsLExprNoLP list1
247 deBindComp pat core_list1 quals core_list2
248
249 deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
250 = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
251 ; let (exps, qual_tys) = unzip exps_and_qual_tys
252
253 ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
254
255 -- Deal with [e | pat <- zip l1 .. ln] in example above
256 ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
257 quals list }
258 where
259 bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]
260
261 -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
262 pat = mkBigLHsPatTupId pats
263 pats = map mkBigLHsVarPatTupId bndrs_s
264
265 deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
266
267 deListComp (ApplicativeStmt {} : _) _ =
268 panic "deListComp ApplicativeStmt"
269
270 deListComp (XStmtLR nec : _) _ =
271 noExtCon nec
272
273 deBindComp :: OutPat GhcTc
274 -> CoreExpr
275 -> [ExprStmt GhcTc]
276 -> CoreExpr
277 -> DsM (Expr Id)
278 deBindComp pat core_list1 quals core_list2 = do
279 let u3_ty@u1_ty = exprType core_list1 -- two names, same thing
280
281 -- u1_ty is a [alpha] type, and u2_ty = alpha
282 let u2_ty = hsLPatType pat
283
284 let res_ty = exprType core_list2
285 h_ty = u1_ty `mkVisFunTy` res_ty
286
287 -- no levity polymorphism here, as list comprehensions don't work
288 -- with RebindableSyntax. NB: These are *not* monad comps.
289 [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
290
291 -- the "fail" value ...
292 let
293 core_fail = App (Var h) (Var u3)
294 letrec_body = App (Var h) core_list1
295
296 rest_expr <- deListComp quals core_fail
297 core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
298
299 let
300 rhs = Lam u1 $
301 Case (Var u1) u1 res_ty
302 [(DataAlt nilDataCon, [], core_list2),
303 (DataAlt consDataCon, [u2, u3], core_match)]
304 -- Increasing order of tag
305
306 return (Let (Rec [(h, rhs)]) letrec_body)
307
308 {-
309 ************************************************************************
310 * *
311 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
312 * *
313 ************************************************************************
314
315 @dfListComp@ are the rules used with foldr/build turned on:
316
317 \begin{verbatim}
318 TE[ e | ] c n = c e n
319 TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n
320 TE[ e | p <- l , q ] c n = let
321 f = \ x b -> case x of
322 p -> TE[ e | q ] c b
323 _ -> b
324 in
325 foldr f n l
326 \end{verbatim}
327 -}
328
329 dfListComp :: Id -> Id -- 'c' and 'n'
330 -> [ExprStmt GhcTc] -- the rest of the qual's
331 -> DsM CoreExpr
332
333 dfListComp _ _ [] = panic "dfListComp"
334
335 dfListComp c_id n_id (LastStmt _ body _ _ : quals)
336 = ASSERT( null quals )
337 do { core_body <- dsLExprNoLP body
338 ; return (mkApps (Var c_id) [core_body, Var n_id]) }
339
340 -- Non-last: must be a guard
341 dfListComp c_id n_id (BodyStmt _ guard _ _ : quals) = do
342 core_guard <- dsLExpr guard
343 core_rest <- dfListComp c_id n_id quals
344 return (mkIfThenElse core_guard core_rest (Var n_id))
345
346 dfListComp c_id n_id (LetStmt _ binds : quals) = do
347 -- new in 1.3, local bindings
348 core_rest <- dfListComp c_id n_id quals
349 dsLocalBinds binds core_rest
350
351 dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
352 (inner_list_expr, pat) <- dsTransStmt stmt
353 -- Anyway, we bind the newly grouped list via the generic binding function
354 dfBindComp c_id n_id (pat, inner_list_expr) quals
355
356 dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do
357 -- evaluate the two lists
358 core_list1 <- dsLExpr list1
359
360 -- Do the rest of the work in the generic binding builder
361 dfBindComp c_id n_id (pat, core_list1) quals
362
363 dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
364 dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
365 dfListComp _ _ (ApplicativeStmt {} : _) =
366 panic "dfListComp ApplicativeStmt"
367 dfListComp _ _ (XStmtLR nec : _) =
368 noExtCon nec
369
370 dfBindComp :: Id -> Id -- 'c' and 'n'
371 -> (LPat GhcTc, CoreExpr)
372 -> [ExprStmt GhcTc] -- the rest of the qual's
373 -> DsM CoreExpr
374 dfBindComp c_id n_id (pat, core_list1) quals = do
375 -- find the required type
376 let x_ty = hsLPatType pat
377 let b_ty = idType n_id
378
379 -- create some new local id's
380 b <- newSysLocalDs b_ty
381 x <- newSysLocalDs x_ty
382
383 -- build rest of the comprehesion
384 core_rest <- dfListComp c_id b quals
385
386 -- build the pattern match
387 core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
388 pat core_rest (Var b)
389
390 -- now build the outermost foldr, and return
391 mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
392
393 {-
394 ************************************************************************
395 * *
396 \subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
397 * *
398 ************************************************************************
399 -}
400
401 mkZipBind :: [Type] -> DsM (Id, CoreExpr)
402 -- mkZipBind [t1, t2]
403 -- = (zip, \as1:[t1] as2:[t2]
404 -- -> case as1 of
405 -- [] -> []
406 -- (a1:as'1) -> case as2 of
407 -- [] -> []
408 -- (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
409
410 mkZipBind elt_tys = do
411 ass <- mapM newSysLocalDs elt_list_tys
412 as' <- mapM newSysLocalDs elt_tys
413 as's <- mapM newSysLocalDs elt_list_tys
414
415 zip_fn <- newSysLocalDs zip_fn_ty
416
417 let inner_rhs = mkConsExpr elt_tuple_ty
418 (mkBigCoreVarTup as')
419 (mkVarApps (Var zip_fn) as's)
420 zip_body = foldr mk_case inner_rhs (zip3 ass as' as's)
421
422 return (zip_fn, mkLams ass zip_body)
423 where
424 elt_list_tys = map mkListTy elt_tys
425 elt_tuple_ty = mkBigCoreTupTy elt_tys
426 elt_tuple_list_ty = mkListTy elt_tuple_ty
427
428 zip_fn_ty = mkVisFunTys elt_list_tys elt_tuple_list_ty
429
430 mk_case (as, a', as') rest
431 = Case (Var as) as elt_tuple_list_ty
432 [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty),
433 (DataAlt consDataCon, [a', as'], rest)]
434 -- Increasing order of tag
435
436
437 mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
438 -- mkUnzipBind [t1, t2]
439 -- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
440 -- -> case ax of
441 -- (x1, x2) -> case axs of
442 -- (xs1, xs2) -> (x1 : xs1, x2 : xs2))
443 -- ([], [])
444 -- ys)
445 --
446 -- We use foldr here in all cases, even if rules are turned off, because we may as well!
447 mkUnzipBind ThenForm _
448 = return Nothing -- No unzipping for ThenForm
449 mkUnzipBind _ elt_tys
450 = do { ax <- newSysLocalDs elt_tuple_ty
451 ; axs <- newSysLocalDs elt_list_tuple_ty
452 ; ys <- newSysLocalDs elt_tuple_list_ty
453 ; xs <- mapM newSysLocalDs elt_tys
454 ; xss <- mapM newSysLocalDs elt_list_tys
455
456 ; unzip_fn <- newSysLocalDs unzip_fn_ty
457
458 ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
459
460 ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
461 concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
462 tupled_concat_expression = mkBigCoreTup concat_expressions
463
464 folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
465 folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
466 folder_body = mkLams [ax, axs] folder_body_outer_case
467
468 ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
469 ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
470 where
471 elt_tuple_ty = mkBigCoreTupTy elt_tys
472 elt_tuple_list_ty = mkListTy elt_tuple_ty
473 elt_list_tys = map mkListTy elt_tys
474 elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys
475
476 unzip_fn_ty = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty
477
478 mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
479
480 -- Translation for monad comprehensions
481
482 -- Entry point for monad comprehension desugaring
483 dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr
484 dsMonadComp stmts = dsMcStmts stmts
485
486 dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr
487 dsMcStmts [] = panic "dsMcStmts"
488 dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
489
490 ---------------
491 dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
492
493 dsMcStmt (LastStmt _ body _ ret_op) stmts
494 = ASSERT( null stmts )
495 do { body' <- dsLExpr body
496 ; dsSyntaxExpr ret_op [body'] }
497
498 -- [ .. | let binds, stmts ]
499 dsMcStmt (LetStmt _ binds) stmts
500 = do { rest <- dsMcStmts stmts
501 ; dsLocalBinds binds rest }
502
503 -- [ .. | a <- m, stmts ]
504 dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts
505 = do { rhs' <- dsLExpr rhs
506 ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
507
508 -- Apply `guard` to the `exp` expression
509 --
510 -- [ .. | exp, stmts ]
511 --
512 dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts
513 = do { exp' <- dsLExpr exp
514 ; rest <- dsMcStmts stmts
515 ; guard_exp' <- dsSyntaxExpr guard_exp [exp']
516 ; dsSyntaxExpr then_exp [guard_exp', rest] }
517
518 -- Group statements desugar like this:
519 --
520 -- [| (q, then group by e using f); rest |]
521 -- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
522 -- case unzip n_tup of qv' -> [| rest |]
523 --
524 -- where variables (v1:t1, ..., vk:tk) are bound by q
525 -- qv = (v1, ..., vk)
526 -- qt = (t1, ..., tk)
527 -- (>>=) :: m2 a -> (a -> m3 b) -> m3 b
528 -- f :: forall a. (a -> t) -> m1 a -> m2 (n a)
529 -- n_tup :: n qt
530 -- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n)
531
532 dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
533 , trS_by = by, trS_using = using
534 , trS_ret = return_op, trS_bind = bind_op
535 , trS_ext = n_tup_ty' -- n (a,b,c)
536 , trS_fmap = fmap_op, trS_form = form }) stmts_rest
537 = do { let (from_bndrs, to_bndrs) = unzip bndrs
538
539 ; let from_bndr_tys = map idType from_bndrs -- Types ty
540
541
542 -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
543 ; expr' <- dsInnerMonadComp stmts from_bndrs return_op
544
545 -- Work out what arguments should be supplied to that expression: i.e. is an extraction
546 -- function required? If so, create that desugared function and add to arguments
547 ; usingExpr' <- dsLExpr using
548 ; usingArgs' <- case by of
549 Nothing -> return [expr']
550 Just by_e -> do { by_e' <- dsLExpr by_e
551 ; lam' <- matchTuple from_bndrs by_e'
552 ; return [lam', expr'] }
553
554 -- Generate the expressions to build the grouped list
555 -- Build a pattern that ensures the consumer binds into the NEW binders,
556 -- which hold monads rather than single values
557 ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs
558
559 ; body <- dsMcStmts stmts_rest
560 ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty'
561 ; tup_n_var' <- newSysLocalDs tup_n_ty'
562 ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
563 ; us <- newUniqueSupply
564 ; let rhs' = mkApps usingExpr' usingArgs'
565 body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'
566
567 ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
568
569 -- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
570 -- statements, for example:
571 --
572 -- [ body | qs1 | qs2 | qs3 ]
573 -- -> [ body | (bndrs1, (bndrs2, bndrs3))
574 -- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
575 --
576 -- where `mzip` has type
577 -- mzip :: forall a b. m a -> m b -> m (a,b)
578 -- NB: we need a polymorphic mzip because we call it several times
579
580 dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
581 = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty)
582 ; mzip_op' <- dsExpr mzip_op
583
584 ; let -- The pattern variables
585 pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]
586 -- Pattern with tuples of variables
587 -- [v1,v2,v3] => (v1, (v2, v3))
588 pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
589 (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
590 (mkApps mzip_op' [Type t1, Type t2, e1, e2],
591 mkBoxedTupleTy [t1,t2]))
592 exps_w_tys
593
594 ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
595 where
596 ds_inner (ParStmtBlock _ stmts bndrs return_op)
597 = do { exp <- dsInnerMonadComp stmts bndrs return_op
598 ; return (exp, mkBigCoreVarTupTy bndrs) }
599 ds_inner (XParStmtBlock nec) = noExtCon nec
600
601 dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
602
603
604 matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
605 -- (matchTuple [a,b,c] body)
606 -- returns the Core term
607 -- \x. case x of (a,b,c) -> body
608 matchTuple ids body
609 = do { us <- newUniqueSupply
610 ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
611 ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
612
613 -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
614 -- desugared `CoreExpr`
615 dsMcBindStmt :: LPat GhcTc
616 -> CoreExpr -- ^ the desugared rhs of the bind statement
617 -> SyntaxExpr GhcTc
618 -> SyntaxExpr GhcTc
619 -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T
620 -> [ExprLStmt GhcTc]
621 -> DsM CoreExpr
622 dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
623 = do { body <- dsMcStmts stmts
624 ; var <- selectSimpleMatchVarL pat
625 ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
626 res1_ty (cantFailMatchResult body)
627 ; match_code <- handle_failure pat match fail_op
628 ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
629
630 where
631 -- In a monad comprehension expression, pattern-match failure just calls
632 -- the monadic `fail` rather than throwing an exception
633 handle_failure pat match fail_op
634 | matchCanFail match
635 = do { dflags <- getDynFlags
636 ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
637 ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
638 ; extractMatchResult match fail_expr }
639 | otherwise
640 = extractMatchResult match (error "It can't fail")
641
642 mk_fail_msg :: DynFlags -> Located e -> String
643 mk_fail_msg dflags pat
644 = "Pattern match failure in monad comprehension at " ++
645 showPpr dflags (getLoc pat)
646
647 -- Desugar nested monad comprehensions, for example in `then..` constructs
648 -- dsInnerMonadComp quals [a,b,c] ret_op
649 -- returns the desugaring of
650 -- [ (a,b,c) | quals ]
651
652 dsInnerMonadComp :: [ExprLStmt GhcTc]
653 -> [Id] -- Return a tuple of these variables
654 -> SyntaxExpr GhcTc -- The monomorphic "return" operator
655 -> DsM CoreExpr
656 dsInnerMonadComp stmts bndrs ret_op
657 = dsMcStmts (stmts ++
658 [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) False ret_op)])
659
660
661 -- The `unzip` function for `GroupStmt` in a monad comprehensions
662 --
663 -- unzip :: m (a,b,..) -> (m a,m b,..)
664 -- unzip m_tuple = ( liftM selN1 m_tuple
665 -- , liftM selN2 m_tuple
666 -- , .. )
667 --
668 -- mkMcUnzipM fmap ys [t1, t2]
669 -- = ( fmap (selN1 :: (t1, t2) -> t1) ys
670 -- , fmap (selN2 :: (t1, t2) -> t2) ys )
671
672 mkMcUnzipM :: TransForm
673 -> HsExpr GhcTcId -- fmap
674 -> Id -- Of type n (a,b,c)
675 -> [Type] -- [a,b,c] (not levity-polymorphic)
676 -> DsM CoreExpr -- Of type (n a, n b, n c)
677 mkMcUnzipM ThenForm _ ys _
678 = return (Var ys) -- No unzipping to do
679
680 mkMcUnzipM _ fmap_op ys elt_tys
681 = do { fmap_op' <- dsExpr fmap_op
682 ; xs <- mapM newSysLocalDs elt_tys
683 ; let tup_ty = mkBigCoreTupTy elt_tys
684 ; tup_xs <- newSysLocalDs tup_ty
685
686 ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b
687 [ Type tup_ty, Type (getNth elt_tys i)
688 , mk_sel i, Var ys]
689
690 mk_sel n = Lam tup_xs $
691 mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)
692
693 ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }