DsListComp.lhs 33.4 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

11
module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
12

13 14
#include "HsVersions.h"

15
import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
16

17
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
18
import TcHsSyn
19
import CoreSyn
20
import MkCore
21

22
import DsMonad          -- the monadery used in the desugarer
23
import DsUtils
24

Simon Marlow's avatar
Simon Marlow committed
25 26
import DynFlags
import CoreUtils
27
import Id
Simon Marlow's avatar
Simon Marlow committed
28 29 30 31 32
import Type
import TysWiredIn
import Match
import PrelNames
import SrcLoc
33
import Outputable
34
import FastString
35
import TcType
36
import Util
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 :: [ExprLStmt Id]
47 48 49
           -> Type              -- Type of entire list
           -> DsM CoreExpr
dsListComp lquals res_ty = do
50
    dflags <- getDynFlags
51
    let quals = map unLoc lquals
52 53 54
        elt_ty = case tcTyConAppArgs res_ty of
                   [elt_ty] -> elt_ty
                   _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
55

56
    if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
57 58 59 60 61
       -- 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 (mkNilExpr elt_ty)
63 64
        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
             -- Foldr/build should be enabled, so desugar
65
             -- into foldrs and builds
66

67
  where
68 69 70 71 72
    -- 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
73

74 75
    isParallelStmt (ParStmt {}) = True
    isParallelStmt _            = False
76 77


78 79 80
-- 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)
81 82
dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type)
dsInnerListComp (ParStmtBlock stmts bndrs _)
83
  = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])
84
                            (mkListTy bndrs_tuple_type)
85 86 87
       ; return (expr, bndrs_tuple_type) }
  where
    bndrs_tuple_type = mkBigCoreVarTupTy bndrs
88

89 90 91
-- 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
92
dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id)
93 94 95 96 97 98
dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
                       , trS_by = by, trS_using = using }) = do
    let (from_bndrs, to_bndrs) = unzip binderMap
        from_bndrs_tys  = map idType from_bndrs
        to_bndrs_tys    = map idType to_bndrs
        to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
99

100
    -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
101
    (expr, from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)
102

103 104
    -- 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
105
    usingExpr' <- dsLExpr using
106 107
    usingArgs <- case by of
                   Nothing   -> return [expr]
108
                   Just by_e -> do { by_e' <- dsLExpr by_e
109 110
                                   ; lam <- matchTuple from_bndrs by_e'
                                   ; return [lam, expr] }
111

112
    -- Create an unzip function for the appropriate arity and element types and find "map"
113
    unzip_stuff <- mkUnzipBind form from_bndrs_tys
114 115 116 117
    map_id <- dsLookupGlobalId mapName

    -- Generate the expressions to build the grouped list
    let -- First we apply the grouping function to the inner list
118
        inner_list_expr = mkApps usingExpr' usingArgs
119 120 121 122
        -- 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!
        -- Then finally we bind the unzip function around that expression
123
        bound_unzipped_inner_list_expr
124 125 126 127 128 129 130 131 132
          = case unzip_stuff of
              Nothing -> inner_list_expr
              Just (unzip_fn, unzip_rhs) -> Let (Rec [(unzip_fn, unzip_rhs)]) $
                                            mkApps (Var map_id) $
                                            [ Type (mkListTy from_tup_ty)
                                            , Type to_bndrs_tup_ty
                                            , Var unzip_fn
                                            , inner_list_expr]

133
    -- Build a pattern that ensures the consumer binds into the NEW binders,
134 135
    -- which hold lists rather than single values
    let pat = mkBigLHsVarPatTup to_bndrs
136
    return (bound_unzipped_inner_list_expr, pat)
137 138

dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"
139 140 141
\end{code}

%************************************************************************
142
%*                                                                      *
143
\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
144
%*                                                                      *
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168
%************************************************************************

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 ->
169 170 171 172 173
          case u1 of
            []        ->  TE << L2 >>
            (u2 : u3) ->
                  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
                    [] (h u3)
174 175 176 177 178 179 180 181 182 183
  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.

184 185 186 187 188
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]
     =>
189 190 191 192 193 194
     [ 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

195
In the translation below, the ParStmt branch translates each parallel branch
196 197 198 199 200 201 202 203
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.
204

205
\begin{code}
206

207
deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr
208 209

deListComp [] _ = panic "deListComp"
210

211
deListComp (LastStmt body _ : quals) list
212 213 214 215 216
  =     -- 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) }

