DsListComp.lhs 38.1 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, monad comprehensions and array comprehensions
7 8

\begin{code}
9
{-# LANGUAGE NamedFieldPuns #-}
10
{-# OPTIONS -fno-warn-incomplete-patterns #-}
11 12 13
-- 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
14
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
15 16
-- for details

17
module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
18

19 20
#include "HsVersions.h"

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

23
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
24
import TcHsSyn
25
import CoreSyn
26
import MkCore
27

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

Simon Marlow's avatar
Simon Marlow committed
31 32
import DynFlags
import CoreUtils
33
import Id
Simon Marlow's avatar
Simon Marlow committed
34 35 36 37 38
import Type
import TysWiredIn
import Match
import PrelNames
import SrcLoc
39
import Outputable
40
import FastString
41
import TcType
42 43 44 45 46 47 48 49 50
\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}
51
dsListComp :: [LStmt Id] 
52
	   -> Type		-- Type of entire list 
53
	   -> DsM CoreExpr
54
dsListComp lquals res_ty = do 
55 56
    dflags <- getDOptsDs
    let quals = map unLoc lquals
57
        [elt_ty] = tcTyConAppArgs res_ty
58
    
59
    if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
60 61 62 63 64
       -- 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
65 66
        then deListComp quals (mkNilExpr elt_ty)
        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) 
67 68
             -- Foldr/build should be enabled, so desugar 
             -- into foldrs and builds
69 70 71 72 73 74 75 76

  where 
    -- We must test for ParStmt anywhere, not just at the head, because an extension
    -- to list comprehensions would be to add brackets to specify the associativity
    -- of qualifier lists. This is really easy to do by adding extra ParStmts into the
    -- mix of possibly a single element in length, so we do this to leave the possibility open
    isParallelComp = any isParallelStmt
  
77 78
    isParallelStmt (ParStmt _ _ _ _) = True
    isParallelStmt _                 = False
79 80 81 82 83 84 85
    
    
-- This function lets you desugar a inner list comprehension and a list of the binders
-- of that comprehension that we need in the outer comprehension into such an expression
-- and the type of the elements that it outputs (tuples of binders)
dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
dsInnerListComp (stmts, bndrs) = do
86 87 88 89 90
  = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)]) 
                           bndrs_tuple_type
       ; return (expr, bndrs_tuple_type) }
  where
    bndrs_tuple_type = mkBigCoreVarTupTy bndrs
91 92 93 94 95
        
-- This function factors out commonality between the desugaring strategies for TransformStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
96
dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr _ _)
97 98
 = do { (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
      ; usingExpr' <- dsLExpr usingExpr
99
    
100 101
      ; using_args <-
          case maybeByExpr of
102 103 104 105 106 107 108 109 110 111
            Nothing -> return [expr]
            Just byExpr -> do
                byExpr' <- dsLExpr byExpr
                
                us <- newUniqueSupply
                [tuple_binder] <- newSysLocalsDs [binders_tuple_type]
                let byExprWrapper = mkTupleCase us binders byExpr' tuple_binder (Var tuple_binder)
                
                return [Lam tuple_binder byExprWrapper, expr]

112 113 114
      ; let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
            pat = mkBigLHsVarPatTup binders
      ; return (inner_list_expr, pat) }
115 116 117 118 119
    
-- This function factors out commonality between the desugaring strategies for GroupStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
120
dsGroupStmt (GroupStmt stmts binderMap by using _ _ _) = do
121 122 123 124 125 126 127 128
    let (fromBinders, toBinders) = unzip binderMap
        
        fromBindersTypes = map idType fromBinders
        toBindersTypes = map idType toBinders
        
        toBindersTupleType = mkBigCoreTupTy toBindersTypes
    
    -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
129
    (expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders)
130 131 132
    
    -- Work out what arguments should be supplied to that expression: i.e. is an extraction
    -- function required? If so, create that desugared function and add to arguments
133 134 135 136 137 138 139 140 141
    usingExpr' <- dsLExpr (either id noLoc using)
    usingArgs <- case by of
                   Nothing   -> return [expr]
 		   Just by_e -> do { by_e' <- dsLExpr by_e
                                   ; us <- newUniqueSupply
                                   ; [from_tup_id] <- newSysLocalsDs [from_tup_ty]
                                   ; let by_wrap = mkTupleCase us fromBinders by_e' 
                                                   from_tup_id (Var from_tup_id)
                                   ; return [Lam from_tup_id by_wrap, expr] }
142 143 144 145 146 147 148
    
    -- Create an unzip function for the appropriate arity and element types and find "map"
    (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes
    map_id <- dsLookupGlobalId mapName

    -- Generate the expressions to build the grouped list
    let -- First we apply the grouping function to the inner list
149
        inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs)
150 151 152 153
        -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
        -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
        -- the "b" to be a tuple of "to" lists!
        unzipped_inner_list_expr = mkApps (Var map_id) 
154
            [Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr]
155 156 157 158 159 160 161
        -- Then finally we bind the unzip function around that expression
        bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr
    
    -- Build a pattern that ensures the consumer binds into the NEW binders, which hold lists rather than single values
    let pat = mkBigLHsVarPatTup toBinders
    return (bound_unzipped_inner_list_expr, pat)
    
162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
\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.

207 208 209 210 211
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]
     =>
