X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsListComp.lhs;h=def08e1f6aa5ab1331b1123f6007ee707fdc4a07;hp=35ff21fa5695c7b55b709e061ee3cc9572714582;hb=6084fb5517da34f65034370a3695e2af3b85ce2b;hpb=dcc8f0a89f1ff43684b6e0f34b9ded3ec6b96e1c

diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index 35ff21f..def08e1 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -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,7 +19,6 @@ module DsListComp ( dsListComp, dsPArrComp ) where
 
 import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
 
-import BasicTypes
 import HsSyn
 import TcHsSyn
 import CoreSyn
@@ -29,15 +28,13 @@ 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 )
@@ -65,17 +62,9 @@ dsListComp lquals body elt_ty = do
        || 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
-            return (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
@@ -294,6 +283,12 @@ deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' abov
 
 
 \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
@@ -403,13 +398,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}
 
 %************************************************************************
@@ -475,7 +464,6 @@ mkUnzipBind elt_tys = do
     
     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 +475,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
@@ -623,6 +609,7 @@ dePArrComp (ParStmt _ : _) _ _ _ =
 --    where
 --      {x_1, ..., x_n} = DV (qs)
 --
+dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr
 dePArrParComp qss body = do
     (pQss, ceQss) <- deParStmt qss
     dePArrComp [] body pQss ceQss