X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsListComp.lhs;h=68c5249c33349b5d969ad8a08302ae38c3a9a912;hb=942fd04666dfbcb6bf3088ab0ef55e60d18ae67a;hp=ccc1a7bb34f4f86d4a7f0de8511e7706d31fe076;hpb=5943ce90c9c9d4319eec3cfe1fb3315f018e1c45;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index ccc1a7b..68c5249 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -6,6 +6,13 @@
 Desugaring list comprehensions and array comprehensions
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- 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
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module DsListComp ( dsListComp, dsPArrComp ) where
 
 #include "HsVersions.h"
@@ -21,7 +28,6 @@ import DsMonad		-- the monadery used in the desugarer
 import DsUtils
 
 import DynFlags
-import StaticFlags
 import CoreUtils
 import Var
 import Type
@@ -355,9 +361,8 @@ dsPArrComp      :: [Stmt Id]
 dsPArrComp [ParStmt qss] body _  =  -- parallel comprehension
   dePArrParComp qss body
 dsPArrComp qs            body _  =  -- no ParStmt in `qs'
-  dsLookupGlobalId replicatePName			  `thenDs` \repP ->
-  let unitArray = mkApps (Var repP) [Type unitTy, 
-				     mkIntExpr 1, 
+  dsLookupGlobalId singletonPName			  `thenDs` \sglP ->
+  let unitArray = mkApps (Var sglP) [Type unitTy, 
 				     mkCoreTup []]
   in
   dePArrComp qs body (mkTuplePat []) unitArray
@@ -390,6 +395,14 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea =
   in
   deLambda ty pa b				  `thenDs` \(clam,_) ->
   dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
+
+--
+--  <<[: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
 --
 --  <<[:e' | p <- e, qs:]>> pa ea = 
 --    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
@@ -407,7 +420,8 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea =
   in
   newSysLocalDs ety'ce					  `thenDs` \v       ->
   matchSimply (Var v) (StmtCtxt PArrComp) p true false    `thenDs` \pred    ->
-  let cef = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
+  let cef | isIrrefutableHsPat p = ce
+          | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
   in
   mkLambda ety'cea pa cef				  `thenDs` \(clam, 
 								     _    ) ->