212 213 214 215 216 217
     [ 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

218
In the translation below, the ParStmt branch translates each parallel branch
219 220 221 222 223 224 225 226
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.
227

228
\begin{code}
229

230 231 232
deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr

deListComp [] _ = panic "deListComp"
233

234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
deListComp (LastStmt body _ : quals) list 
  =     -- Figure 7.4, SLPJ, p 135, rule C above
    ASSERT( null quals )
    do { core_body <- dsLExpr body
       ; return (mkConsExpr (exprType core_body) core_body list) }

	-- Non-last: must be a guard
deListComp (ExprStmt guard _ _ _ : quals) list = do  -- rule B above
    core_guard <- dsLExpr guard
    core_rest <- deListComp quals list
    return (mkIfThenElse core_guard core_rest list)

-- [e | let B, qs] = let B in [e | qs]
deListComp (LetStmt binds : quals) list = do
    core_rest <- deListComp quals list
    dsLocalBinds binds core_rest

deListComp (stmt@(TransformStmt {}) : quals) list = do
    (inner_list_expr, pat) <- dsTransformStmt stmt
    deBindComp pat inner_list_expr quals list

deListComp (stmt@(GroupStmt {}) : quals) list = do
    (inner_list_expr, pat) <- dsGroupStmt stmt
    deBindComp pat inner_list_expr quals list

deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above
    core_list1 <- dsLExpr list1
    deBindComp pat core_list1 quals core_list2

deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
264
  = do
265
    exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
266 267 268
    let (exps, qual_tys) = unzip exps_and_qual_tys
    
    (zip_fn, zip_rhs) <- mkZipBind qual_tys
269 270 271

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

274 275 276 277
  where 
	bndrs_s = map snd stmtss_w_bndrs

	-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
278
	pat  = mkBigLHsPatTup pats
279
	pats = map mkBigLHsVarPatTup bndrs_s
280 281
\end{code}

282

283
\begin{code}
284 285 286 287 288
deBindComp :: OutPat Id
           -> CoreExpr
           -> [Stmt Id]
           -> CoreExpr
           -> DsM (Expr Id)
289
deBindComp pat core_list1 quals core_list2 = do
290 291
    let
        u3_ty@u1_ty = exprType core_list1	-- two names, same thing
292

293 294
        -- u1_ty is a [alpha] type, and u2_ty = alpha
        u2_ty = hsLPatType pat
295

296 297 298 299
        res_ty = exprType core_list2
        h_ty   = u1_ty `mkFunTy` res_ty
        
    [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
300

301
    -- the "fail" value ...
302
    let
303 304 305
        core_fail   = App (Var h) (Var u3)
        letrec_body = App (Var h) core_list1
        
306
    rest_expr <- deListComp quals core_fail
307 308
    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail	
    
309
    let
310
        rhs = Lam u1 $
311 312 313
	      Case (Var u1) u1 res_ty
		   [(DataAlt nilDataCon,  [], 	    core_list2),
		    (DataAlt consDataCon, [u2, u3], core_match)]
314
			-- Increasing order of tag
315 316
            
    return (Let (Rec [(h, rhs)]) letrec_body)
317 318
\end{code}

319 320 321 322 323 324 325
%************************************************************************
%*									*
\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
%*									*
%************************************************************************

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

327
\begin{verbatim}
328 329 330 331 332 333 334 335
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
336
\end{verbatim}
337

338
\begin{code}
339 340 341
dfListComp :: Id -> Id -- 'c' and 'n'
        -> [Stmt Id]   -- the rest of the qual's
        -> DsM CoreExpr
342

343 344 345 346 347 348
dfListComp _ _ [] = panic "dfListComp"

dfListComp c_id n_id (LastStmt body _ : quals) 
  = ASSERT( null quals )
    do { core_body <- dsLExpr body
       ; return (mkApps (Var c_id) [core_body, Var n_id]) }
349

350
	-- Non-last: must be a guard
351
dfListComp c_id n_id (ExprStmt guard _ _ _  : quals) = do
352
    core_guard <- dsLExpr guard
353
    core_rest <- dfListComp c_id n_id quals
354 355
    return (mkIfThenElse core_guard core_rest (Var n_id))

356
dfListComp c_id n_id (LetStmt binds : quals) = do
357
    -- new in 1.3, local bindings
358
    core_rest <- dfListComp c_id n_id quals
359
    dsLocalBinds binds core_rest
360

361
dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) = do
362 363
    (inner_list_expr, pat) <- dsTransformStmt stmt
    -- Anyway, we bind the newly transformed list via the generic binding function
364
    dfBindComp c_id n_id (pat, inner_list_expr) quals 
365

366
dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) = do
367 368
    (inner_list_expr, pat) <- dsGroupStmt stmt
    -- Anyway, we bind the newly grouped list via the generic binding function