217
        -- Non-last: must be a guard
218
deListComp (BodyStmt guard _ _ _ : quals) list = do  -- rule B above
219 220 221 222 223 224 225 226 227
    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

228 229
deListComp (stmt@(TransStmt {}) : quals) list = do
    (inner_list_expr, pat) <- dsTransStmt stmt
230 231 232 233 234 235
    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

236
deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list
237 238
  = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
       ; let (exps, qual_tys) = unzip exps_and_qual_tys
239

240
       ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
241

242 243 244 245
        -- Deal with [e | pat <- zip l1 .. ln] in example above
       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
                    quals list }
  where
246
        bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
247

248 249 250
        -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
        pat  = mkBigLHsPatTup pats
        pats = map mkBigLHsVarPatTup bndrs_s
251 252

deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
253 254
\end{code}

255

256
\begin{code}
257 258
deBindComp :: OutPat Id
           -> CoreExpr
259
           -> [ExprStmt Id]
260 261
           -> CoreExpr
           -> DsM (Expr Id)
262
deBindComp pat core_list1 quals core_list2 = do
263
    let
264
        u3_ty@u1_ty = exprType core_list1       -- two names, same thing
265

266 267
        -- u1_ty is a [alpha] type, and u2_ty = alpha
        u2_ty = hsLPatType pat
268

269 270
        res_ty = exprType core_list2
        h_ty   = u1_ty `mkFunTy` res_ty
271

272
    [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
273

274
    -- the "fail" value ...
275
    let
276 277
        core_fail   = App (Var h) (Var u3)
        letrec_body = App (Var h) core_list1
278

279
    rest_expr <- deListComp quals core_fail
280 281
    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail

282
    let
283
        rhs = Lam u1 $
284 285 286 287 288
              Case (Var u1) u1 res_ty
                   [(DataAlt nilDataCon,  [],       core_list2),
                    (DataAlt consDataCon, [u2, u3], core_match)]
                        -- Increasing order of tag

289
    return (Let (Rec [(h, rhs)]) letrec_body)
290 291
\end{code}

292
%************************************************************************
293
%*                                                                      *
294
\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
295
%*                                                                      *
296 297 298
%************************************************************************

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

300
\begin{verbatim}
301 302
TE[ e | ]            c n = c e n
TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n
303 304 305 306 307 308
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
309
\end{verbatim}
310

311
\begin{code}
312 313
dfListComp :: Id -> Id      -- 'c' and 'n'
        -> [ExprStmt Id]    -- the rest of the qual's
314
        -> DsM CoreExpr
315

316 317
dfListComp _ _ [] = panic "dfListComp"

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

323
        -- Non-last: must be a guard
324
dfListComp c_id n_id (BodyStmt guard _ _ _  : quals) = do
325
    core_guard <- dsLExpr guard
326
    core_rest <- dfListComp c_id n_id quals
327 328
    return (mkIfThenElse core_guard core_rest (Var n_id))

329
dfListComp c_id n_id (LetStmt binds : quals) = do
330
    -- new in 1.3, local bindings
331
    core_rest <- dfListComp c_id n_id quals
332
    dsLocalBinds binds core_rest
333

334 335
dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
    (inner_list_expr, pat) <- dsTransStmt stmt
336
    -- Anyway, we bind the newly grouped list via the generic binding function
337 338
    dfBindComp c_id n_id (pat, inner_list_expr) quals

339
dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do
340
    -- evaluate the two lists
341
    core_list1 <- dsLExpr list1
342

343
    -- Do the rest of the work in the generic binding builder
344
    dfBindComp c_id n_id (pat, core_list1) quals
345

346 347 348
dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"

349
dfBindComp :: Id -> Id          -- 'c' and 'n'
350 351
           -> (LPat Id, CoreExpr)
           -> [ExprStmt Id]     -- the rest of the qual's
352
           -> DsM CoreExpr
353
dfBindComp c_id n_id (pat, core_list1) quals = do
354
    -- find the required type
355
    let x_ty   = hsLPatType pat
356
        b_ty   = idType n_id
357 358

    -- create some new local id's
359
    [b, x] <- newSysLocalsDs [b_ty, x_ty]
360 361

    -- build rest of the comprehesion
362
    core_rest <- dfListComp c_id b quals
363 364

    -- build the pattern match
365
    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
366
                pat core_rest (Var b)
367 368

    -- now build the outermost foldr, and return
369
    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
370 371 372
\end{code}

%************************************************************************
373
%*                                                                      *
374
\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
375
%*                                                                      *
376 377 378 379 380
%************************************************************************

\begin{code}

mkZipBind :: [Type] -> DsM (Id, CoreExpr)
381 382 383 384 385 386 387
-- 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)]
388 389

