compiler/deSugar/DsListComp.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Desugaring list comprehensions and array comprehensions
   7
   8 \begin{code}
   9 {-# OPTIONS -fno-warn-incomplete-patterns #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module DsListComp ( dsListComp, dsPArrComp ) where
  17
  18 -- XXX This define is a bit of a hack, and should be done more nicely
  19 #define FAST_STRING_NOT_NEEDED 1
  20 #include "HsVersions.h"
  21
  22 import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
  23
  24 import HsSyn
  25 import TcHsSyn
  26 import CoreSyn
  27
  28 import DsMonad          -- the monadery used in the desugarer
  29 import DsUtils
  30
  31 import DynFlags
  32 import CoreUtils
  33 import Var
  34 import Type
  35 import TysPrim
  36 import TysWiredIn
  37 import Match
  38 import PrelNames
  39 import PrelInfo
  40 import SrcLoc
  41 import Outputable
  42
  43 import Control.Monad ( liftM2 )
  44 \end{code}
  45
  46 List comprehensions may be desugared in one of two ways: ``ordinary''
  47 (as you would expect if you read SLPJ's book) and ``with foldr/build
  48 turned on'' (if you read Gill {\em et al.}'s paper on the subject).
  49
  50 There will be at least one ``qualifier'' in the input.
  51
  52 \begin{code}
  53 dsListComp :: [LStmt Id]
  54            -> LHsExpr Id
  55            -> Type              -- Type of list elements
  56            -> DsM CoreExpr
  57 dsListComp lquals body elt_ty = do
  58     dflags <- getDOptsDs
  59     let quals = map unLoc lquals
  60
  61     if not (dopt Opt_RewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
  62        -- Either rules are switched off, or we are ignoring what there are;
  63        -- Either way foldr/build won't happen, so use the more efficient
  64        -- Wadler-style desugaring
  65        || isParallelComp quals
  66        -- Foldr-style desugaring can't handle parallel list comprehensions
  67         then deListComp quals body (mkNilExpr elt_ty)
  68         else do -- Foldr/build should be enabled, so desugar
  69                 -- into foldrs and builds
  70             [n_tyvar] <- newTyVarsDs [alphaTyVar]
  71
  72             let n_ty = mkTyVarTy n_tyvar
  73                 c_ty = mkFunTys [elt_ty, n_ty] n_ty
  74             [c, n] <- newSysLocalsDs [c_ty, n_ty]
  75
  76             result <- dfListComp c n quals body
  77             build_id <- dsLookupGlobalId buildName
  78             return (Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] result)
  79
  80   where
  81     -- We must test for ParStmt anywhere, not just at the head, because an extension
  82     -- to list comprehensions would be to add brackets to specify the associativity
  83     -- of qualifier lists. This is really easy to do by adding extra ParStmts into the
  84     -- mix of possibly a single element in length, so we do this to leave the possibility open
  85     isParallelComp = any isParallelStmt
  86
  87     isParallelStmt (ParStmt _) = True
  88     isParallelStmt _           = False
  89
  90
  91 -- This function lets you desugar a inner list comprehension and a list of the binders
  92 -- of that comprehension that we need in the outer comprehension into such an expression
  93 -- and the type of the elements that it outputs (tuples of binders)
  94 dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
  95 dsInnerListComp (stmts, bndrs) = do
  96         expr <- dsListComp stmts (mkBigLHsVarTup bndrs) bndrs_tuple_type
  97         return (expr, bndrs_tuple_type)
  98     where
  99         bndrs_types = map idType bndrs
 100         bndrs_tuple_type = mkBigCoreTupTy bndrs_types
 101
 102
 103 -- This function factors out commonality between the desugaring strategies for TransformStmt.
 104 -- Given such a statement it gives you back an expression representing how to compute the transformed
 105 -- list and the tuple that you need to bind from that list in order to proceed with your desugaring
 106 dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
 107 dsTransformStmt (TransformStmt (stmts, binders) usingExpr maybeByExpr) = do
 108     (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
 109     usingExpr' <- dsLExpr usingExpr
 110
 111     using_args <-
 112         case maybeByExpr of
 113             Nothing -> return [expr]
 114             Just byExpr -> do
 115                 byExpr' <- dsLExpr byExpr
 116
 117                 us <- newUniqueSupply
 118                 [tuple_binder] <- newSysLocalsDs [binders_tuple_type]
 119                 let byExprWrapper = mkTupleCase us binders byExpr' tuple_binder (Var tuple_binder)
 120
 121                 return [Lam tuple_binder byExprWrapper, expr]
 122
 123     let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
 124
 125     let pat = mkBigLHsVarPatTup binders
 126     return (inner_list_expr, pat)
 127
 128 -- This function factors out commonality between the desugaring strategies for GroupStmt.
 129 -- Given such a statement it gives you back an expression representing how to compute the transformed
 130 -- list and the tuple that you need to bind from that list in order to proceed with your desugaring
 131 dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
 132 dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do
 133     let (fromBinders, toBinders) = unzip binderMap
 134
 135         fromBindersTypes = map idType fromBinders
 136         toBindersTypes = map idType toBinders
 137
 138         toBindersTupleType = mkBigCoreTupTy toBindersTypes
 139
 140     -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
 141     (expr, fromBindersTupleType) <- dsInnerListComp (stmts, fromBinders)
 142
 143     -- Work out what arguments should be supplied to that expression: i.e. is an extraction
 144     -- function required? If so, create that desugared function and add to arguments
 145     (usingExpr', usingArgs) <-
 146         case groupByClause of
 147             GroupByNothing usingExpr -> liftM2 (,) (dsLExpr usingExpr) (return [expr])
 148             GroupBySomething usingExpr byExpr -> do
 149                 usingExpr' <- dsLExpr (either id noLoc usingExpr)
 150
 151                 byExpr' <- dsLExpr byExpr
 152
 153                 us <- newUniqueSupply
 154                 [fromBindersTuple] <- newSysLocalsDs [fromBindersTupleType]
 155                 let byExprWrapper = mkTupleCase us fromBinders byExpr' fromBindersTuple (Var fromBindersTuple)
 156
 157                 return (usingExpr', [Lam fromBindersTuple byExprWrapper, expr])
 158
 159     -- Create an unzip function for the appropriate arity and element types and find "map"
 160     (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes
 161     map_id <- dsLookupGlobalId mapName
 162
 163     -- Generate the expressions to build the grouped list
 164     let -- First we apply the grouping function to the inner list
 165         inner_list_expr = mkApps usingExpr' ((Type fromBindersTupleType) : usingArgs)
 166         -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
 167         -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
 168         -- the "b" to be a tuple of "to" lists!
 169         unzipped_inner_list_expr = mkApps (Var map_id)
 170             [Type (mkListTy fromBindersTupleType), Type toBindersTupleType, Var unzip_fn, inner_list_expr]
 171         -- Then finally we bind the unzip function around that expression
 172         bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr
 173
 174     -- Build a pattern that ensures the consumer binds into the NEW binders, which hold lists rather than single values
 175     let pat = mkBigLHsVarPatTup toBinders
 176     return (bound_unzipped_inner_list_expr, pat)
 177
 178 \end{code}
 179
 180 %************************************************************************
 181 %*                                                                      *
 182 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
 183 %*                                                                      *
 184 %************************************************************************
 185
 186 Just as in Phil's chapter~7 in SLPJ, using the rules for
 187 optimally-compiled list comprehensions.  This is what Kevin followed
 188 as well, and I quite happily do the same.  The TQ translation scheme
 189 transforms a list of qualifiers (either boolean expressions or
 190 generators) into a single expression which implements the list
 191 comprehension.  Because we are generating 2nd-order polymorphic
 192 lambda-calculus, calls to NIL and CONS must be applied to a type
 193 argument, as well as their usual value arguments.
 194 \begin{verbatim}
 195 TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
 196
 197 (Rule C)
 198 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
 199
 200 (Rule B)
 201 TQ << [ e | b , qs ] ++ L >> =
 202     if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
 203
 204 (Rule A')
 205 TQ << [ e | p <- L1, qs ]  ++  L2 >> =
 206   letrec
 207     h = \ u1 ->
 208           case u1 of
 209             []        ->  TE << L2 >>
 210             (u2 : u3) ->
 211                   (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
 212                     [] (h u3)
 213   in
 214     h ( TE << L1 >> )
 215
 216 "h", "u1", "u2", and "u3" are new variables.
 217 \end{verbatim}
 218
 219 @deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
 220 is the TE translation scheme.  Note that we carry around the @L@ list
 221 already desugared.  @dsListComp@ does the top TE rule mentioned above.
 222
 223 To the above, we add an additional rule to deal with parallel list
 224 comprehensions.  The translation goes roughly as follows:
 225      [ e | p1 <- e11, let v1 = e12, p2 <- e13
 226          | q1 <- e21, let v2 = e22, q2 <- e23]
 227      =>
 228      [ e | ((x1, .., xn), (y1, ..., ym)) <-
 229                zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
 230                    [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
 231 where (x1, .., xn) are the variables bound in p1, v1, p2
 232       (y1, .., ym) are the variables bound in q1, v2, q2
 233
 234 In the translation below, the ParStmt branch translates each parallel branch
 235 into a sub-comprehension, and desugars each independently.  The resulting lists
 236 are fed to a zip function, we create a binding for all the variables bound in all
 237 the comprehensions, and then we hand things off the the desugarer for bindings.
 238 The zip function is generated here a) because it's small, and b) because then we
 239 don't have to deal with arbitrary limits on the number of zip functions in the
 240 prelude, nor which library the zip function came from.
 241 The introduced tuples are Boxed, but only because I couldn't get it to work
 242 with the Unboxed variety.
 243
 244 \begin{code}
 245
 246 deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
 247
 248 deListComp (ParStmt stmtss_w_bndrs : quals) body list
 249   = do
 250     exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
 251     let (exps, qual_tys) = unzip exps_and_qual_tys
 252
 253     (zip_fn, zip_rhs) <- mkZipBind qual_tys
 254
 255         -- Deal with [e | pat <- zip l1 .. ln] in example above
 256     deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
 257                    quals body list
 258
 259   where
 260         bndrs_s = map snd stmtss_w_bndrs
 261
 262         -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
 263         pat  = mkBigLHsPatTup pats
 264         pats = map mkBigLHsVarPatTup bndrs_s
 265
 266         -- Last: the one to return
 267 deListComp [] body list = do    -- Figure 7.4, SLPJ, p 135, rule C above
 268     core_body <- dsLExpr body
 269     return (mkConsExpr (exprType core_body) core_body list)
 270
 271         -- Non-last: must be a guard
 272 deListComp (ExprStmt guard _ _ : quals) body list = do  -- rule B above
 273     core_guard <- dsLExpr guard
 274     core_rest <- deListComp quals body list
 275     return (mkIfThenElse core_guard core_rest list)
 276
 277 -- [e | let B, qs] = let B in [e | qs]
 278 deListComp (LetStmt binds : quals) body list = do
 279     core_rest <- deListComp quals body list
 280     dsLocalBinds binds core_rest
 281
 282 deListComp (stmt@(TransformStmt _ _ _) : quals) body list = do
 283     (inner_list_expr, pat) <- dsTransformStmt stmt
 284     deBindComp pat inner_list_expr quals body list
 285
 286 deListComp (stmt@(GroupStmt _ _) : quals) body list = do
 287     (inner_list_expr, pat) <- dsGroupStmt stmt
 288     deBindComp pat inner_list_expr quals body list
 289
 290 deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' above
 291     core_list1 <- dsLExpr list1
 292     deBindComp pat core_list1 quals body core_list2
 293 \end{code}
 294
 295
 296 \begin{code}
 297 deBindComp :: OutPat Id
 298            -> CoreExpr
 299            -> [Stmt Id]
 300            -> LHsExpr Id
 301            -> CoreExpr
 302            -> DsM (Expr Id)
 303 deBindComp pat core_list1 quals body core_list2 = do
 304     let
 305         u3_ty@u1_ty = exprType core_list1       -- two names, same thing
 306
 307         -- u1_ty is a [alpha] type, and u2_ty = alpha
 308         u2_ty = hsLPatType pat
 309
 310         res_ty = exprType core_list2
 311         h_ty   = u1_ty `mkFunTy` res_ty
 312
 313     [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
 314
 315     -- the "fail" value ...
 316     let
 317         core_fail   = App (Var h) (Var u3)
 318         letrec_body = App (Var h) core_list1
 319
 320     rest_expr <- deListComp quals body core_fail
 321     core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
 322
 323     let
 324         rhs = Lam u1 $
 325               Case (Var u1) u1 res_ty
 326                    [(DataAlt nilDataCon,  [],       core_list2),
 327                     (DataAlt consDataCon, [u2, u3], core_match)]
 328                         -- Increasing order of tag
 329
 330     return (Let (Rec [(h, rhs)]) letrec_body)
 331 \end{code}
 332
 333 %************************************************************************
 334 %*                                                                      *
 335 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 @dfListComp@ are the rules used with foldr/build turned on:
 340
 341 \begin{verbatim}
 342 TE[ e | ]            c n = c e n
 343 TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n
 344 TE[ e | p <- l , q ] c n = let
 345                                 f = \ x b -> case x of
 346                                                   p -> TE[ e | q ] c b
 347                                                   _ -> b
 348                            in
 349                            foldr f n l
 350 \end{verbatim}
 351
 352 \begin{code}
 353 dfListComp :: Id -> Id -- 'c' and 'n'
 354         -> [Stmt Id]   -- the rest of the qual's
 355         -> LHsExpr Id
 356         -> DsM CoreExpr
 357
 358         -- Last: the one to return
 359 dfListComp c_id n_id [] body = do
 360     core_body <- dsLExpr body
 361     return (mkApps (Var c_id) [core_body, Var n_id])
 362
 363         -- Non-last: must be a guard
 364 dfListComp c_id n_id (ExprStmt guard _ _  : quals) body = do
 365     core_guard <- dsLExpr guard
 366     core_rest <- dfListComp c_id n_id quals body
 367     return (mkIfThenElse core_guard core_rest (Var n_id))
 368
 369 dfListComp c_id n_id (LetStmt binds : quals) body = do
 370     -- new in 1.3, local bindings
 371     core_rest <- dfListComp c_id n_id quals body
 372     dsLocalBinds binds core_rest
 373
 374 dfListComp c_id n_id (stmt@(TransformStmt _ _ _) : quals) body = do
 375     (inner_list_expr, pat) <- dsTransformStmt stmt
 376     -- Anyway, we bind the newly transformed list via the generic binding function
 377     dfBindComp c_id n_id (pat, inner_list_expr) quals body
 378
 379 dfListComp c_id n_id (stmt@(GroupStmt _ _) : quals) body = do
 380     (inner_list_expr, pat) <- dsGroupStmt stmt
 381     -- Anyway, we bind the newly grouped list via the generic binding function
 382     dfBindComp c_id n_id (pat, inner_list_expr) quals body
 383
 384 dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = do
 385     -- evaluate the two lists
 386     core_list1 <- dsLExpr list1
 387
 388     -- Do the rest of the work in the generic binding builder
 389     dfBindComp c_id n_id (pat, core_list1) quals body
 390
 391 dfBindComp :: Id -> Id          -- 'c' and 'n'
 392        -> (LPat Id, CoreExpr)
 393            -> [Stmt Id]                 -- the rest of the qual's
 394            -> LHsExpr Id
 395            -> DsM CoreExpr
 396 dfBindComp c_id n_id (pat, core_list1) quals body = do
 397     -- find the required type
 398     let x_ty   = hsLPatType pat
 399         b_ty   = idType n_id
 400
 401     -- create some new local id's
 402     [b, x] <- newSysLocalsDs [b_ty, x_ty]
 403
 404     -- build rest of the comprehesion
 405     core_rest <- dfListComp c_id b quals body
 406
 407     -- build the pattern match
 408     core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
 409                 pat core_rest (Var b)
 410
 411     -- now build the outermost foldr, and return
 412     foldr_id <- dsLookupGlobalId foldrName
 413     return (Var foldr_id `App` Type x_ty
 414                `App` Type b_ty
 415                `App` mkLams [x, b] core_expr
 416                `App` Var n_id
 417                `App` core_list1)
 418
 419 \end{code}
 420
 421 %************************************************************************
 422 %*                                                                      *
 423 \subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
 424 %*                                                                      *
 425 %************************************************************************
 426
 427 \begin{code}
 428
 429 mkZipBind :: [Type] -> DsM (Id, CoreExpr)
 430 -- mkZipBind [t1, t2]
 431 -- = (zip, \as1:[t1] as2:[t2]
 432 --         -> case as1 of
 433 --              [] -> []
 434 --              (a1:as'1) -> case as2 of
 435 --                              [] -> []
 436 --                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
 437
 438 mkZipBind elt_tys = do
 439     ass  <- mapM newSysLocalDs  elt_list_tys
 440     as'  <- mapM newSysLocalDs  elt_tys
 441     as's <- mapM newSysLocalDs  elt_list_tys
 442
 443     zip_fn <- newSysLocalDs zip_fn_ty
 444
 445     let inner_rhs = mkConsExpr elt_tuple_ty
 446                         (mkBigCoreVarTup as')
 447                         (mkVarApps (Var zip_fn) as's)
 448         zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
 449
 450     return (zip_fn, mkLams ass zip_body)
 451   where
 452     elt_list_tys      = map mkListTy elt_tys
 453     elt_tuple_ty      = mkBigCoreTupTy elt_tys
 454     elt_tuple_list_ty = mkListTy elt_tuple_ty
 455
 456     zip_fn_ty         = mkFunTys elt_list_tys elt_tuple_list_ty
 457
 458     mk_case (as, a', as') rest
 459           = Case (Var as) as elt_tuple_list_ty
 460                   [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),
 461                    (DataAlt consDataCon, [a', as'], rest)]
 462                         -- Increasing order of tag
 463
 464
 465 mkUnzipBind :: [Type] -> DsM (Id, CoreExpr)
 466 -- mkUnzipBind [t1, t2]
 467 -- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
 468 --     -> case ax of
 469 --      (x1, x2) -> case axs of
 470 --                (xs1, xs2) -> (x1 : xs1, x2 : xs2))
 471 --      ([], [])
 472 --      ys)
 473 --
 474 -- We use foldr here in all cases, even if rules are turned off, because we may as well!
 475 mkUnzipBind elt_tys = do
 476     ax  <- newSysLocalDs elt_tuple_ty
 477     axs <- newSysLocalDs elt_list_tuple_ty
 478     ys  <- newSysLocalDs elt_tuple_list_ty
 479     xs  <- mapM newSysLocalDs elt_tys
 480     xss <- mapM newSysLocalDs elt_list_tys
 481
 482     unzip_fn <- newSysLocalDs unzip_fn_ty
 483
 484     foldr_id <- dsLookupGlobalId foldrName
 485     [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
 486
 487     let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
 488
 489         concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
 490         tupled_concat_expression = mkBigCoreTup concat_expressions
 491
 492         folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
 493         folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
 494         folder_body = mkLams [ax, axs] folder_body_outer_case
 495
 496         unzip_body = mkApps (Var foldr_id) [Type elt_tuple_ty, Type elt_list_tuple_ty, folder_body, nil_tuple, Var ys]
 497         unzip_body_saturated = mkLams [ys] unzip_body
 498
 499     return (unzip_fn, unzip_body_saturated)
 500   where
 501     elt_tuple_ty       = mkBigCoreTupTy elt_tys
 502     elt_tuple_list_ty  = mkListTy elt_tuple_ty
 503     elt_list_tys       = map mkListTy elt_tys
 504     elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys
 505
 506     unzip_fn_ty        = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
 507
 508     mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
 509
 510
 511
 512 \end{code}
 513
 514 %************************************************************************
 515 %*                                                                      *
 516 \subsection[DsPArrComp]{Desugaring of array comprehensions}
 517 %*                                                                      *
 518 %************************************************************************
 519
 520 \begin{code}
 521
 522 -- entry point for desugaring a parallel array comprehension
 523 --
 524 --   [:e | qss:] = <<[:e | qss:]>> () [:():]
 525 --
 526 dsPArrComp :: [Stmt Id]
 527             -> LHsExpr Id
 528             -> Type                 -- Don't use; called with `undefined' below
 529             -> DsM CoreExpr
 530 dsPArrComp [ParStmt qss] body _  =  -- parallel comprehension
 531   dePArrParComp qss body
 532 dsPArrComp qs            body _  = do -- no ParStmt in `qs'
 533     sglP <- dsLookupGlobalId singletonPName
 534     let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
 535     dePArrComp qs body (mkLHsPatTup []) unitArray
 536
 537
 538
 539 -- the work horse
 540 --
 541 dePArrComp :: [Stmt Id]
 542            -> LHsExpr Id
 543            -> LPat Id           -- the current generator pattern
 544            -> CoreExpr          -- the current generator expression
 545            -> DsM CoreExpr
 546 --
 547 --  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
 548 --
 549 dePArrComp [] e' pa cea = do
 550     mapP <- dsLookupGlobalId mapPName
 551     let ty = parrElemType cea
 552     (clam, ty'e') <- deLambda ty pa e'
 553     return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
 554 --
 555 --  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
 556 --
 557 dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
 558     filterP <- dsLookupGlobalId filterPName
 559     let ty = parrElemType cea
 560     (clam,_) <- deLambda ty pa b
 561     dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
 562
 563 --
 564 --  <<[:e' | p <- e, qs:]>> pa ea =
 565 --    let ef = \pa -> e
 566 --    in
 567 --    <<[:e' | qs:]>> (pa, p) (crossMap ea ef)
 568 --
 569 -- if matching again p cannot fail, or else
 570 --
 571 --  <<[:e' | p <- e, qs:]>> pa ea =
 572 --    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
 573 --    in
 574 --    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
 575 --
 576 dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
 577     filterP <- dsLookupGlobalId filterPName
 578     crossMapP <- dsLookupGlobalId crossMapPName
 579     ce <- dsLExpr e
 580     let ety'cea = parrElemType cea
 581         ety'ce  = parrElemType ce
 582         false   = Var falseDataConId
 583         true    = Var trueDataConId
 584     v <- newSysLocalDs ety'ce
 585     pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
 586     let cef | isIrrefutableHsPat p = ce
 587             | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
 588     (clam, _) <- mkLambda ety'cea pa cef
 589     let ety'cef = ety'ce                    -- filter doesn't change the element type
 590         pa'     = mkLHsPatTup [pa, p]
 591
 592     dePArrComp qs body pa' (mkApps (Var crossMapP)
 593                                  [Type ety'cea, Type ety'cef, cea, clam])
 594 --
 595 --  <<[:e' | let ds, qs:]>> pa ea =
 596 --    <<[:e' | qs:]>> (pa, (x_1, ..., x_n))
 597 --                    (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)
 598 --  where
 599 --    {x_1, ..., x_n} = DV (ds)         -- Defined Variables
 600 --
 601 dePArrComp (LetStmt ds : qs) body pa cea = do
 602     mapP <- dsLookupGlobalId mapPName
 603     let xs     = map unLoc (collectLocalBinders ds)
 604         ty'cea = parrElemType cea
 605     v <- newSysLocalDs ty'cea
 606     clet <- dsLocalBinds ds (mkCoreTup (map Var xs))
 607     let'v <- newSysLocalDs (exprType clet)
 608     let projBody = mkDsLet (NonRec let'v clet) $
 609                    mkCoreTup [Var v, Var let'v]
 610         errTy    = exprType projBody
 611         errMsg   = "DsListComp.dePArrComp: internal error!"
 612     cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg
 613     ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
 614     let pa'    = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
 615         proj   = mkLams [v] ccase
 616     dePArrComp qs body pa' (mkApps (Var mapP)
 617                                    [Type ty'cea, Type errTy, proj, cea])
 618 --
 619 -- The parser guarantees that parallel comprehensions can only appear as
 620 -- singeltons qualifier lists, which we already special case in the caller.
 621 -- So, encountering one here is a bug.
 622 --
 623 dePArrComp (ParStmt _ : _) _ _ _ =
 624   panic "DsListComp.dePArrComp: malformed comprehension AST"
 625
 626 --  <<[:e' | qs | qss:]>> pa ea =
 627 --    <<[:e' | qss:]>> (pa, (x_1, ..., x_n))
 628 --                     (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
 629 --    where
 630 --      {x_1, ..., x_n} = DV (qs)
 631 --
 632 dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr
 633 dePArrParComp qss body = do
 634     (pQss, ceQss) <- deParStmt qss
 635     dePArrComp [] body pQss ceQss
 636   where
 637     deParStmt []             =
 638       -- empty parallel statement lists have no source representation
 639       panic "DsListComp.dePArrComp: Empty parallel list comprehension"
 640     deParStmt ((qs, xs):qss) = do        -- first statement
 641       let res_expr = mkLHsVarTup xs
 642       cqs <- dsPArrComp (map unLoc qs) res_expr undefined
 643       parStmts qss (mkLHsVarPatTup xs) cqs
 644     ---
 645     parStmts []             pa cea = return (pa, cea)
 646     parStmts ((qs, xs):qss) pa cea = do  -- subsequent statements (zip'ed)
 647       zipP <- dsLookupGlobalId zipPName
 648       let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
 649           ty'cea   = parrElemType cea
 650           res_expr = mkLHsVarTup xs
 651       cqs <- dsPArrComp (map unLoc qs) res_expr undefined
 652       let ty'cqs = parrElemType cqs
 653           cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
 654       parStmts qss pa' cea'
 655
 656 -- generate Core corresponding to `\p -> e'
 657 --
 658 deLambda :: Type                        -- type of the argument
 659           -> LPat Id                    -- argument pattern
 660           -> LHsExpr Id                 -- body
 661           -> DsM (CoreExpr, Type)
 662 deLambda ty p e =
 663     mkLambda ty p =<< dsLExpr e
 664
 665 -- generate Core for a lambda pattern match, where the body is already in Core
 666 --
 667 mkLambda :: Type                        -- type of the argument
 668          -> LPat Id                     -- argument pattern
 669          -> CoreExpr                    -- desugared body
 670          -> DsM (CoreExpr, Type)
 671 mkLambda ty p ce = do
 672     v <- newSysLocalDs ty
 673     let errMsg = do "DsListComp.deLambda: internal error!"
 674         ce'ty  = exprType ce
 675     cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg
 676     res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr
 677     return (mkLams [v] res, ce'ty)
 678
 679 -- obtain the element type of the parallel array produced by the given Core
 680 -- expression
 681 --
 682 parrElemType   :: CoreExpr -> Type
 683 parrElemType e  =
 684   case splitTyConApp_maybe (exprType e) of
 685     Just (tycon, [ty]) | tycon == parrTyCon -> ty
 686     _                                                     -> panic
 687       "DsListComp.parrElemType: not a parallel array type"
 688 \end{code}