369
    dfBindComp c_id n_id (pat, inner_list_expr) quals 
370
    
371
dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do
372
    -- evaluate the two lists
373 374 375
    core_list1 <- dsLExpr list1
    
    -- Do the rest of the work in the generic binding builder
376
    dfBindComp c_id n_id (pat, core_list1) quals
377 378 379 380 381
               
dfBindComp :: Id -> Id	        -- 'c' and 'n'
       -> (LPat Id, CoreExpr)
	   -> [Stmt Id] 	        -- the rest of the qual's
	   -> DsM CoreExpr
382
dfBindComp c_id n_id (pat, core_list1) quals = do
383
    -- find the required type
384
    let x_ty   = hsLPatType pat
385
        b_ty   = idType n_id
386 387

    -- create some new local id's
388
    [b, x] <- newSysLocalsDs [b_ty, x_ty]
389 390

    -- build rest of the comprehesion
391
    core_rest <- dfListComp c_id b quals
392 393

    -- build the pattern match
394 395
    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
		pat core_rest (Var b)
396 397

    -- now build the outermost foldr, and return
398
    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418
\end{code}

%************************************************************************
%*									*
\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
%*									*
%************************************************************************

\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) -> (a1, a2) : zip as'1 as'2)]

mkZipBind elt_tys = do
419 420 421
    ass  <- mapM newSysLocalDs  elt_list_tys
    as'  <- mapM newSysLocalDs  elt_tys
    as's <- mapM newSysLocalDs  elt_list_tys
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458
    
    zip_fn <- newSysLocalDs zip_fn_ty
    
    let inner_rhs = mkConsExpr elt_tuple_ty 
			(mkBigCoreVarTup as')
			(mkVarApps (Var zip_fn) as's)
        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
    
    return (zip_fn, mkLams ass zip_body)
  where
    elt_list_tys      = map mkListTy elt_tys
    elt_tuple_ty      = mkBigCoreTupTy elt_tys
    elt_tuple_list_ty = mkListTy elt_tuple_ty
    
    zip_fn_ty         = mkFunTys elt_list_tys elt_tuple_list_ty

    mk_case (as, a', as') rest
	  = Case (Var as) as elt_tuple_list_ty
		  [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),
		   (DataAlt consDataCon, [a', as'], rest)]
			-- Increasing order of tag
            
            
mkUnzipBind :: [Type] -> DsM (Id, CoreExpr)
-- mkUnzipBind [t1, t2] 
-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
--     -> case ax of
--      (x1, x2) -> case axs of
--                (xs1, xs2) -> (x1 : xs1, x2 : xs2))
--      ([], [])
--      ys)
-- 
-- We use foldr here in all cases, even if rules are turned off, because we may as well!
mkUnzipBind elt_tys = do
    ax  <- newSysLocalDs elt_tuple_ty
    axs <- newSysLocalDs elt_list_tuple_ty
    ys  <- newSysLocalDs elt_tuple_list_ty
459 460
    xs  <- mapM newSysLocalDs elt_tys
    xss <- mapM newSysLocalDs elt_list_tys
461 462 463 464 465 466 467 468 469 470 471 472 473 474
    
    unzip_fn <- newSysLocalDs unzip_fn_ty

    [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]

    let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
        
        concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
        tupled_concat_expression = mkBigCoreTup concat_expressions
        
        folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
        folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
        folder_body = mkLams [ax, axs] folder_body_outer_case
        
475 476
    unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
    return (unzip_fn, mkLams [ys] unzip_body)
477 478 479 480 481 482 483 484 485
  where
    elt_tuple_ty       = mkBigCoreTupTy elt_tys
    elt_tuple_list_ty  = mkListTy elt_tuple_ty
    elt_list_tys       = map mkListTy elt_tys
    elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys
    
    unzip_fn_ty        = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
            
    mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
