Move error-ids to MkCore (from PrelRules)
[ghc-hetmet.git] / compiler / deSugar / DsListComp.lhs
index f4ab7b3..166bfc2 100644 (file)
@@ -6,7 +6,7 @@
 Desugaring list comprehensions and array comprehensions
 
 \begin{code}
-{-# OPTIONS -w #-}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
@@ -19,28 +19,24 @@ module DsListComp ( dsListComp, dsPArrComp ) where
 
 import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
 
-import BasicTypes
 import HsSyn
 import TcHsSyn
 import CoreSyn
+import MkCore
 
 import DsMonad         -- the monadery used in the desugarer
 import DsUtils
 
 import DynFlags
 import CoreUtils
-import Var
+import Id
 import Type
-import TysPrim
 import TysWiredIn
 import Match
 import PrelNames
-import PrelInfo
 import SrcLoc
-import Panic
 import Outputable
-
-import Control.Monad ( liftM2 )
+import FastString
 \end{code}
 
 List comprehensions may be desugared in one of two ways: ``ordinary''
@@ -58,24 +54,16 @@ dsListComp lquals body elt_ty = do
     dflags <- getDOptsDs
     let quals = map unLoc lquals
     
-    if not (dopt Opt_RewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
+    if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
        -- Either rules are switched off, or we are ignoring what there are;
        -- Either way foldr/build won't happen, so use the more efficient
        -- Wadler-style desugaring
        || isParallelComp quals
        -- Foldr-style desugaring can't handle parallel list comprehensions
         then deListComp quals body (mkNilExpr elt_ty)
-        else do -- Foldr/build should be enabled, so desugar 
-                -- into foldrs and builds
-            [n_tyvar] <- newTyVarsDs [alphaTyVar]
-            
-            let n_ty = mkTyVarTy n_tyvar
-                c_ty = mkFunTys [elt_ty, n_ty] n_ty
-            [c, n] <- newSysLocalsDs [c_ty, n_ty]
-            
-            result <- dfListComp c n quals body
-            build_id <- dsLookupGlobalId buildName
-            returnDs (Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] result)
+        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body) 
+             -- Foldr/build should be enabled, so desugar 
+             -- into foldrs and builds
 
   where 
     -- We must test for ParStmt anywhere, not just at the head, because an extension
@@ -104,7 +92,7 @@ dsInnerListComp (stmts, bndrs) = do
 -- Given such a statement it gives you back an expression representing how to compute the transformed
 -- list and the tuple that you need to bind from that list in order to proceed with your desugaring
 dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
