DsListComp.lhs 17.3 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}
chak's avatar
chak committed
9
module DsListComp ( dsListComp, dsPArrComp ) where
10

11 12
#include "HsVersions.h"

13
import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
14

Simon Marlow's avatar
Simon Marlow committed
15
import BasicTypes
16
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
17
import TcHsSyn
18
import CoreSyn
19

20
import DsMonad		-- the monadery used in the desugarer
21
import DsUtils
22

Simon Marlow's avatar
Simon Marlow committed
23 24 25 26 27 28 29 30 31 32 33 34
import DynFlags
import StaticFlags
import CoreUtils
import Var
import Type
import TysPrim
import TysWiredIn
import Match
import PrelNames
import PrelInfo
import SrcLoc
import Panic
35 36 37 38 39 40 41 42 43
\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}
44
dsListComp :: [LStmt Id] 
45
	   -> LHsExpr Id
46 47
	   -> Type		-- Type of list elements
	   -> DsM CoreExpr
48
dsListComp lquals body elt_ty
49
  = getDOptsDs  `thenDs` \dflags ->
50 51 52
    let
	quals = map unLoc lquals
    in
53 54 55 56 57 58 59
    if opt_RulesOff || dopt Opt_IgnoreInterfacePragmas dflags
	-- 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
60
  	then deListComp quals body (mkNilExpr elt_ty)
61

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

75 76
  where isParallelComp (ParStmt bndrstmtss : _) = True
	isParallelComp _                        = False
77 78 79 80 81 82 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
\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.

122 123 124 125 126
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]
     =>
127 128 129 130 131 132
     [ 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

133
In the translation below, the ParStmt branch translates each parallel branch
134 135 136 137 138 139 140 141
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.
142

143
\begin{code}
144
deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
145

146
deListComp (ParStmt stmtss_w_bndrs : quals) body list
147
  = mappM do_list_comp stmtss_w_bndrs	`thenDs` \ exps ->
148 149 150 151
    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)) 
152
		   quals body list
153

154 155 156 157
  where 
	bndrs_s = map snd stmtss_w_bndrs

	-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
158
	pat	 = mkTuplePat pats
159
	pats	 = map mk_hs_tuple_pat bndrs_s
160 161

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

164
	do_list_comp (stmts, bndrs)
165
	  = dsListComp stmts (mk_hs_tuple_expr bndrs)
166 167
		       (mk_bndrs_tys bndrs)

168
	mk_bndrs_tys bndrs = mkCoreTupTy (map idType bndrs)
169

170
	-- Last: the one to return
171 172 173
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)
174

175
	-- Non-last: must be a guard
176
deListComp (ExprStmt guard _ _ : quals) body list	-- rule B above
177
  = dsLExpr guard      		`thenDs` \ core_guard ->
178
    deListComp quals body list	`thenDs` \ core_rest ->
179
    returnDs (mkIfThenElse core_guard core_rest list)
180

181
-- [e | let B, qs] = let B in [e | qs]
182 183
deListComp (LetStmt binds : quals) body list
  = deListComp quals body list	`thenDs` \ core_rest ->
184
    dsLocalBinds binds core_rest
185

186
deListComp (BindStmt pat list1 _ _ : quals) body core_list2 -- rule A' above
187
  = dsLExpr list1		    `thenDs` \ core_list1 ->
188
    deBindComp pat core_list1 quals body core_list2
189 190
\end{code}

191

192
\begin{code}
193
deBindComp pat core_list1 quals body core_list2
194
  = let
195
	u3_ty@u1_ty = exprType core_list1	-- two names, same thing
196 197

	-- u1_ty is a [alpha] type, and u2_ty = alpha
198
	u2_ty = hsLPatType pat
199

200
	res_ty = exprType core_list2
201
	h_ty   = u1_ty `mkFunTy` res_ty
202
    in
203
    newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]	`thenDs` \ [h, u1, u2, u3] ->
204

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

223

224 225 226 227 228 229 230 231 232 233 234
\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 
235 236 237
  = mappM newSysLocalDs  list_tys	`thenDs` \ ass ->
    mappM newSysLocalDs  elt_tys	`thenDs` \ as' ->
    mappM newSysLocalDs  list_tys	`thenDs` \ as's ->
238 239
    newSysLocalDs zip_fn_ty		`thenDs` \ zip_fn ->
    let 
