From 7a4a8360e8b7119485d10d073a984e617d6a0422 Mon Sep 17 00:00:00 2001
From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Sat, 7 Mar 2009 13:40:49 +0000
Subject: [PATCH] Special-case desugaring of simple parallel array
 comprehensions

---
 compiler/deSugar/DsListComp.lhs |   24 +++++++++++++++++++++++-
 1 file changed, 23 insertions(+), 1 deletion(-)

diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index bdbe65e..9508e51 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -510,10 +510,32 @@ dsPArrComp :: [Stmt Id]
             -> DsM CoreExpr
 dsPArrComp [ParStmt qss] body _  =  -- parallel comprehension
   dePArrParComp qss body
+
+-- 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 (mkLHsPatTup []) unitArray
+    dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
 
 
 
-- 
1.7.10.4