-dsTransformStmt (TransformStmt (stmts, binders) usingExpr maybeByExpr) = do
+dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr) = do
     (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
     usingExpr' <- dsLExpr usingExpr
     
@@ -129,7 +117,7 @@ dsTransformStmt (TransformStmt (stmts, binders) usingExpr maybeByExpr) = do
 -- Given such a statement it gives you back an expression representing how to compute the transformed
 -- list and the tuple that you need to bind from that list in order to proceed with your desugaring
 dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
-dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do
+dsGroupStmt (GroupStmt stmts binderMap by using) = do
     let (fromBinders, toBinders) = unzip binderMap
         
         fromBindersTypes = map idType fromBinders
@@ -138,23 +126,19 @@ dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do
         toBindersTupleType = mkBigCoreTupTy toBindersTypes
     
     -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
-    (expr, fromBindersTupleType) <- dsInnerListComp (stmts, fromBinders)
+    (expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders)
     
     -- Work out what arguments should be supplied to that expression: i.e. is an extraction
     -- function required? If so, create that desugared function and add to arguments
-    (usingExpr', usingArgs) <- 
-        case groupByClause of
-            GroupByNothing usingExpr -> liftM2 (,) (dsLExpr usingExpr) (return [expr])
-            GroupBySomething usingExpr byExpr -> do
-                usingExpr' <- dsLExpr (either id noLoc usingExpr)
-                
-                byExpr' <- dsLExpr byExpr
-                
-                us <- newUniqueSupply
-                [fromBindersTuple] <- newSysLocalsDs [fromBindersTupleType]
-                let byExprWrapper = mkTupleCase us fromBinders byExpr' fromBindersTuple (Var fromBindersTuple)
-                
-                return (usingExpr', [Lam fromBindersTuple byExprWrapper, expr])
+    usingExpr' <- dsLExpr (either id noLoc using)
+    usingArgs <- case by of
+                   Nothing   -> return [expr]
+                  Just by_e -> do { by_e' <- dsLExpr by_e
+                                   ; us <- newUniqueSupply
+                                   ; [from_tup_id] <- newSysLocalsDs [from_tup_ty]
+                                   ; let by_wrap = mkTupleCase us fromBinders by_e' 
+                                                   from_tup_id (Var from_tup_id)
+                                   ; return [Lam from_tup_id by_wrap, expr] }
     
     -- Create an unzip function for the appropriate arity and element types and find "map"
     (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes
@@ -162,12 +146,12 @@ dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do
 
     -- Generate the expressions to build the grouped list
     let -- First we apply the grouping function to the inner list
-        inner_list_expr = mkApps usingExpr' ((Type fromBindersTupleType) : usingArgs)
+        inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs)
         -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
         -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
         -- the "b" to be a tuple of "to" lists!
         unzipped_inner_list_expr = mkApps (Var map_id) 
-            [Type (mkListTy fromBindersTupleType), Type toBindersTupleType, Var unzip_fn, inner_list_expr]
+            [Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr]
         -- Then finally we bind the unzip function around that expression
         bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr
     
@@ -247,7 +231,7 @@ deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
 
 deListComp (ParStmt stmtss_w_bndrs : quals) body list
   = do
-    exps_and_qual_tys <- mappM dsInnerListComp stmtss_w_bndrs
+    exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
     let (exps, qual_tys) = unzip exps_and_qual_tys
     
     (zip_fn, zip_rhs) <- mkZipBind qual_tys
@@ -260,40 +244,46 @@ deListComp (ParStmt stmtss_w_bndrs : quals) body list
        bndrs_s = map snd stmtss_w_bndrs
 
        -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
-       pat      = mkBigLHsPatTup pats
+       pat  = mkBigLHsPatTup pats
        pats = map mkBigLHsVarPatTup bndrs_s
 
        -- Last: the one to return
-deListComp [] body list                -- Figure 7.4, SLPJ, p 135, rule C above
-  = dsLExpr body               `thenDs` \ core_body ->
-    returnDs (mkConsExpr (exprType core_body) core_body list)
+deListComp [] body list = do    -- Figure 7.4, SLPJ, p 135, rule C above
+    core_body <- dsLExpr body
+    return (mkConsExpr (exprType core_body) core_body list)
 
        -- Non-last: must be a guard
-deListComp (ExprStmt guard _ _ : quals) body list      -- rule B above
-  = dsLExpr guard                      `thenDs` \ core_guard ->
-    deListComp quals body list `thenDs` \ core_rest ->
-    returnDs (mkIfThenElse core_guard core_rest list)
+deListComp (ExprStmt guard _ _ : quals) body list = do  -- rule B above
+    core_guard <- dsLExpr guard
+    core_rest <- deListComp quals body list
+    return (mkIfThenElse core_guard core_rest list)
 
 -- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt binds : quals) body list
-  = deListComp quals body list `thenDs` \ core_rest ->
+deListComp (LetStmt binds : quals) body list = do
+    core_rest <- deListComp quals body list
     dsLocalBinds binds core_rest
 
-deListComp (stmt@(TransformStmt _ _ _) : quals) body list = do
+deListComp (stmt@(TransformStmt {}) : quals) body list = do
     (inner_list_expr, pat) <- dsTransformStmt stmt
     deBindComp pat inner_list_expr quals body list
 
-deListComp (stmt@(GroupStmt _ _) : quals) body list = do
+deListComp (stmt@(GroupStmt {}) : quals) body list = do
     (inner_list_expr, pat) <- dsGroupStmt stmt
     deBindComp pat inner_list_expr quals body list
 
-deListComp (BindStmt pat list1 _ _ : quals) body core_list2 -- rule A' above
-  = dsLExpr list1                  `thenDs` \ core_list1 ->
+deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' above
+    core_list1 <- dsLExpr list1
     deBindComp pat core_list1 quals body core_list2
 \end{code}
 
 
 \begin{code}
+deBindComp :: OutPat Id
+           -> CoreExpr
+           -> [Stmt Id]
+           -> LHsExpr Id
+           -> CoreExpr
+           -> DsM (Expr Id)
 deBindComp pat core_list1 quals body core_list2 = do
     let
         u3_ty@u1_ty = exprType core_list1      -- two names, same thing
@@ -350,27 +340,27 @@ dfListComp :: Id -> Id -- 'c' and 'n'
         -> DsM CoreExpr
 
        -- Last: the one to return
-dfListComp c_id n_id [] body
-  = dsLExpr body               `thenDs` \ core_body ->
-    returnDs (mkApps (Var c_id) [core_body, Var n_id])
+dfListComp c_id n_id [] body = do
+    core_body <- dsLExpr body
+    return (mkApps (Var c_id) [core_body, Var n_id])
 
        -- Non-last: must be a guard
-dfListComp c_id n_id (ExprStmt guard _ _  : quals) body
-  = dsLExpr guard                              `thenDs` \ core_guard ->
-    dfListComp c_id n_id quals body    `thenDs` \ core_rest ->
-    returnDs (mkIfThenElse core_guard core_rest (Var n_id))
-
-dfListComp c_id n_id (LetStmt binds : quals) body
-  -- new in 1.3, local bindings
-  = dfListComp c_id n_id quals body    `thenDs` \ core_rest ->
+dfListComp c_id n_id (ExprStmt guard _ _  : quals) body = do
+    core_guard <- dsLExpr guard
+    core_rest <- dfListComp c_id n_id quals body
+    return (mkIfThenElse core_guard core_rest (Var n_id))
+
+dfListComp c_id n_id (LetStmt binds : quals) body = do
+    -- new in 1.3, local bindings
+    core_rest <- dfListComp c_id n_id quals body
     dsLocalBinds binds core_rest
 
-dfListComp c_id n_id (stmt@(TransformStmt _ _ _) : quals) body = do
+dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do
     (inner_list_expr, pat) <- dsTransformStmt stmt
     -- Anyway, we bind the newly transformed list via the generic binding function
     dfBindComp c_id n_id (pat, inner_list_expr) quals body
 
-dfListComp c_id n_id (stmt@(GroupStmt _ _) : quals) body = do
+dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do
     (inner_list_expr, pat) <- dsGroupStmt stmt
     -- Anyway, we bind the newly grouped list via the generic binding function
     dfBindComp c_id n_id (pat, inner_list_expr) quals body
@@ -403,13 +393,7 @@ dfBindComp c_id n_id (pat, core_list1) quals body = do
                pat core_rest (Var b)
 
     -- now build the outermost foldr, and return
-    foldr_id <- dsLookupGlobalId foldrName
-    return (Var foldr_id `App` Type x_ty 
-               `App` Type b_ty
-               `App` mkLams [x, b] core_expr
-               `App` Var n_id
-               `App` core_list1)
-    
+    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
 \end{code}
 
 %************************************************************************
@@ -430,9 +414,9 @@ mkZipBind :: [Type] -> DsM (Id, CoreExpr)
 --                             (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
 
 mkZipBind elt_tys = do
-    ass  <- mappM newSysLocalDs  elt_list_tys
-    as'  <- mappM newSysLocalDs  elt_tys
-    as's <- mappM newSysLocalDs  elt_list_tys
+    ass  <- mapM newSysLocalDs  elt_list_tys
+    as'  <- mapM newSysLocalDs  elt_tys
+    as's <- mapM newSysLocalDs  elt_list_tys
     
     zip_fn <- newSysLocalDs zip_fn_ty
     
@@ -470,12 +454,11 @@ mkUnzipBind elt_tys = do
     ax  <- newSysLocalDs elt_tuple_ty
     axs <- newSysLocalDs elt_list_tuple_ty
     ys  <- newSysLocalDs elt_tuple_list_ty
-    xs  <- mappM newSysLocalDs elt_tys
-    xss <- mappM newSysLocalDs elt_list_tys
+    xs  <- mapM newSysLocalDs elt_tys
+    xss <- mapM newSysLocalDs elt_list_tys
     
     unzip_fn <- newSysLocalDs unzip_fn_ty
 
-    foldr_id <- dsLookupGlobalId foldrName
     [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
 
     let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
@@ -487,10 +470,8 @@ mkUnzipBind elt_tys = do
         folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
         folder_body = mkLams [ax, axs] folder_body_outer_case
         
-        unzip_body = mkApps (Var foldr_id) [Type elt_tuple_ty, Type elt_list_tuple_ty, folder_body, nil_tuple, Var ys]
-        unzip_body_saturated = mkLams [ys] unzip_body
-
-    return (unzip_fn, unzip_body_saturated)
+    unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
+    return (unzip_fn, mkLams [ys] unzip_body)
   where
     elt_tuple_ty       = mkBigCoreTupTy elt_tys
     elt_tuple_list_ty  = mkListTy elt_tuple_ty
@@ -523,12 +504,32 @@ dsPArrComp :: [Stmt Id]
             -> DsM CoreExpr
 dsPArrComp [ParStmt qss] body _  =  -- parallel comprehension
   dePArrParComp qss body
-dsPArrComp qs            body _  =  -- no ParStmt in `qs'
-  dsLookupGlobalId singletonPName                        `thenDs` \sglP ->
-  let unitArray = mkApps (Var sglP) [Type unitTy, 
-                                    mkCoreTup []]
-  in
-  dePArrComp qs body (mkLHsPatTup []) unitArray
+
+-- Special case for simple generators:
+--
+--  <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e
+--
+-- if matching again p cannot fail, or else
+--
+--  <<[:e' | p <- e, qs:]>> = 
+--    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
+--
+dsPArrComp (BindStmt p e _ _ : qs) body _ = do
+    filterP <- dsLookupGlobalId filterPName
+    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]
+    dePArrComp qs body p gen
+
+dsPArrComp qs            body _  = do -- no ParStmt in `qs'
+    sglP <- dsLookupGlobalId singletonPName
+    let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
+    dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
 
 
 
@@ -542,22 +543,19 @@ dePArrComp :: [Stmt Id]
 --
 --  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
 --
-dePArrComp [] e' pa cea =
-  dsLookupGlobalId mapPName                              `thenDs` \mapP    ->
-  let ty = parrElemType cea
-  in
-  deLambda ty pa e'                                      `thenDs` \(clam, 
-                                                                    ty'e') ->
-  returnDs $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
+dePArrComp [] e' pa cea = do
+    mapP <- dsLookupGlobalId mapPName
+    let ty = parrElemType cea
+    (clam, ty'e') <- deLambda ty pa e'
+    return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
 --
 --  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
 --
-dePArrComp (ExprStmt b _ _ : qs) body pa cea =
-  dsLookupGlobalId filterPName                   `thenDs` \filterP  ->
-  let ty = parrElemType cea
-  in
-  deLambda ty pa b                               `thenDs` \(clam,_) ->
-  dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
+dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
+    filterP <- dsLookupGlobalId filterPName
+    let ty = parrElemType cea
+    (clam,_) <- deLambda ty pa b
+    dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
 
 --
 --  <<[:e' | p <- e, qs:]>> pa ea =
@@ -572,27 +570,24 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea =
 --    in
 --    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
 --
-dePArrComp (BindStmt p e _ _ : qs) body pa cea =
-  dsLookupGlobalId filterPName                   `thenDs` \filterP    ->
-  dsLookupGlobalId crossMapPName                 `thenDs` \crossMapP  ->
-  dsLExpr e                                      `thenDs` \ce         ->
-  let ety'cea = parrElemType cea
-      ety'ce  = parrElemType ce
-      false   = Var falseDataConId
-      true    = Var trueDataConId
-  in
-  newSysLocalDs ety'ce                                   `thenDs` \v       ->
-  matchSimply (Var v) (StmtCtxt PArrComp) p true false    `thenDs` \pred    ->
-  let cef | isIrrefutableHsPat p = ce
-          | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
-  in
-  mkLambda ety'cea pa cef                                `thenDs` \(clam, 
-                                                                    _    ) ->
-  let ety'cef = ety'ce             -- filter doesn't change the element type
-      pa'     = mkLHsPatTup [pa, p]
-  in
-  dePArrComp qs body pa' (mkApps (Var crossMapP) 
-                                [Type ety'cea, Type ety'cef, cea, clam])
+dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
+    filterP <- dsLookupGlobalId filterPName
+    crossMapP <- dsLookupGlobalId crossMapPName
+    ce <- dsLExpr e
+    let ety'cea = parrElemType cea
+        ety'ce  = parrElemType ce
+        false   = Var falseDataConId
+        true    = Var trueDataConId
+    v <- newSysLocalDs ety'ce
+    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
+    let cef | isIrrefutableHsPat p = ce
+            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
+    (clam, _) <- mkLambda ety'cea pa cef
+    let ety'cef = ety'ce                   -- filter doesn't change the element type
+        pa'     = mkLHsPatTup [pa, p]
+
+    dePArrComp qs body pa' (mkApps (Var crossMapP) 
+                                 [Type ety'cea, Type ety'cef, cea, clam])
 --
 --  <<[:e' | let ds, qs:]>> pa ea = 
 --    <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) 
@@ -600,26 +595,23 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea =
 --  where
 --    {x_1, ..., x_n} = DV (ds)                -- Defined Variables
 --
-dePArrComp (LetStmt ds : qs) body pa cea =
-  dsLookupGlobalId mapPName                              `thenDs` \mapP    ->
-  let xs     = map unLoc (collectLocalBinders ds)
-      ty'cea = parrElemType cea
-  in
-  newSysLocalDs ty'cea                                   `thenDs` \v       ->
-  dsLocalBinds ds (mkCoreTup (map Var xs))               `thenDs` \clet    ->
-  newSysLocalDs (exprType clet)                                  `thenDs` \let'v   ->
-  let projBody = mkDsLet (NonRec let'v clet) $ 
-                mkCoreTup [Var v, Var let'v]
-      errTy    = exprType projBody
-      errMsg   = "DsListComp.dePArrComp: internal error!"
-  in
-  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->
-  matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr`thenDs` \ccase   ->
-  let pa'    = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
-      proj   = mkLams [v] ccase
-  in
-  dePArrComp qs body pa' (mkApps (Var mapP) 
-                                [Type ty'cea, Type errTy, proj, cea])
+dePArrComp (LetStmt ds : qs) body pa cea = do
+    mapP <- dsLookupGlobalId mapPName
+    let xs     = collectLocalBinders ds
+        ty'cea = parrElemType cea
+    v <- newSysLocalDs ty'cea
+    clet <- dsLocalBinds ds (mkCoreTup (map Var xs))
+    let'v <- newSysLocalDs (exprType clet)
+    let projBody = mkCoreLet (NonRec let'v clet) $ 
+                   mkCoreTup [Var v, Var let'v]
+        errTy    = exprType projBody
+        errMsg   = ptext (sLit "DsListComp.dePArrComp: internal error!")
+    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
+    dePArrComp qs body pa' (mkApps (Var mapP) 
+                                   [Type ty'cea, Type errTy, proj, cea])
 --
 -- The parser guarantees that parallel comprehensions can only appear as
 -- singeltons qualifier lists, which we already special case in the caller.
@@ -634,31 +626,28 @@ dePArrComp (ParStmt _ : _) _ _ _ =
 --    where
 --      {x_1, ..., x_n} = DV (qs)
 --
-dePArrParComp qss body = 
-  deParStmt qss                                                `thenDs` \(pQss, 
-                                                                  ceQss) ->
-  dePArrComp [] body pQss ceQss
+dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr
+dePArrParComp qss body = do
+    (pQss, ceQss) <- deParStmt qss
+    dePArrComp [] body pQss ceQss
   where
     deParStmt []             =
       -- empty parallel statement lists have no source representation
       panic "DsListComp.dePArrComp: Empty parallel list comprehension"
-    deParStmt ((qs, xs):qss) =          -- first statement
-      let res_expr = mkLHsVarTup xs
-      in
-      dsPArrComp (map unLoc qs) res_expr undefined       `thenDs` \cqs     ->
+    deParStmt ((qs, xs):qss) = do        -- first statement
+      let res_expr = mkLHsVarTuple xs
+      cqs <- dsPArrComp (map unLoc qs) res_expr undefined
       parStmts qss (mkLHsVarPatTup xs) cqs
     ---
     parStmts []             pa cea = return (pa, cea)
-    parStmts ((qs, xs):qss) pa cea =    -- subsequent statements (zip'ed)
-      dsLookupGlobalId zipPName                                  `thenDs` \zipP    ->
+    parStmts ((qs, xs):qss) pa cea = do  -- subsequent statements (zip'ed)
+      zipP <- dsLookupGlobalId zipPName
       let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
-         ty'cea   = parrElemType cea
-         res_expr = mkLHsVarTup xs
-      in
-      dsPArrComp (map unLoc qs) res_expr undefined       `thenDs` \cqs     ->
+          ty'cea   = parrElemType cea
+          res_expr = mkLHsVarTuple xs
+      cqs <- dsPArrComp (map unLoc qs) res_expr undefined
       let ty'cqs = parrElemType cqs
-         cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
-      in
+          cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
       parStmts qss pa' cea'
 
 -- generate Core corresponding to `\p -> e'
@@ -668,8 +657,7 @@ deLambda :: Type                    -- type of the argument
          -> LHsExpr Id                 -- body
          -> DsM (CoreExpr, Type)
 deLambda ty p e =
-  dsLExpr e                                              `thenDs` \ce      ->
-  mkLambda ty p ce
+    mkLambda ty p =<< dsLExpr e
 
 -- generate Core for a lambda pattern match, where the body is already in Core
 --
@@ -677,14 +665,13 @@ mkLambda :: Type                  -- type of the argument
         -> LPat Id                     -- argument pattern
         -> CoreExpr                    -- desugared body
         -> DsM (CoreExpr, Type)
-mkLambda ty p ce =
-  newSysLocalDs ty                                       `thenDs` \v       ->
-  let errMsg = "DsListComp.deLambda: internal error!"
-      ce'ty  = exprType ce
-  in
-  mkErrorAppDs pAT_ERROR_ID ce'ty errMsg                  `thenDs` \cerr    -> 
-  matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr      `thenDs` \res     ->
-  returnDs (mkLams [v] res, ce'ty)
+mkLambda ty p ce = do
+    v <- newSysLocalDs ty
+    let errMsg = ptext (sLit "DsListComp.deLambda: internal error!")
+        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)
 
 -- obtain the element type of the parallel array produced by the given Core
 -- expression