mkZipBind elt_tys = do
390 391 392
    ass  <- mapM newSysLocalDs  elt_list_tys
    as'  <- mapM newSysLocalDs  elt_tys
    as's <- mapM newSysLocalDs  elt_list_tys
393

394
    zip_fn <- newSysLocalDs zip_fn_ty
395 396 397 398

    let inner_rhs = mkConsExpr elt_tuple_ty
                        (mkBigCoreVarTup as')
                        (mkVarApps (Var zip_fn) as's)
399
        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
400

401 402 403 404 405
    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
406

407 408 409
    zip_fn_ty         = mkFunTys elt_list_tys elt_tuple_list_ty

    mk_case (as, a', as') rest
410 411 412 413 414 415
          = Case (Var as) as elt_tuple_list_ty
                  [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),
                   (DataAlt consDataCon, [a', as'], rest)]
                        -- Increasing order of tag


416
mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
417
-- mkUnzipBind [t1, t2]
418 419 420 421 422 423
-- = (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)
424
--
425
-- We use foldr here in all cases, even if rules are turned off, because we may as well!
426 427
mkUnzipBind ThenForm _
 = return Nothing    -- No unzipping for ThenForm
428
mkUnzipBind _ elt_tys
429 430 431 432 433
  = do { ax  <- newSysLocalDs elt_tuple_ty
       ; axs <- newSysLocalDs elt_list_tuple_ty
       ; ys  <- newSysLocalDs elt_tuple_list_ty
       ; xs  <- mapM newSysLocalDs elt_tys
       ; xss <- mapM newSysLocalDs elt_list_tys
434

435 436 437 438 439
       ; unzip_fn <- newSysLocalDs unzip_fn_ty

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

       ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
440 441 442 443 444 445 446
             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

447 448
       ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
       ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
449 450 451 452 453
  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
454

455
    unzip_fn_ty        = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
456

457
    mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
458 459
\end{code}

chak's avatar
chak committed
460
%************************************************************************
461
%*                                                                      *
chak's avatar
chak committed
462
\subsection[DsPArrComp]{Desugaring of array comprehensions}
463
%*                                                                      *
chak's avatar
chak committed
464 465 466 467 468 469 470 471
%************************************************************************

\begin{code}

-- entry point for desugaring a parallel array comprehension
--
--   [:e | qss:] = <<[:e | qss:]>> () [:():]
--
472
dsPArrComp :: [ExprStmt Id]
473
            -> DsM CoreExpr
474 475

-- Special case for parallel comprehension
476
dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals
477 478 479 480 481 482 483

-- Special case for simple generators:
--
--  <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e
--
-- if matching again p cannot fail, or else
--
484
--  <<[:e' | p <- e, qs:]>> =
485 486
--    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
--
487
dsPArrComp (BindStmt p e _ _ : qs) = do
488
    filterP <- dsDPHBuiltin filterPVar
489 490 491 492 493 494 495 496
    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]
497
    dePArrComp qs p gen
498

499
dsPArrComp qs = do -- no ParStmt in `qs'
500
    sglP <- dsDPHBuiltin singletonPVar
501
    let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
502
    dePArrComp qs (noLoc $ WildPat unitTy) unitArray
503

504 505


chak's avatar
chak committed
506 507
-- the work horse
--
508
dePArrComp :: [ExprStmt Id]
509 510 511
           -> LPat Id           -- the current generator pattern
           -> CoreExpr          -- the current generator expression
           -> DsM CoreExpr
512 513 514

dePArrComp [] _ _ = panic "dePArrComp"

chak's avatar
chak committed
515 516 517
--
--  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
518 519
dePArrComp (LastStmt e' _ : quals) pa cea
  = ASSERT( null quals )
520
    do { mapP <- dsDPHBuiltin mapPVar
521 522 523
       ; 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
524 525 526
--
--  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
527
dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do
528
    filterP <- dsDPHBuiltin filterPVar
529 530
    let ty = parrElemType cea
    (clam,_) <- deLambda ty pa b
531
    dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
532 533 534 535 536 537 538 539

--
--  <<[: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
540
--
541
--  <<[:e' | p <- e, qs:]>> pa ea =
542
--    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
chak's avatar
chak committed
543
--    in
544
--    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
chak's avatar
chak committed
545
--
546
dePArrComp (BindStmt p e _ _ : qs) pa cea = do
547 548
    filterP <- dsDPHBuiltin filterPVar
    crossMapP <- dsDPHBuiltin crossMapPVar
549 550 551 552 553 554 555 556 557 558
    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
559
    let ety'cef = ety'ce                    -- filter doesn't change the element type
560 561
        pa'     = mkLHsPatTup [pa, p]

562
    dePArrComp qs pa' (mkApps (Var crossMapP)
563
                                 [Type ety'cea, Type ety'cef, cea, clam])
chak's avatar
chak committed
564
--
565 566 567
--  <<[:e' | let ds, qs:]>> pa ea =
--    <<[:e' | qs:]>> (pa, (x_1, ..., x_n))
--                    (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)
chak's avatar
chak committed
568
--  where
569
--    {x_1, ..., x_n} = DV (ds)         -- Defined Variables
chak's avatar
chak committed
570
--
571
dePArrComp (LetStmt ds : qs) pa cea = do
572
    mapP <- dsDPHBuiltin mapPVar
573
    let xs     = collectLocalBinders ds
574 575 576 577
        ty'cea = parrElemType cea
    v <- newSysLocalDs ty'cea
    clet <- dsLocalBinds ds (mkCoreTup (map Var xs))
    let'v <- newSysLocalDs (exprType clet)
578
    let projBody = mkCoreLet (NonRec let'v clet) $
579 580
                   mkCoreTup [Var v, Var let'v]
        errTy    = exprType projBody
581
        errMsg   = ptext (sLit "DsListComp.dePArrComp: internal error!")
582 583 584 585
    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
586
    dePArrComp qs pa' (mkApps (Var mapP)
587
                                   [Type ty'cea, Type errTy, proj, cea])
chak's avatar
chak committed
588
--
589 590 591 592
-- 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.
--
593
dePArrComp (ParStmt {} : _) _ _ =
594 595 596
  panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"
dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"
dePArrComp (RecStmt   {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
597

598 599 600
--  <<[:e' | qs | qss:]>> pa ea =
--    <<[:e' | qss:]>> (pa, (x_1, ..., x_n))
--                     (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
chak's avatar
chak committed
601 602 603
--    where
--      {x_1, ..., x_n} = DV (qs)
--
604
dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr
605
dePArrParComp qss quals = do
606
    (pQss, ceQss) <- deParStmt qss
607
    dePArrComp quals pQss ceQss
chak's avatar
chak committed
608 609
  where
    deParStmt []             =
610
      -- empty parallel statement lists have no source representation
chak's avatar
chak committed
611
      panic "DsListComp.dePArrComp: Empty parallel list comprehension"
612
    deParStmt (ParStmtBlock qs xs _:qss) = do        -- first statement
613
      let res_expr = mkLHsVarTuple xs
614
      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
615
      parStmts qss (mkLHsVarPatTup xs) cqs
chak's avatar
chak committed
616 617
    ---
    parStmts []             pa cea = return (pa, cea)
618
    parStmts (ParStmtBlock qs xs _:qss) pa cea = do  -- subsequent statements (zip'ed)
619
      zipP <- dsDPHBuiltin zipPVar
620
      let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
621
          ty'cea   = parrElemType cea
622
          res_expr = mkLHsVarTuple xs
623
      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
chak's avatar
chak committed
624
      let ty'cqs = parrElemType cqs
625
          cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
chak's avatar
chak committed
626
      parStmts qss pa' cea'
chak's avatar
chak committed
627 628 629

-- generate Core corresponding to `\p -> e'
--
630 631 632 633
deLambda :: Type                        -- type of the argument
          -> LPat Id                    -- argument pattern
          -> LHsExpr Id                 -- body
          -> DsM (CoreExpr, Type)
634
deLambda ty p e =
635
    mkLambda ty p =<< dsLExpr e
636 637 638

-- generate Core for a lambda pattern match, where the body is already in Core
--
639 640 641 642
mkLambda :: Type                        -- type of the argument
         -> LPat Id                     -- argument pattern
         -> CoreExpr                    -- desugared body
         -> DsM (CoreExpr, Type)
643 644
mkLambda ty p ce = do
    v <- newSysLocalDs ty
645
    let errMsg = ptext (sLit "DsListComp.deLambda: internal error!")
646 647 648 649
        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
650 651 652 653 654

-- obtain the element type of the parallel array produced by the given Core
-- expression
--
parrElemType   :: CoreExpr -> Type
655
parrElemType e  =
chak's avatar
chak committed
656
  case splitTyConApp_maybe (exprType e) of
657
    Just (tycon, [ty]) | tycon == parrTyCon -> ty
658
    _                                                     -> panic
chak's avatar
chak committed
659 660
      "DsListComp.parrElemType: not a parallel array type"
\end{code}
661 662 663 664 665

Translation for monad comprehensions

\begin{code}
-- Entry point for monad comprehension desugaring
666
dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr
667
dsMonadComp stmts = dsMcStmts stmts
668

669
dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr
670 671
dsMcStmts []                    = panic "dsMcStmts"
dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
672

673
---------------
674
dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr
675 676 677 678 679 680

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

--   [ .. | let binds, stmts ]
683
dsMcStmt (LetStmt binds) stmts
684
  = do { rest <- dsMcStmts stmts
685 686 687
       ; dsLocalBinds binds rest }

--   [ .. | a <- m, stmts ]
688 689 690
dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts
  = do { rhs' <- dsLExpr rhs
       ; dsMcBindStmt pat rhs' bind_op fail_op stmts }
691 692 693 694 695

-- Apply `guard` to the `exp` expression
--
--   [ .. | exp, stmts ]
--
696
dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
697 698 699
  = do { exp'       <- dsLExpr exp
       ; guard_exp' <- dsExpr guard_exp
       ; then_exp'  <- dsExpr then_exp
700
       ; rest       <- dsMcStmts stmts
701 702 703 704 705
       ; return $ mkApps then_exp' [ mkApps guard_exp' [exp']
                                   , rest ] }

-- Group statements desugar like this:
--
706
--   [| (q, then group by e using f); rest |]
707
--   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
708
--         case unzip n_tup of qv' -> [| rest |]
709 710 711 712 713 714 715 716
--
-- 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)
717

718 719 720 721
dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
                    , trS_by = by, trS_using = using
                    , trS_ret = return_op, trS_bind = bind_op
                    , trS_fmap = fmap_op, trS_form = form }) stmts_rest
