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