486 487
\end{code}

chak's avatar
chak committed
488 489 490 491 492 493 494 495 496 497 498 499
%************************************************************************
%*									*
\subsection[DsPArrComp]{Desugaring of array comprehensions}
%*									*
%************************************************************************

\begin{code}

-- entry point for desugaring a parallel array comprehension
--
--   [:e | qss:] = <<[:e | qss:]>> () [:():]
--
500 501
dsPArrComp :: [Stmt Id] 
            -> DsM CoreExpr
502 503 504

-- Special case for parallel comprehension
dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
505 506 507 508 509 510 511 512 513 514

-- Special case for simple generators:
--
--  <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e
--
-- if matching again p cannot fail, or else
--
--  <<[:e' | p <- e, qs:]>> = 
--    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
--
515
dsPArrComp (BindStmt p e _ _ : qs) = do
516
    filterP <- dsLookupDPHId filterPName
517 518 519 520 521 522 523 524
    ce <- dsLExpr e
    let ety'ce  = parrElemType ce
        false   = Var falseDataConId
        true    = Var trueDataConId
    v <- newSysLocalDs ety'ce
    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
    let gen | isIrrefutableHsPat p = ce
            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
525
    dePArrComp qs p gen
526

527
dsPArrComp qs = do -- no ParStmt in `qs'
528
    sglP <- dsLookupDPHId singletonPName
529
    let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
530
    dePArrComp qs (noLoc $ WildPat unitTy) unitArray
531

532 533


chak's avatar
chak committed
534 535
-- the work horse
--
536 537 538
dePArrComp :: [Stmt Id] 
	   -> LPat Id		-- the current generator pattern
	   -> CoreExpr		-- the current generator expression
chak's avatar
chak committed
539
	   -> DsM CoreExpr
540 541 542

dePArrComp [] _ _ = panic "dePArrComp"

chak's avatar
chak committed
543 544 545
--
--  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
546 547 548 549 550 551
dePArrComp (LastStmt e' _ : quals) pa cea
  = ASSERT( null quals )
    do { mapP <- dsLookupDPHId mapPName
       ; let ty = parrElemType cea
       ; (clam, ty'e') <- deLambda ty pa e'
       ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
chak's avatar
chak committed
552 553 554
--
--  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
555
dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
556
    filterP <- dsLookupDPHId filterPName
557 558
    let ty = parrElemType cea
    (clam,_) <- deLambda ty pa b
559
    dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
560 561 562 563 564 565 566 567

--
--  <<[: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
568 569
--
--  <<[:e' | p <- e, qs:]>> pa ea = 
570
--    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
chak's avatar
chak committed
571
--    in
572
--    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
chak's avatar
chak committed
573
--
574
dePArrComp (BindStmt p e _ _ : qs) pa cea = do
575 576
    filterP <- dsLookupDPHId filterPName
    crossMapP <- dsLookupDPHId crossMapPName
577 578 579 580 581 582 583 584 585 586 587 588 589
    ce <- dsLExpr e
    let ety'cea = parrElemType cea
        ety'ce  = parrElemType ce
        false   = Var falseDataConId
        true    = Var trueDataConId
    v <- newSysLocalDs ety'ce
    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
    let cef | isIrrefutableHsPat p = ce
            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
    (clam, _) <- mkLambda ety'cea pa cef
    let ety'cef = ety'ce		    -- filter doesn't change the element type
        pa'     = mkLHsPatTup [pa, p]

590
    dePArrComp qs pa' (mkApps (Var crossMapP) 
591
                                 [Type ety'cea, Type ety'cef, cea, clam])
chak's avatar
chak committed
592 593 594
--
--  <<[:e' | let ds, qs:]>> pa ea = 
--    <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) 
595
--		      (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)
chak's avatar
chak committed
596 597 598
--  where
--    {x_1, ..., x_n} = DV (ds)		-- Defined Variables
--
599
dePArrComp (LetStmt ds : qs) pa cea = do
600
    mapP <- dsLookupDPHId mapPName
601
    let xs     = collectLocalBinders ds
602 603 604 605
        ty'cea = parrElemType cea
    v <- newSysLocalDs ty'cea
    clet <- dsLocalBinds ds (mkCoreTup (map Var xs))
    let'v <- newSysLocalDs (exprType clet)
606
    let projBody = mkCoreLet (NonRec let'v clet) $ 
607 608
                   mkCoreTup [Var v, Var let'v]
        errTy    = exprType projBody
609
        errMsg   = ptext (sLit "DsListComp.dePArrComp: internal error!")
610 611 612 613
    cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg
    ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
    let pa'    = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
        proj   = mkLams [v] ccase
614
    dePArrComp qs pa' (mkApps (Var mapP) 
615
                                   [Type ty'cea, Type errTy, proj, cea])
chak's avatar
chak committed
616
--
617 618 619 620
-- 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.
--
621
dePArrComp (ParStmt _ _ _ _ : _) _ _ = 
622 623
  panic "DsListComp.dePArrComp: malformed comprehension AST"

chak's avatar
chak committed
624 625 626 627 628 629
--  <<[: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)
--
630 631
dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr
dePArrParComp qss quals = do
632
    (pQss, ceQss) <- deParStmt qss
633
    dePArrComp quals pQss ceQss
chak's avatar
chak committed
634 635
  where
    deParStmt []             =
636
      -- empty parallel statement lists have no source representation
chak's avatar
chak committed
637
      panic "DsListComp.dePArrComp: Empty parallel list comprehension"
638
    deParStmt ((qs, xs):qss) = do        -- first statement
639
      let res_expr = mkLHsVarTuple xs
640
      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
641
      parStmts qss (mkLHsVarPatTup xs) cqs
chak's avatar
chak committed
642 643
    ---
    parStmts []             pa cea = return (pa, cea)
644
    parStmts ((qs, xs):qss) pa cea = do  -- subsequent statements (zip'ed)
645
      zipP <- dsLookupDPHId zipPName
646
      let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
647
          ty'cea   = parrElemType cea
648
          res_expr = mkLHsVarTuple xs
649
      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
chak's avatar
chak committed
650
      let ty'cqs = parrElemType cqs
651
          cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
chak's avatar
chak committed
652
      parStmts qss pa' cea'
chak's avatar
chak committed
653 654 655

-- generate Core corresponding to `\p -> e'
--
656 657 658 659 660
deLambda :: Type			-- type of the argument
	  -> LPat Id			-- argument pattern
	  -> LHsExpr Id			-- body
	  -> DsM (CoreExpr, Type)
deLambda ty p e =
661
    mkLambda ty p =<< dsLExpr e
662 663 664 665 666 667 668

-- 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)
669 670
mkLambda ty p ce = do
    v <- newSysLocalDs ty