722
  = do { let (from_bndrs, to_bndrs) = unzip bndrs
723
             from_bndr_tys          = map idType from_bndrs     -- Types ty
724 725

       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
726
       ; expr <- dsInnerMonadComp stmts from_bndrs return_op
727 728 729

       -- 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
730
       ; usingExpr' <- dsLExpr using
731 732 733
       ; usingArgs <- case by of
                        Nothing   -> return [expr]
                        Just by_e -> do { by_e' <- dsLExpr by_e
734
                                        ; lam <- matchTuple from_bndrs by_e'
735
                                        ; return [lam, expr] }
736 737

       -- Generate the expressions to build the grouped list
738
       -- Build a pattern that ensures the consumer binds into the NEW binders,
739 740
       -- which hold monads rather than single values
       ; bind_op' <- dsExpr bind_op
741
       ; let bind_ty  = exprType bind_op'    -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2
742 743 744 745 746 747
             n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty   -- n (a,b,c)
             tup_n_ty = mkBigCoreVarTupTy to_bndrs

       ; body       <- dsMcStmts stmts_rest
       ; n_tup_var  <- newSysLocalDs n_tup_ty
       ; tup_n_var  <- newSysLocalDs tup_n_ty
748
       ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys
749 750 751
       ; us         <- newUniqueSupply
       ; let rhs'  = mkApps usingExpr' usingArgs
             body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr
752

753
       ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) }
