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

6
Desugaring list comprehensions, 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 37 38 39 40 41 42 43 44
\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}
45 46 47 48
dsListComp :: [LStmt Id]
           -> Type              -- Type of entire list
           -> DsM CoreExpr
dsListComp lquals res_ty = do
49 50
    dflags <- getDOptsDs
    let quals = map unLoc lquals
51 52 53
        elt_ty = case tcTyConAppArgs res_ty of
                   [elt_ty] -> elt_ty
                   _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
54

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

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

73 74
    isParallelStmt (ParStmt _ _ _ _) = True
    isParallelStmt _                 = False
75 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)
dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
81
dsInnerListComp (stmts, bndrs)
82
  = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])
83
                            (mkListTy bndrs_tuple_type)
84 85 86
       ; return (expr, bndrs_tuple_type) }
  where
    bndrs_tuple_type = mkBigCoreVarTupTy bndrs
87

88 89 90
-- 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
91 92 93 94 95 96 97
dsTransStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
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
98

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

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

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

    -- Generate the expressions to build the grouped list
    let -- First we apply the grouping function to the inner list
117
        inner_list_expr = mkApps usingExpr' usingArgs
118 119 120 121
        -- 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
122
        bound_unzipped_inner_list_expr
123 124 125 126 127 128 129 130 131
          = 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]

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

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

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

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

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

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

204
\begin{code}
205

206 207 208
deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr

deListComp [] _ = panic "deListComp"
209

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

216
        -- Non-last: must be a guard
217 218 219 220 221 222 223 224 225 226
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

227 228
deListComp (stmt@(TransStmt {}) : quals) list = do
    (inner_list_expr, pat) <- dsTransStmt stmt
229 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

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

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

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
        bndrs_s = map snd stmtss_w_bndrs
246

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

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

254

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

\begin{code}

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

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

393
    zip_fn <- newSysLocalDs zip_fn_ty
394 395 396 397

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

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

406 407 408
    zip_fn_ty         = mkFunTys elt_list_tys elt_tuple_list_ty

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


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

434 435 436 437 438
       ; unzip_fn <- newSysLocalDs unzip_fn_ty

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

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

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

454
    unzip_fn_ty        = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
455

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

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

\begin{code}

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

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

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

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

503 504


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

dePArrComp [] _ _ = panic "dePArrComp"

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

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

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

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

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

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

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

Translation for monad comprehensions

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

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

672
---------------
673 674 675 676 677 678 679
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') }
680 681

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

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

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

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

717 718 719 720
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
721
  = do { let (from_bndrs, to_bndrs) = unzip bndrs
722
             from_bndr_tys          = map idType from_bndrs     -- Types ty
723 724

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

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

       -- Generate the expressions to build the grouped list
737
       -- Build a pattern that ensures the consumer binds into the NEW binders,
738 739
       -- which hold monads rather than single values
       ; bind_op' <- dsExpr bind_op
740
       ; let bind_ty  = exprType bind_op'    -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2
741 742 743 744 745 746
             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
747
       ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys
748 749 750
       ; us         <- newUniqueSupply
       ; let rhs'  = mkApps usingExpr' usingArgs
             body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr
751

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

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

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

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

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

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


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

-- 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
807
dsMcBindStmt pat rhs' bind_op fail_op stmts
808
  = do  { body     <- dsMcStmts stmts
809 810
        ; bind_op' <- dsExpr bind_op
        ; var      <- selectSimpleMatchVarL pat
811
        ; let bind_ty = exprType bind_op'       -- rhs -> (pat -> res1) -> res2
812 813 814 815 816 817 818 819 820 821 822 823 824 825 826
              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
827
        = extractMatchResult match (error "It can't fail")
828 829

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

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

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

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

856
mkMcUnzipM :: TransForm
857 858 859 860 861
           -> 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 _
862 863 864 865 866
  = return (Var ys) -- No unzipping to do

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

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

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

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