671
    let errMsg = ptext (sLit "DsListComp.deLambda: internal error!")
672 673 674 675
        ce'ty  = exprType ce
    cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg
    res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr
    return (mkLams [v] res, ce'ty)
chak's avatar
chak committed
676 677 678 679 680 681 682

-- 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
683
    Just (tycon, [ty]) | tycon == parrTyCon -> ty
chak's avatar
chak committed
684 685 686
    _							  -> panic
      "DsListComp.parrElemType: not a parallel array type"
\end{code}
687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705

Translation for monad comprehensions

\begin{code}

-- | Keep the "context" of a monad comprehension in a small data type to avoid
-- some boilerplate...
data DsMonadComp = DsMonadComp
    { mc_return :: Either (SyntaxExpr Id) (Expr CoreBndr)
    , mc_body   :: LHsExpr Id
    , mc_m_ty   :: Type
    }

--
-- Entry point for monad comprehension desugaring
--
dsMonadComp :: [LStmt Id]       -- the statements
            -> Type             -- the final type
            -> DsM CoreExpr
706
dsMonadComp stmts res_ty
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729
  = dsMcStmts stmts (DsMonadComp (Left return_op) body m_ty)
  where
    (m_ty, _) = tcSplitAppTy res_ty


dsMcStmts :: [LStmt Id]
          -> DsMonadComp
          -> DsM CoreExpr

-- No statements left for desugaring. Desugar the body after calling "return"
-- on it.
dsMcStmts [] DsMonadComp { mc_return, mc_body }
  = case mc_return of
         Left ret   -> dsLExpr $ noLoc ret `nlHsApp` mc_body
         Right ret' -> do
             { body' <- dsLExpr mc_body
             ; return $ mkApps ret' [body'] }

-- Otherwise desugar each statement step by step
dsMcStmts ((L loc stmt) : lstmts) mc
  = putSrcSpanDs loc (dsMcStmt stmt lstmts mc)


730 731 732 733 734 735 736
dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr

dsMcStmt (LastStmt body ret_op) stmts
  = ASSERT( null stmts )
    do { body' <- dsLExpr body
       ; ret_op' <- dsExpr ret_op
       ; return (App ret_op' body') }
737 738

--   [ .. | let binds, stmts ]
739 740
dsMcStmt (LetStmt binds) stmts 
  = do { rest <- dsMcStmts stmts
741 742 743
       ; dsLocalBinds binds rest }

