DsListComp.lhs 17.7 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5 6

Desugaring list comprehensions and array comprehensions
7 8

\begin{code}
9
{-# OPTIONS -w #-}
10 11 12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 15
-- for details

chak's avatar
chak committed
16
module DsListComp ( dsListComp, dsPArrComp ) where
17

18 19
#include "HsVersions.h"

20
import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
21

Simon Marlow's avatar
Simon Marlow committed
22
import BasicTypes
23
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
24
import TcHsSyn
25
import CoreSyn
26

27
import DsMonad		-- the monadery used in the desugarer
28
import DsUtils
29

Simon Marlow's avatar
Simon Marlow committed
30 31 32 33 34 35 36 37 38 39 40
import DynFlags
import CoreUtils
import Var
import Type
import TysPrim
import TysWiredIn
import Match
import PrelNames
import PrelInfo
import SrcLoc
import Panic
41 42 43 44 45 46 47 48 49
\end{code}

List comprehensions may be desugared in one of two ways: ``ordinary''
(as you would expect if you read SLPJ's book) and ``with foldr/build
turned on'' (if you read Gill {\em et al.}'s paper on the subject).

There will be at least one ``qualifier'' in the input.

\begin{code}
50
dsListComp :: [LStmt Id] 
51
	   -> LHsExpr Id
52 53
	   -> Type		-- Type of list elements
	   -> DsM CoreExpr
54
dsListComp lquals body elt_ty
55
  = getDOptsDs  `thenDs` \dflags ->
56 57 58
    let
	quals = map unLoc lquals
    in
59
    if not (dopt Opt_RewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
60 61 62 63 64 65
	-- Either rules are switched off, or we are ignoring what there are;
	-- Either way foldr/build won't happen, so use the more efficient
	-- Wadler-style desugaring
  	|| isParallelComp quals
		-- Foldr-style desugaring can't handle
		-- parallel list comprehensions
66
  	then deListComp quals body (mkNilExpr elt_ty)
67

68 69 70
   else		-- Foldr/build should be enabled, so desugar 
		-- into foldrs and builds
    newTyVarsDs [alphaTyVar]    `thenDs` \ [n_tyvar] ->
71 72 73
    let
	n_ty = mkTyVarTy n_tyvar
        c_ty = mkFunTys [elt_ty, n_ty] n_ty
74
    in
75
    newSysLocalsDs [c_ty,n_ty]		`thenDs` \ [c, n] ->
76
    dfListComp c n quals body		`thenDs` \ result ->
77
    dsLookupGlobalId buildName	`thenDs` \ build_id ->
78 79
    returnDs (Var build_id `App` Type elt_ty 
			   `App` mkLams [n_tyvar, c, n] result)
80

81 82
  where isParallelComp (ParStmt bndrstmtss : _) = True
	isParallelComp _                        = False
83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
\end{code}

%************************************************************************
%*									*
\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
%*									*
%************************************************************************

Just as in Phil's chapter~7 in SLPJ, using the rules for
optimally-compiled list comprehensions.  This is what Kevin followed
as well, and I quite happily do the same.  The TQ translation scheme
transforms a list of qualifiers (either boolean expressions or
generators) into a single expression which implements the list
comprehension.  Because we are generating 2nd-order polymorphic
lambda-calculus, calls to NIL and CONS must be applied to a type
argument, as well as their usual value arguments.
\begin{verbatim}
TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>

(Rule C)
TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>

(Rule B)
TQ << [ e | b , qs ] ++ L >> =
    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>

(Rule A')
TQ << [ e | p <- L1, qs ]  ++  L2 >> =
  letrec
    h = \ u1 ->
    	  case u1 of
	    []        ->  TE << L2 >>
	    (u2 : u3) ->
		  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
		    [] (h u3)
  in
    h ( TE << L1 >> )

"h", "u1", "u2", and "u3" are new variables.
\end{verbatim}

@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
is the TE translation scheme.  Note that we carry around the @L@ list
already desugared.  @dsListComp@ does the top TE rule mentioned above.

128 129 130 131 132
To the above, we add an additional rule to deal with parallel list
comprehensions.  The translation goes roughly as follows:
     [ e | p1 <- e11, let v1 = e12, p2 <- e13
         | q1 <- e21, let v2 = e22, q2 <- e23]
     =>
133 134 135 136 137 138
     [ e | ((x1, .., xn), (y1, ..., ym)) <-
               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
where (x1, .., xn) are the variables bound in p1, v1, p2
      (y1, .., ym) are the variables bound in q1, v2, q2

139
In the translation below, the ParStmt branch translates each parallel branch
140 141 142 143 144 145 146 147
into a sub-comprehension, and desugars each independently.  The resulting lists
are fed to a zip function, we create a binding for all the variables bound in all
the comprehensions, and then we hand things off the the desugarer for bindings.
The zip function is generated here a) because it's small, and b) because then we
don't have to deal with arbitrary limits on the number of zip functions in the
prelude, nor which library the zip function came from.
The introduced tuples are Boxed, but only because I couldn't get it to work
with the Unboxed variety.
148

149
\begin{code}
150
deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
151

152
deListComp (ParStmt stmtss_w_bndrs : quals) body list
153
  = mappM do_list_comp stmtss_w_bndrs	`thenDs` \ exps ->
154 155 156 157
    mkZipBind qual_tys			`thenDs` \ (zip_fn, zip_rhs) ->

	-- Deal with [e | pat <- zip l1 .. ln] in example above
    deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) 
158
		   quals body list
159

160 161 162 163
  where 
	bndrs_s = map snd stmtss_w_bndrs

	-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
164
	pat	 = mkTuplePat pats
165
	pats	 = map mk_hs_tuple_pat bndrs_s
166 167

	-- Types of (x1,..,xn), (y1,..,yn) etc
168
	qual_tys = map mk_bndrs_tys bndrs_s
169

170
	do_list_comp (stmts, bndrs)
171
	  = dsListComp stmts (mk_hs_tuple_expr bndrs)
172 173
		       (mk_bndrs_tys bndrs)

174
	mk_bndrs_tys bndrs = mkCoreTupTy (map idType bndrs)
175

176
	-- Last: the one to return
177 178 179
deListComp [] body list		-- Figure 7.4, SLPJ, p 135, rule C above
  = dsLExpr body		`thenDs` \ core_body ->
    returnDs (mkConsExpr (exprType core_body) core_body list)
180

181
	-- Non-last: must be a guard
182
deListComp (ExprStmt guard _ _ : quals) body list	-- rule B above
183
  = dsLExpr guard      		`thenDs` \ core_guard ->
184
    deListComp quals body list	`thenDs` \ core_rest ->
185
    returnDs (mkIfThenElse core_guard core_rest list)
186

187
-- [e | let B, qs] = let B in [e | qs]
188 189
deListComp (LetStmt binds : quals) body list
  = deListComp quals body list	`thenDs` \ core_rest ->
190
    dsLocalBinds binds core_rest
191

192
deListComp (BindStmt pat list1 _ _ : quals) body core_list2 -- rule A' above
193
  = dsLExpr list1		    `thenDs` \ core_list1 ->
194
    deBindComp pat core_list1 quals body core_list2
195 196
\end{code}

197

198
\begin{code}
199
deBindComp pat core_list1 quals body core_list2
200
  = let
201
	u3_ty@u1_ty = exprType core_list1	-- two names, same thing
202 203

	-- u1_ty is a [alpha] type, and u2_ty = alpha
204
	u2_ty = hsLPatType pat
205

206
	res_ty = exprType core_list2
207
	h_ty   = u1_ty `mkFunTy` res_ty
208
    in
209
    newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]	`thenDs` \ [h, u1, u2, u3] ->
210

211
    -- the "fail" value ...
212 213 214 215
    let
	core_fail   = App (Var h) (Var u3)
	letrec_body = App (Var h) core_list1
    in
216
    deListComp quals body core_fail		`thenDs` \ rest_expr ->
217
    matchSimply (Var u2) (StmtCtxt ListComp) pat
218
		rest_expr core_fail		`thenDs` \ core_match ->
219 220
    let
	rhs = Lam u1 $
221 222 223
	      Case (Var u1) u1 res_ty
		   [(DataAlt nilDataCon,  [], 	    core_list2),
		    (DataAlt consDataCon, [u2, u3], core_match)]
224
			-- Increasing order of tag
225 226
    in
    returnDs (Let (Rec [(h, rhs)]) letrec_body)
227 228
\end{code}

229

230 231 232 233 234 235 236 237 238 239 240
\begin{code}
mkZipBind :: [Type] -> DsM (Id, CoreExpr)
-- mkZipBind [t1, t2] 
-- = (zip, \as1:[t1] as2:[t2] 
--	   -> case as1 of 
--		[] -> []
--		(a1:as'1) -> case as2 of
--				[] -> []
--				(a2:as'2) -> (a2,a2) : zip as'1 as'2)]

mkZipBind elt_tys 
241 242 243
  = mappM newSysLocalDs  list_tys	`thenDs` \ ass ->
    mappM newSysLocalDs  elt_tys	`thenDs` \ as' ->
    mappM newSysLocalDs  list_tys	`thenDs` \ as's ->
244 245
    newSysLocalDs zip_fn_ty		`thenDs` \ zip_fn ->
    let 
246 247 248
	inner_rhs = mkConsExpr ret_elt_ty 
			(mkCoreTup (map Var as'))
			(mkVarApps (Var zip_fn) as's)
249 250 251 252
	zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
    in
    returnDs (zip_fn, mkLams ass zip_body)
  where
253 254 255 256
    list_tys    = map mkListTy elt_tys
    ret_elt_ty  = mkCoreTupTy elt_tys
    list_ret_ty = mkListTy ret_elt_ty
    zip_fn_ty   = mkFunTys list_tys list_ret_ty
257 258

    mk_case (as, a', as') rest
259 260 261
	  = Case (Var as) as list_ret_ty
		  [(DataAlt nilDataCon,  [],        mkNilExpr ret_elt_ty),
		   (DataAlt consDataCon, [a', as'], rest)]
262
			-- Increasing order of tag
263
-- Helper functions that makes an HsTuple only for non-1-sized tuples
264 265 266 267 268 269
mk_hs_tuple_expr :: [Id] -> LHsExpr Id
mk_hs_tuple_expr []   = nlHsVar unitDataConId
mk_hs_tuple_expr [id] = nlHsVar id
mk_hs_tuple_expr ids  = noLoc $ ExplicitTuple [ nlHsVar i | i <- ids ] Boxed

mk_hs_tuple_pat :: [Id] -> LPat Id
270
mk_hs_tuple_pat bs  = mkTuplePat (map nlVarPat bs)
271 272 273
\end{code}


274 275 276 277 278 279 280
%************************************************************************
%*									*
\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
%*									*
%************************************************************************

@dfListComp@ are the rules used with foldr/build turned on:
281

282
\begin{verbatim}
283 284 285 286 287 288 289 290
TE[ e | ]            c n = c e n
TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n
TE[ e | p <- l , q ] c n = let 
				f = \ x b -> case x of
						  p -> TE[ e | q ] c b
						  _ -> b
			   in
			   foldr f n l
291
\end{verbatim}
292

293
\begin{code}
294
dfListComp :: Id -> Id			-- 'c' and 'n'
295
	   -> [Stmt Id] 	-- the rest of the qual's
296
	   -> LHsExpr Id
297
	   -> DsM CoreExpr
298

299
	-- Last: the one to return
300 301 302
dfListComp c_id n_id [] body
  = dsLExpr body		`thenDs` \ core_body ->
    returnDs (mkApps (Var c_id) [core_body, Var n_id])
303

304
	-- Non-last: must be a guard
305 306 307
dfListComp c_id n_id (ExprStmt guard _ _  : quals) body
  = dsLExpr guard              		`thenDs` \ core_guard ->
    dfListComp c_id n_id quals body	`thenDs` \ core_rest ->
308
    returnDs (mkIfThenElse core_guard core_rest (Var n_id))
309

310
dfListComp c_id n_id (LetStmt binds : quals) body
311
  -- new in 1.3, local bindings
312
  = dfListComp c_id n_id quals body	`thenDs` \ core_rest ->
313
    dsLocalBinds binds core_rest
314

315
dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body
316
    -- evaluate the two lists
317
  = dsLExpr list1			`thenDs` \ core_list1 ->
318 319

    -- find the required type
320
    let x_ty   = hsLPatType pat
321
	b_ty   = idType n_id
322 323 324
    in

    -- create some new local id's
325
    newSysLocalsDs [b_ty,x_ty]			`thenDs` \ [b,x] ->
326 327

    -- build rest of the comprehesion
328
    dfListComp c_id b quals body		`thenDs` \ core_rest ->
329 330

    -- build the pattern match
331
    matchSimply (Var x) (StmtCtxt ListComp)
332
		pat core_rest (Var b)		`thenDs` \ core_expr ->
333 334

    -- now build the outermost foldr, and return
335
    dsLookupGlobalId foldrName		`thenDs` \ foldr_id ->
336
    returnDs (
337 338 339 340 341
      Var foldr_id `App` Type x_ty 
		   `App` Type b_ty
		   `App` mkLams [x, b] core_expr
		   `App` Var n_id
		   `App` core_list1
342
    )
343 344
\end{code}

chak's avatar
chak committed
345 346 347 348 349 350 351 352 353 354 355 356
%************************************************************************
%*									*
\subsection[DsPArrComp]{Desugaring of array comprehensions}
%*									*
%************************************************************************

\begin{code}

-- entry point for desugaring a parallel array comprehension
--
--   [:e | qss:] = <<[:e | qss:]>> () [:():]
--
357
dsPArrComp      :: [Stmt Id] 
358
		-> LHsExpr Id
chak's avatar
chak committed
359 360
	        -> Type		    -- Don't use; called with `undefined' below
	        -> DsM CoreExpr
361 362 363
dsPArrComp [ParStmt qss] body _  =  -- parallel comprehension
  dePArrParComp qss body
dsPArrComp qs            body _  =  -- no ParStmt in `qs'
364 365
  dsLookupGlobalId singletonPName			  `thenDs` \sglP ->
  let unitArray = mkApps (Var sglP) [Type unitTy, 
366
				     mkCoreTup []]
chak's avatar
chak committed
367
  in
368
  dePArrComp qs body (mkTuplePat []) unitArray
369

370 371


chak's avatar
chak committed
372 373
-- the work horse
--
374
dePArrComp :: [Stmt Id] 
375
	   -> LHsExpr Id
376 377
	   -> LPat Id		-- the current generator pattern
	   -> CoreExpr		-- the current generator expression
chak's avatar
chak committed
378 379 380 381
	   -> DsM CoreExpr
--
--  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
382
dePArrComp [] e' pa cea =
383
  dsLookupGlobalId mapPName				  `thenDs` \mapP    ->
chak's avatar
chak committed
384 385 386 387 388 389 390 391
  let ty = parrElemType cea
  in
  deLambda ty pa e'					  `thenDs` \(clam, 
								     ty'e') ->
  returnDs $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
--
--  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
392
dePArrComp (ExprStmt b _ _ : qs) body pa cea =
393
  dsLookupGlobalId filterPName			  `thenDs` \filterP  ->
chak's avatar
chak committed
394 395
  let ty = parrElemType cea
  in
chak's avatar
chak committed
396
  deLambda ty pa b				  `thenDs` \(clam,_) ->
397
  dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
398 399 400 401 402 403 404 405

--
--  <<[:e' | p <- e, qs:]>> pa ea =
--    let ef = \pa -> e
--    in
--    <<[:e' | qs:]>> (pa, p) (crossMap ea ef)
--
-- if matching again p cannot fail, or else
chak's avatar
chak committed
406 407
--
--  <<[:e' | p <- e, qs:]>> pa ea = 
408
--    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
chak's avatar
chak committed
409
--    in
410
--    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
chak's avatar
chak committed
411
--
412
dePArrComp (BindStmt p e _ _ : qs) body pa cea =
413 414 415 416 417 418 419
  dsLookupGlobalId filterPName			  `thenDs` \filterP    ->
  dsLookupGlobalId crossMapPName		  `thenDs` \crossMapP  ->
  dsLExpr e					  `thenDs` \ce         ->
  let ety'cea = parrElemType cea
      ety'ce  = parrElemType ce
      false   = Var falseDataConId
      true    = Var trueDataConId
chak's avatar
chak committed
420
  in
421
  newSysLocalDs ety'ce					  `thenDs` \v       ->
chak's avatar
chak committed
422
  matchSimply (Var v) (StmtCtxt PArrComp) p true false    `thenDs` \pred    ->
423 424
  let cef | isIrrefutableHsPat p = ce
          | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
425 426 427 428 429
  in
  mkLambda ety'cea pa cef				  `thenDs` \(clam, 
								     _    ) ->
  let ety'cef = ety'ce		    -- filter doesn't change the element type
      pa'     = mkTuplePat [pa, p]
chak's avatar
chak committed
430
  in
431 432
  dePArrComp qs body pa' (mkApps (Var crossMapP) 
				 [Type ety'cea, Type ety'cef, cea, clam])
chak's avatar
chak committed
433 434 435
--
--  <<[:e' | let ds, qs:]>> pa ea = 
--    <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) 
436
--		      (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)
chak's avatar
chak committed
437 438 439
--  where
--    {x_1, ..., x_n} = DV (ds)		-- Defined Variables
--
440
dePArrComp (LetStmt ds : qs) body pa cea =
441
  dsLookupGlobalId mapPName				  `thenDs` \mapP    ->
442
  let xs     = map unLoc (collectLocalBinders ds)
chak's avatar
chak committed
443 444 445
      ty'cea = parrElemType cea
  in
  newSysLocalDs ty'cea					  `thenDs` \v       ->
446
  dsLocalBinds ds (mkCoreTup (map Var xs))		  `thenDs` \clet    ->
chak's avatar
chak committed
447
  newSysLocalDs (exprType clet)				  `thenDs` \let'v   ->
448 449
  let projBody = mkDsLet (NonRec let'v clet) $ 
		 mkCoreTup [Var v, Var let'v]
chak's avatar
chak committed
450 451 452 453
      errTy    = exprType projBody
      errMsg   = "DsListComp.dePArrComp: internal error!"
  in
  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->
chak's avatar
chak committed
454 455
  matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr`thenDs` \ccase   ->
  let pa'    = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
chak's avatar
chak committed
456 457
      proj   = mkLams [v] ccase
  in
458 459
  dePArrComp qs body pa' (mkApps (Var mapP) 
				 [Type ty'cea, Type errTy, proj, cea])
chak's avatar
chak committed
460
--
461 462 463 464 465 466 467
-- The parser guarantees that parallel comprehensions can only appear as
-- singeltons qualifier lists, which we already special case in the caller.
-- So, encountering one here is a bug.
--
dePArrComp (ParStmt _ : _) _ _ _ = 
  panic "DsListComp.dePArrComp: malformed comprehension AST"

chak's avatar
chak committed
468 469 470 471 472 473
--  <<[:e' | qs | qss:]>> pa ea = 
--    <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) 
--		       (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
--    where
--      {x_1, ..., x_n} = DV (qs)
--
474
dePArrParComp qss body = 
chak's avatar
chak committed
475 476
  deParStmt qss						`thenDs` \(pQss, 
								   ceQss) ->
477
  dePArrComp [] body pQss ceQss
chak's avatar
chak committed
478 479
  where
    deParStmt []             =
480
      -- empty parallel statement lists have no source representation
chak's avatar
chak committed
481 482
      panic "DsListComp.dePArrComp: Empty parallel list comprehension"
    deParStmt ((qs, xs):qss) =          -- first statement
483
      let res_expr = mkExplicitTuple (map nlHsVar xs)
chak's avatar
chak committed
484
      in
485
      dsPArrComp (map unLoc qs) res_expr undefined	  `thenDs` \cqs     ->
chak's avatar
chak committed
486 487 488 489 490
      parStmts qss (mkTuplePat (map nlVarPat xs)) cqs
    ---
    parStmts []             pa cea = return (pa, cea)
    parStmts ((qs, xs):qss) pa cea =    -- subsequent statements (zip'ed)
      dsLookupGlobalId zipPName				  `thenDs` \zipP    ->
491 492 493
      let pa'      = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
	  ty'cea   = parrElemType cea
	  res_expr = mkExplicitTuple (map nlHsVar xs)
chak's avatar
chak committed
494
      in
495
      dsPArrComp (map unLoc qs) res_expr undefined	  `thenDs` \cqs     ->
chak's avatar
chak committed
496 497 498 499
      let ty'cqs = parrElemType cqs
	  cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
      in
      parStmts qss pa' cea'
chak's avatar
chak committed
500 501 502

-- generate Core corresponding to `\p -> e'
--
503 504 505 506 507
deLambda :: Type			-- type of the argument
	  -> LPat Id			-- argument pattern
	  -> LHsExpr Id			-- body
	  -> DsM (CoreExpr, Type)
deLambda ty p e =
508
  dsLExpr e						  `thenDs` \ce      ->
509 510 511 512 513 514 515 516 517 518 519 520
  mkLambda ty p ce

-- generate Core for a lambda pattern match, where the body is already in Core
--
mkLambda :: Type			-- type of the argument
	 -> LPat Id			-- argument pattern
	 -> CoreExpr			-- desugared body
	 -> DsM (CoreExpr, Type)
mkLambda ty p ce =
  newSysLocalDs ty					  `thenDs` \v       ->
  let errMsg = "DsListComp.deLambda: internal error!"
      ce'ty  = exprType ce
chak's avatar
chak committed
521
  in
522
  mkErrorAppDs pAT_ERROR_ID ce'ty errMsg                  `thenDs` \cerr    -> 
523
  matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr	  `thenDs` \res	    ->
524
  returnDs (mkLams [v] res, ce'ty)
chak's avatar
chak committed
525 526 527 528 529 530 531

-- obtain the element type of the parallel array produced by the given Core
-- expression
--
parrElemType   :: CoreExpr -> Type
parrElemType e  = 
  case splitTyConApp_maybe (exprType e) of
532
    Just (tycon, [ty]) | tycon == parrTyCon -> ty
chak's avatar
chak committed
533 534
    _							  -> panic
      "DsListComp.parrElemType: not a parallel array type"
chak's avatar
chak committed
535 536 537

-- Smart constructor for source tuple patterns
--
538
mkTuplePat :: [LPat Id] -> LPat Id
chak's avatar
chak committed
539
mkTuplePat [lpat] = lpat
540
mkTuplePat lpats  = noLoc $ mkVanillaTuplePat lpats Boxed
chak's avatar
chak committed
541 542 543 544 545 546

-- Smart constructor for source tuple expressions
--
mkExplicitTuple :: [LHsExpr id] -> LHsExpr id
mkExplicitTuple [lexp] = lexp
mkExplicitTuple lexps  = noLoc $ ExplicitTuple lexps Boxed
chak's avatar
chak committed
547
\end{code}