DsListComp.lhs 17.2 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
%
chak's avatar
chak committed
4
\section[DsListComp]{Desugaring list comprehensions and array comprehensions}
5 6

\begin{code}
chak's avatar
chak committed
7
module DsListComp ( dsListComp, dsPArrComp ) where
8

9 10
#include "HsVersions.h"

11
import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
12

13
import BasicTypes	( Boxity(..) )
14
import HsSyn
15
import TcHsSyn		( hsLPatType, mkVanillaTuplePat )
16
import CoreSyn
17

18
import DsMonad		-- the monadery used in the desugarer
19
import DsUtils
20

21 22
import DynFlags		( DynFlag(..), dopt )
import StaticFlags	( opt_RulesOff )
23
import CoreUtils	( exprType, mkIfThenElse )
24
import Id		( idType )
25
import Var              ( Id )
chak's avatar
chak committed
26 27
import Type		( mkTyVarTy, mkFunTys, mkFunTy, Type,
			  splitTyConApp_maybe )
28
import TysPrim		( alphaTyVar )
29
import TysWiredIn	( nilDataCon, consDataCon, trueDataConId, falseDataConId, 
30
			  unitDataConId, unitTy, mkListTy, parrTyCon )
31
import Match		( matchSimply )
32
import PrelNames	( foldrName, buildName, replicatePName, mapPName, 
33
			  filterPName, zipPName, crossPName ) 
chak's avatar
chak committed
34
import PrelInfo		( pAT_ERROR_ID )
35
import SrcLoc		( noLoc, unLoc )
chak's avatar
chak committed
36
import Panic		( panic )
37 38 39 40 41 42 43 44 45
\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}
46
dsListComp :: [LStmt Id] 
47
	   -> LHsExpr Id
48 49
	   -> Type		-- Type of list elements
	   -> DsM CoreExpr
50
dsListComp lquals body elt_ty
51
  = getDOptsDs  `thenDs` \dflags ->
52 53 54
    let
	quals = map unLoc lquals
    in
55 56 57 58 59 60 61
    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
62
  	then deListComp quals body (mkNilExpr elt_ty)
63

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

77 78
  where isParallelComp (ParStmt bndrstmtss : _) = True
	isParallelComp _                        = False
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 122 123
\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.

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

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

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

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

156 157 158 159
  where 
	bndrs_s = map snd stmtss_w_bndrs

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

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

166
	do_list_comp (stmts, bndrs)
167
	  = dsListComp stmts (mk_hs_tuple_expr bndrs)
168 169
		       (mk_bndrs_tys bndrs)

170
	mk_bndrs_tys bndrs = mkCoreTupTy (map idType bndrs)
171

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

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

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

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

193

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

	-- u1_ty is a [alpha] type, and u2_ty = alpha
200
	u2_ty = hsLPatType pat
201

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

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

225

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

\begin{code}

-- entry point for desugaring a parallel array comprehension
--
--   [:e | qss:] = <<[:e | qss:]>> () [:():]
--
353
dsPArrComp      :: [Stmt Id] 
354
		-> LHsExpr Id
chak's avatar
chak committed
355 356
	        -> Type		    -- Don't use; called with `undefined' below
	        -> DsM CoreExpr
357
dsPArrComp qs body _  =
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

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

-- generate Core corresponding to `\p -> e'
--
deLambda        :: Type			-- type of the argument
482 483
		-> LPat Id		-- argument pattern
		-> LHsExpr Id		-- body
chak's avatar
chak committed
484 485 486
		-> DsM (CoreExpr, Type)
deLambda ty p e  =
  newSysLocalDs ty					  `thenDs` \v       ->
487
  dsLExpr e						  `thenDs` \ce      ->
chak's avatar
chak committed
488 489 490
  let errTy    = exprType ce
      errMsg   = "DsListComp.deLambda: internal error!"
  in
491
  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    -> 
492
  matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr	  `thenDs` \res	    ->
chak's avatar
chak committed
493 494 495 496 497 498 499 500
  returnDs (mkLams [v] res, errTy)

-- 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
501
    Just (tycon, [ty]) | tycon == parrTyCon -> ty
chak's avatar
chak committed
502 503
    _							  -> panic
      "DsListComp.parrElemType: not a parallel array type"
chak's avatar
chak committed
504 505 506

-- Smart constructor for source tuple patterns
--
507
mkTuplePat :: [LPat Id] -> LPat Id
chak's avatar
chak committed
508
mkTuplePat [lpat] = lpat
509
mkTuplePat lpats  = noLoc $ mkVanillaTuplePat lpats Boxed
chak's avatar
chak committed
510 511 512 513 514 515

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