754 755 756 757 758

-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
-- statements, for example:
--
--   [ body | qs1 | qs2 | qs3 ]
759
--     ->  [ body | (bndrs1, (bndrs2, bndrs3))
760
--                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
761
--
762 763 764
-- 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
765

766 767
dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest
 = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)
768
       ; mzip_op'    <- dsExpr mzip_op
769 770

       ; let -- The pattern variables
771
             pats = [ mkBigLHsVarPatTup bs | ParStmtBlock _ bs _ <- blocks]
772 773
             -- Pattern with tuples of variables
             -- [v1,v2,v3]  =>  (v1, (v2, v3))
774
             pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
775
             (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
776
                                 (mkApps mzip_op' [Type t1, Type t2, e1, e2],
777
                                  mkBoxedTupleTy [t1,t2]))
778
                               exps_w_tys
779

780 781
       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
  where
782 783 784
    ds_inner (ParStmtBlock stmts bndrs return_op) 
       = do { exp <- dsInnerMonadComp stmts bndrs return_op
            ; return (exp, mkBigCoreVarTupTy bndrs) }
785

786 787 788 789 790 791
dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)


matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
-- (matchTuple [a,b,c] body)
--       returns the Core term
792
--  \x. case x of (a,b,c) -> body
793 794
matchTuple ids body
  = do { us <- newUniqueSupply
795
       ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
796
       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
797 798 799 800 801 802 803

-- 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
804
             -> [ExprLStmt Id]
805
             -> DsM CoreExpr
806
dsMcBindStmt pat rhs' bind_op fail_op stmts
807
  = do  { body     <- dsMcStmts stmts
808 809
        ; bind_op' <- dsExpr bind_op
        ; var      <- selectSimpleMatchVarL pat
810
        ; let bind_ty = exprType bind_op'       -- rhs -> (pat -> res1) -> res2
811 812 813 814 815 816 817 818 819 820 821 822
              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
Ian Lynagh's avatar
Ian Lynagh committed
823 824
             ; dflags <- getDynFlags
             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
825 826
             ; extractMatchResult match (App fail_op' fail_msg) }
      | otherwise
827
        = extractMatchResult match (error "It can't fail")
828

Ian Lynagh's avatar
Ian Lynagh committed
829 830 831 832
    mk_fail_msg :: DynFlags -> Located e -> String
    mk_fail_msg dflags pat
        = "Pattern match failure in monad comprehension at " ++
          showPpr dflags (getLoc pat)
833 834

-- Desugar nested monad comprehensions, for example in `then..` constructs
835
--    dsInnerMonadComp quals [a,b,c] ret_op
836
-- returns the desugaring of
837 838
--       [ (a,b,c) | quals ]

839
dsInnerMonadComp :: [ExprLStmt Id]
840 841
                 -> [Id]        -- Return a tuple of these variables
                 -> HsExpr Id   -- The monomorphic "return" operator
842 843
                 -> DsM CoreExpr
dsInnerMonadComp stmts bndrs ret_op
844
  = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)])