--   [ .. | a <- m, stmts ]
744 745 746
dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts
  = do { rhs' <- dsLExpr rhs
       ; dsMcBindStmt pat rhs' bind_op fail_op stmts }
747 748 749 750 751

-- Apply `guard` to the `exp` expression
--
--   [ .. | exp, stmts ]
--
752
dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts 
753 754 755
  = do { exp'       <- dsLExpr exp
       ; guard_exp' <- dsExpr guard_exp
       ; then_exp'  <- dsExpr then_exp
756
       ; rest       <- dsMcStmts stmts
757 758 759 760 761 762 763 764 765
       ; return $ mkApps then_exp' [ mkApps guard_exp' [exp']
                                   , rest ] }

-- Transform statements desugar like this:
--
--   [ .. | qs, then f by e ]  ->  f (\q_v -> e) [| qs |]
--
-- where [| qs |] is the desugared inner monad comprehenion generated by the
-- statements `qs`.
766 767 768
dsMcStmt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) stmts_rest
  = do { expr <- dsInnerMonadComp stmts binders return_op
       ; let binders_tup_type = mkBigCoreTupTy $ map idType binders
769 770 771 772 773 774
       ; usingExpr' <- dsLExpr usingExpr
       ; using_args <- case maybeByExpr of
            Nothing -> return [expr]
            Just byExpr -> do
                byExpr' <- dsLExpr byExpr
                us <- newUniqueSupply
775 776 777
                tup_binder <- newSysLocalDs binders_tup_type
                let byExprWrapper = mkTupleCase us binders byExpr' tup_binder (Var tup_binder)
                return [Lam tup_binder byExprWrapper, expr]
778 779

       ; let pat = mkBigLHsVarPatTup binders
780
             rhs = mkApps usingExpr' ((Type binders_tup_type) : using_args)
781

782
       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
783 784 785

-- Group statements desugar like this:
--
786 787 788 789 790 791 792 793 794 795 796 797
--   [| (q, then group by e using f); rest |]
--   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> 
--         case unzip n_tup of qv -> [| rest |]
--
-- where   variables (v1:t1, ..., vk:tk) are bound by q
--         qv = (v1, ..., vk)
--         qt = (t1, ..., tk)
--         (>>=) :: m2 a -> (a -> m3 b) -> m3 b
--         f :: forall a. (a -> t) -> m1 a -> m2 (n a)
--         n_tup :: n qt
--         unzip :: n qt -> (n t1, ..., n tk)    (needs Functor n)
--
798 799 800 801 802 803 804 805
--   [| q, then group by e using f |]  ->  (f (\q_v -> e) [| q |]) >>= (return . (unzip q_v))
--
-- which is equal to
--
--   [| q, then group by e using f |]  ->  liftM (unzip q_v) (f (\q_v -> e) [| q |])
--
-- where unzip is of the form
--
806 807 808
--   unzip :: n (a,b,c,..) -> (n a,n b,n c,..)
--   unzip m_tuple = ( fmap selN1 m_tuple
--                   , fmap selN2 m_tuple
809 810 811 812 813
--                   , .. )
--     where selN1 (a,b,c,..) = a
--           selN2 (a,b,c,..) = b
--           ..
--
814
dsMcStmt (GroupStmt stmts binderMap by using return_op bind_op fmap_op) stmts_rest
815
  = do { let (fromBinders, toBinders) = unzip binderMap
816
             fromBindersTypes         = map idType fromBinders		-- Types ty
817
             fromBindersTupleTy       = mkBigCoreTupTy fromBindersTypes
818
             toBindersTypes           = map idType toBinders		-- Types (n ty)
819 820 821
             toBindersTupleTy         = mkBigCoreTupTy toBindersTypes

       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
822
       ; expr <- dsInnerMonadComp stmts fromBinders return_op
823 824 825 826 827 828 829

       -- Work out what arguments should be supplied to that expression: i.e. is an extraction
       -- function required? If so, create that desugared function and add to arguments
       ; usingExpr' <- dsLExpr (either id noLoc using)
       ; usingArgs <- case by of
                        Nothing   -> return [expr]
                        Just by_e -> do { by_e' <- dsLExpr by_e
830 831
                                        ; lam <- matchTuple fromBinders by_e'
                                        ; return [lam, expr] }
832 833

       -- Create an unzip function for the appropriate arity and element types
834 835
       ; fmap_op' <- dsExpr fmap_op
       ; (unzip_fn, unzip_rhs) <- mkMcUnzipM fmap_op' m_ty fromBindersTypes
836 837

       -- Generate the expressions to build the grouped list
838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853
       -- Build a pattern that ensures the consumer binds into the NEW binders, 
       -- which hold monads rather than single values
       ; bind_op' <- dsExpr bind_op
       ; let bind_ty = exprType bind_op'    -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2
             n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty

       ; body      <- dsMcStmts stmts_rest
       ; n_tup_var <- newSysLocalDs n_tup_ty
       ; tup_n_var <- newSysLocalDs (mkBigCoreVarTupTy toBinders)
       ; us        <- newUniqueSupply
       ; let unzip_n_tup = Let (Rec [(unzip_fn, unzip_rhs)]) $
                           App (Var unzip_fn) (Var n_tup_var)
	     -- unzip_n_tup :: (n a, n b, n c)
             body' = mkTupleCase us toBinders body unzip_n_tup (Var tup_n_var)
		   
       ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) }