240 241 242
	inner_rhs = mkConsExpr ret_elt_ty 
			(mkCoreTup (map Var as'))
			(mkVarApps (Var zip_fn) as's)
243 244 245 246
	zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
    in
    returnDs (zip_fn, mkLams ass zip_body)
  where
247 248 249 250
    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
251 252

    mk_case (as, a', as') rest
253 254 255
	  = Case (Var as) as list_ret_ty
		  [(DataAlt nilDataCon,  [],        mkNilExpr ret_elt_ty),
		   (DataAlt consDataCon, [a', as'], rest)]
256
			-- Increasing order of tag
257
-- Helper functions that makes an HsTuple only for non-1-sized tuples
258 259 260 261 262 263
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
264
mk_hs_tuple_pat bs  = mkTuplePat (map nlVarPat bs)
265 266 267
\end{code}


268 269 270 271 272 273 274
%************************************************************************
%*									*
\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
%*									*
%************************************************************************

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

276
\begin{verbatim}
277 278 279 280 281 282 283 284
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
285
\end{verbatim}
286

287
\begin{code}
288
dfListComp :: Id -> Id			-- 'c' and 'n'
289
	   -> [Stmt Id] 	-- the rest of the qual's
290
	   -> LHsExpr Id
291
	   -> DsM CoreExpr
292

293
	-- Last: the one to return
294 295 296
dfListComp c_id n_id [] body
  = dsLExpr body		`thenDs` \ core_body ->
    returnDs (mkApps (Var c_id) [core_body, Var n_id])
297

298
	-- Non-last: must be a guard
299 300 301
dfListComp c_id n_id (ExprStmt guard _ _  : quals) body
  = dsLExpr guard              		`thenDs` \ core_guard ->
    dfListComp c_id n_id quals body	`thenDs` \ core_rest ->
302
    returnDs (mkIfThenElse core_guard core_rest (Var n_id))
303

304
dfListComp c_id n_id (LetStmt binds : quals) body
305
  -- new in 1.3, local bindings
306
  = dfListComp c_id n_id quals body	`thenDs` \ core_rest ->
307
    dsLocalBinds binds core_rest
308

309
dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body
310
    -- evaluate the two lists
311
  = dsLExpr list1			`thenDs` \ core_list1 ->
312 313

    -- find the required type
314
    let x_ty   = hsLPatType pat
315
	b_ty   = idType n_id
316 317 318
    in

    -- create some new local id's
319
    newSysLocalsDs [b_ty,x_ty]			`thenDs` \ [b,x] ->
320 321

    -- build rest of the comprehesion
322
    dfListComp c_id b quals body		`thenDs` \ core_rest ->
323 324

    -- build the pattern match
325
    matchSimply (Var x) (StmtCtxt ListComp)
326
		pat core_rest (Var b)		`thenDs` \ core_expr ->
327 328

    -- now build the outermost foldr, and return
329
    dsLookupGlobalId foldrName		`thenDs` \ foldr_id ->
330
    returnDs (
331 332 333 334 335
      Var foldr_id `App` Type x_ty 
		   `App` Type b_ty
		   `App` mkLams [x, b] core_expr
		   `App` Var n_id
		   `App` core_list1
336
    )
337 338
\end{code}

chak's avatar
chak committed
339 340 341 342 343 344 345 346 347 348 349 350
%************************************************************************
%*									*
\subsection[DsPArrComp]{Desugaring of array comprehensions}
%*									*
%************************************************************************

\begin{code}

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

365 366


chak's avatar
chak committed
367 368
-- the work horse
--
369
dePArrComp :: [Stmt Id] 
370
	   -> LHsExpr Id
371 372
	   -> LPat Id		-- the current generator pattern
	   -> CoreExpr		-- the current generator expression
chak's avatar
chak committed
373 374 375 376
	   -> DsM CoreExpr
--
--  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
377
dePArrComp [] e' pa cea =
378
  dsLookupGlobalId mapPName				  `thenDs` \mapP    ->
chak's avatar
chak committed
379 380 381 382 383 384 385 386
  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)
--
387
dePArrComp (ExprStmt b _ _ : qs) body pa cea =
388
  dsLookupGlobalId filterPName			  `thenDs` \filterP  ->
chak's avatar
chak committed
389 390
  let ty = parrElemType cea
  in
chak's avatar
chak committed
391
  deLambda ty pa b				  `thenDs` \(clam,_) ->
392
  dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
chak's avatar
chak committed
393 394
--
--  <<[:e' | p <- e, qs:]>> pa ea = 
395
--    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
chak's avatar
chak committed
396
--    in
397
--    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
chak's avatar
chak committed
398
--
399
dePArrComp (BindStmt p e _ _ : qs) body pa cea =
400 401 402 403 404 405 406
  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
407
  in
408
  newSysLocalDs ety'ce					  `thenDs` \v       ->
chak's avatar
chak committed
409
  matchSimply (Var v) (StmtCtxt PArrComp) p true false    `thenDs` \pred    ->
410 411 412 413 414 415
  let cef = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
  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
416
  in
417 418
  dePArrComp qs body pa' (mkApps (Var crossMapP) 
				 [Type ety'cea, Type ety'cef, cea, clam])
chak's avatar
chak committed
419 420 421
--
--  <<[:e' | let ds, qs:]>> pa ea = 
--    <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) 
422
--		      (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)
chak's avatar
chak committed
423 424 425
--  where
--    {x_1, ..., x_n} = DV (ds)		-- Defined Variables
--
426
dePArrComp (LetStmt ds : qs) body pa cea =
427
  dsLookupGlobalId mapPName				  `thenDs` \mapP    ->
428
  let xs     = map unLoc (collectLocalBinders ds)
chak's avatar
chak committed
429 430 431
      ty'cea = parrElemType cea
  in
  newSysLocalDs ty'cea					  `thenDs` \v       ->
432
  dsLocalBinds ds (mkCoreTup (map Var xs))		  `thenDs` \clet    ->
chak's avatar
chak committed
433
  newSysLocalDs (exprType clet)				  `thenDs` \let'v   ->
434 435
  let projBody = mkDsLet (NonRec let'v clet) $ 
		 mkCoreTup [Var v, Var let'v]
chak's avatar
chak committed
436 437 438 439
      errTy    = exprType projBody
      errMsg   = "DsListComp.dePArrComp: internal error!"
  in
  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->
chak's avatar
chak committed
440 441
  matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr`thenDs` \ccase   ->
  let pa'    = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
chak's avatar
chak committed
442 443
      proj   = mkLams [v] ccase
  in
444 445
  dePArrComp qs body pa' (mkApps (Var mapP) 
				 [Type ty'cea, Type errTy, proj, cea])
chak's avatar
chak committed
446
--
447 448 449 450 451 452 453
-- 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
454 455 456 457 458 459
--  <<[: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)
--
460
dePArrParComp qss body = 
chak's avatar
chak committed
461 462
  deParStmt qss						`thenDs` \(pQss, 
								   ceQss) ->
463
  dePArrComp [] body pQss ceQss
chak's avatar
chak committed
464 465
  where
    deParStmt []             =
466
      -- empty parallel statement lists have no source representation
chak's avatar
chak committed
467 468
      panic "DsListComp.dePArrComp: Empty parallel list comprehension"
    deParStmt ((qs, xs):qss) =          -- first statement
469
      let res_expr = mkExplicitTuple (map nlHsVar xs)
chak's avatar
chak committed
470
      in
471
      dsPArrComp (map unLoc qs) res_expr undefined	  `thenDs` \cqs     ->
chak's avatar
chak committed
472 473 474 475 476
      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    ->
477 478 479
      let pa'      = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
	  ty'cea   = parrElemType cea
	  res_expr = mkExplicitTuple (map nlHsVar xs)
chak's avatar
chak committed
480
      in
481
      dsPArrComp (map unLoc qs) res_expr undefined	  `thenDs` \cqs     ->
chak's avatar
chak committed
482 483 484 485
      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
486 487 488

-- generate Core corresponding to `\p -> e'
--
489 490 491 492 493
deLambda :: Type			-- type of the argument
	  -> LPat Id			-- argument pattern
	  -> LHsExpr Id			-- body
	  -> DsM (CoreExpr, Type)
deLambda ty p e =
494
  dsLExpr e						  `thenDs` \ce      ->
495 496 497 498 499 500 501 502 503 504 505 506
  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
507
  in
508
  mkErrorAppDs pAT_ERROR_ID ce'ty errMsg                  `thenDs` \cerr    -> 
509
  matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr	  `thenDs` \res	    ->
510
  returnDs (mkLams [v] res, ce'ty)
chak's avatar
chak committed
511 512 513 514 515 516 517

-- 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
518
    Just (tycon, [ty]) | tycon == parrTyCon -> ty
chak's avatar
chak committed
519 520
    _							  -> panic
      "DsListComp.parrElemType: not a parallel array type"
chak's avatar
chak committed
521 522 523

-- Smart constructor for source tuple patterns
--
524
mkTuplePat :: [LPat Id] -> LPat Id
chak's avatar
chak committed
525
mkTuplePat [lpat] = lpat
526
mkTuplePat lpats  = noLoc $ mkVanillaTuplePat lpats Boxed
chak's avatar
chak committed
527 528 529 530 531 532

-- 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
533
\end{code}