845 846 847 848 849 850 851 852

-- 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
--                   , .. )
--
853 854 855 856
--   mkMcUnzipM fmap ys [t1, t2]
--     = ( fmap (selN1 :: (t1, t2) -> t1) ys
--       , fmap (selN2 :: (t1, t2) -> t2) ys )

857
mkMcUnzipM :: TransForm
858 859 860 861 862
           -> SyntaxExpr TcId   -- fmap
           -> Id                -- Of type n (a,b,c)
           -> [Type]            -- [a,b,c]
           -> DsM CoreExpr      -- Of type (n a, n b, n c)
mkMcUnzipM ThenForm _ ys _
863 864 865 866 867
  = return (Var ys) -- No unzipping to do

mkMcUnzipM _ fmap_op ys elt_tys
  = do { fmap_op' <- dsExpr fmap_op
       ; xs       <- mapM newSysLocalDs elt_tys
868 869
       ; let tup_ty = mkBigCoreTupTy elt_tys
       ; tup_xs   <- newSysLocalDs tup_ty
870

871 872
       ; let mk_elt i = mkApps fmap_op'  -- fmap :: forall a b. (a -> b) -> n a -> n b
                           [ Type tup_ty, Type (elt_tys !! i)
873 874
                           , mk_sel i, Var ys]

875
             mk_sel n = Lam tup_xs $
876
                        mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs)
877

878
       ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
879
\end{code}