854 855 856 857 858

-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
-- statements, for example:
--
--   [ body | qs1 | qs2 | qs3 ]
859 860
--     ->  [ body | (bndrs1, (bndrs2, bndrs3)) 
--                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
861
--
862 863 864
-- where `mzip` has type
--   mzip :: forall a b. m a -> m b -> m (a,b)
-- NB: we need a polymorphic mzip because we call it several times
865

866 867 868
dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest
 = do  { exps <- mapM ds_inner pairs
       ; let qual_tys = map (mkBigCoreVarTupTy . snd) pairs
869 870 871 872 873 874 875 876 877 878
       ; mzip_op' <- dsExpr mzip_op
       ; (zip_fn, zip_rhs) <- mkMcZipM mzip_op' (mc_m_ty mc) qual_tys

       ; let -- The pattern variables
             vars = map (mkBigLHsVarPatTup . snd) pairs
             -- Pattern with tuples of variables
             -- [v1,v2,v3]  =>  (v1, (v2, v3))
             pat = foldr (\tn tm -> mkBigLHsPatTup [tn, tm]) (last vars) (init vars)
             rhs = Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)

879 880 881 882 883
       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
  where
    ds_inner (stmts, bndrs) = dsInnerMonadComp stmts bndrs mono_ret_op
       where 
         mono_ret_op = HsWrap (WpTyApp (mkBigCoreVarTupTy bndrs)) return_op
884

885 886 887 888 889 890 891 892 893 894 895
dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)


matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
-- (matchTuple [a,b,c] body)
--       returns the Core term
--  \x. case x of (a,b,c) -> body 
matchTuple ids body
  = do { us <- newUniqueSupply
       ; tup_id <- newSysLocalDs (mkBigLHsVarPatTup ids)
       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
896 897 898 899 900 901 902 903 904 905


-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
-- desugared `CoreExpr`
dsMcBindStmt :: LPat Id
             -> CoreExpr        -- ^ the desugared rhs of the bind statement
             -> SyntaxExpr Id
             -> SyntaxExpr Id
             -> [LStmt Id]
             -> DsM CoreExpr
906 907
dsMcBindStmt pat rhs' bind_op fail_op stmts
  = do  { body     <- dsMcStmts stmts 
908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932
        ; bind_op' <- dsExpr bind_op
        ; var      <- selectSimpleMatchVarL pat
        ; let bind_ty = exprType bind_op' 	-- rhs -> (pat -> res1) -> res2
              res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
        ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
                                  res1_ty (cantFailMatchResult body)
        ; match_code <- handle_failure pat match fail_op
        ; return (mkApps bind_op' [rhs', Lam var match_code]) }

  where
    -- In a monad comprehension expression, pattern-match failure just calls
    -- the monadic `fail` rather than throwing an exception
    handle_failure pat match fail_op
      | matchCanFail match
        = do { fail_op' <- dsExpr fail_op
             ; fail_msg <- mkStringExpr (mk_fail_msg pat)
             ; extractMatchResult match (App fail_op' fail_msg) }
      | otherwise
        = extractMatchResult match (error "It can't fail") 

    mk_fail_msg :: Located e -> String
    mk_fail_msg pat = "Pattern match failure in monad comprehension at " ++ 
                      showSDoc (ppr (getLoc pat))

-- Desugar nested monad comprehensions, for example in `then..` constructs
933 934 935 936 937 938 939 940 941 942
--    dsInnerMonadComp quals [a,b,c] ret_op
-- returns the desugaring of 
--       [ (a,b,c) | quals ]

dsInnerMonadComp :: [LStmt Id]
                 -> [Id]	-- Return a tuple of these variables
                 -> LHsExpr Id	-- The monomorphic "return" operator
                 -> DsM CoreExpr
dsInnerMonadComp stmts bndrs ret_op
  = dsMcStmts (stmts ++ [noLoc (ReturnStmt (mkBigLHsVarTup bndrs) ret_op)])
943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032

-- The `unzip` function for `GroupStmt` in a monad comprehensions
--
--   unzip :: m (a,b,..) -> (m a,m b,..)
--   unzip m_tuple = ( liftM selN1 m_tuple
--                   , liftM selN2 m_tuple
--                   , .. )
--
--   mkMcUnzipM m [t1, t2]
--     = (unzip_fn, \ys :: m (t1, t2) ->
--         ( liftM (selN1 :: (t1, t2) -> t1) ys
--         , liftM (selN2 :: (t1, t2) -> t2) ys
--         ))
--
mkMcUnzipM :: CoreExpr
           -> Type                      -- m
           -> [Type]                    -- [a,b,c,..]
           -> DsM (Id, CoreExpr)
mkMcUnzipM liftM_op m_ty elt_tys
  = do  { ys    <- newSysLocalDs monad_tuple_ty
        ; xs    <- mapM newSysLocalDs elt_tys
        ; scrut <- newSysLocalDs tuple_tys

        ; unzip_fn <- newSysLocalDs unzip_fn_ty

        ; let -- Select one Id from our tuple
              selectExpr n = mkLams [scrut] $ mkTupleSelector xs (xs !! n) scrut (Var scrut)
              -- Apply 'selectVar' and 'ys' to 'liftM'
              tupleElem n = mkApps liftM_op
                                   -- Types (m is figured out by the type checker):
                                   -- liftM :: forall a b. (a -> b) -> m a -> m b
                                   [ Type tuple_tys, Type (elt_tys !! n)
                                   -- Arguments:
                                   , selectExpr n, Var ys ]
              -- The final expression with the big tuple
              unzip_body = mkBigCoreTup [ tupleElem n | n <- [0..length elt_tys - 1] ]

        ; return (unzip_fn, mkLams [ys] unzip_body) }
  where monad_tys       = map (m_ty `mkAppTy`) elt_tys                  -- [m a,m b,m c,..]
        tuple_monad_tys = mkBigCoreTupTy monad_tys                      -- (m a,m b,m c,..)
        tuple_tys       = mkBigCoreTupTy elt_tys                        -- (a,b,c,..)
        monad_tuple_ty  = m_ty `mkAppTy` tuple_tys                      -- m (a,b,c,..)
        unzip_fn_ty     = monad_tuple_ty `mkFunTy` tuple_monad_tys      -- m (a,b,c,..) -> (m a,m b,m c,..)

-- Generate the `mzip` function for `ParStmt` in monad comprehensions, for
-- example:
--
--   mzip :: m t1
--        -> (m t2 -> m t3 -> m (t2, t3))
--        -> m (t1, (t2, t3))
--
--   mkMcZipM m [t1, t2, t3]
--     = (zip_fn, \(q1::t1) (q2::t2) (q3::t3) ->
--         mzip q1 (mzip q2 q3))
--
mkMcZipM :: CoreExpr
         -> Type
         -> [Type]
         -> DsM (Id, CoreExpr)

mkMcZipM mzip_op m_ty tys@(_:_:_) -- min. 2 types
 = do  { (ids, t1, tuple_ty, zip_body) <- loop tys
       ; zip_fn <- newSysLocalDs $
                       (m_ty `mkAppTy` t1)
                       `mkFunTy`
                       (m_ty `mkAppTy` tuple_ty)
                       `mkFunTy`
                       (m_ty `mkAppTy` mkBigCoreTupTy [t1, tuple_ty])
       ; return (zip_fn, mkLams ids zip_body) }

 where 
       -- loop :: [Type] -> DsM ([Id], Type, [Type], CoreExpr)
       loop [t1, t2] = do -- last run of the `loop`
           { ids@[a,b] <- newSysLocalsDs (map (m_ty `mkAppTy`) [t1,t2])
           ; let zip_body = mkApps mzip_op [ Type t1, Type t2 , Var a, Var b ]
           ; return (ids, t1, t2, zip_body) }

       loop (t1:tr) = do
           { -- Get ty, ids etc from the "inner" zip
             (ids', t1', t2', zip_body') <- loop tr

           ; a <- newSysLocalDs $ m_ty `mkAppTy` t1
           ; let tuple_ty' = mkBigCoreTupTy [t1', t2']
                 zip_body = mkApps mzip_op [ Type t1, Type tuple_ty', Var a, zip_body' ]
           ; return ((a:ids'), t1, tuple_ty', zip_body) }

-- This case should never happen:
mkMcZipM _ _ tys = pprPanic "mkMcZipM: unexpected argument" (ppr tys)

\end{code}