X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=6cbd5380b83e73315bcc44f245d1bf9059bf3007;hb=7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43;hp=eed7f87d8f304c49d989ff832729f5325d368fb0;hpb=27de38efce6d73d2a0209f803cfa98c82773e773;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index eed7f87..6cbd538 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -315,20 +315,20 @@ dsExpr (HsIf guard_expr then_expr else_expr)
 dsExpr (ExplicitList elt_ty xs) 
   = dsExplicitList elt_ty xs
 
--- we create a list from the array elements and convert them into a list using
--- `PrelPArr.toP'
---
---  * the main disadvantage to this scheme is that `toP' traverses the list
---   twice: once to determine the length and a second time to put to elements
---   into the array; this inefficiency could be avoided by exposing some of
---   the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
---   that we can exploit the fact that we already know the length of the array
---   here at compile time
+-- We desugar [:x1, ..., xn:] as
+--   singletonP x1 +:+ ... +:+ singletonP xn
 --
+dsExpr (ExplicitPArr ty []) = do
+    emptyP <- dsLookupGlobalId emptyPName
+    return (Var emptyP `App` Type ty)
 dsExpr (ExplicitPArr ty xs) = do
-    toP <- dsLookupGlobalId toPName
-    coreList <- dsExpr (ExplicitList ty xs)
-    return (mkApps (Var toP) [Type ty, coreList])
+    singletonP <- dsLookupGlobalId singletonPName
+    appP       <- dsLookupGlobalId appPName
+    xs'        <- mapM dsLExpr xs
+    return . foldr1 (binary appP) $ map (unary singletonP) xs'
+  where
+    unary  fn x   = mkApps (Var fn) [Type ty, x]
+    binary fn x y = mkApps (Var fn) [Type ty, x, y]
 
 dsExpr (ExplicitTuple expr_list boxity) = do
     core_exprs <- mapM dsLExpr expr_list
@@ -564,7 +564,7 @@ dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 dsExplicitList elt_ty xs = do
     dflags <- getDOptsDs
     xs' <- mapM dsLExpr xs
-    if not (dopt Opt_RewriteRules dflags)
+    if not (dopt Opt_EnableRewriteRules dflags)
         then return $ mkListExpr elt_ty xs'
         else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
   where