[project @ 2000-10-12 13:44:59 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsListComp.lhs

diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index 52283b4..a7cec0c 100644 (file)
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -10,8 +10,8 @@ module DsListComp ( dsListComp ) where
 
 import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
 
-import HsSyn           ( Stmt(..), HsExpr )
-import TcHsSyn         ( TypecheckedStmt, TypecheckedHsExpr )
+import HsSyn           ( Stmt(..) )
+import TcHsSyn         ( TypecheckedStmt )
 import DsHsSyn         ( outPatType )
 import CoreSyn
 
@@ -19,16 +19,14 @@ import DsMonad              -- the monadery used in the desugarer
 import DsUtils
 
 import CmdLineOpts     ( opt_FoldrBuildOn )
-import CoreUtils       ( coreExprType )
+import CoreUtils       ( exprType, mkIfThenElse )
 import Id              ( idType )
-import Var              ( Id, TyVar )
-import Const           ( Con(..) )
-import PrelInfo                ( foldrId, buildId )
-import Type            ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type )
-import TysPrim         ( alphaTyVar, alphaTy )
-import TysWiredIn      ( nilDataCon, consDataCon, listTyCon )
+import Var              ( Id )
+import Type            ( mkTyVarTy, mkFunTys, mkFunTy, Type )
+import TysPrim         ( alphaTyVar )
+import TysWiredIn      ( nilDataCon, consDataCon )
 import Match           ( matchSimply )
-import Outputable
+import PrelNames       ( foldrIdKey, buildIdKey )
 \end{code}
 
 List comprehensions may be desugared in one of two ways: ``ordinary''
@@ -52,12 +50,13 @@ dsListComp quals elt_ty
        n_ty = mkTyVarTy n_tyvar
         c_ty = mkFunTys [elt_ty, n_ty] n_ty
     in
-    newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] ->
+    newSysLocalsDs [c_ty,n_ty]         `thenDs` \ [c, n] ->
 
-    dfListComp c n quals       `thenDs` \ result ->
+    dfListComp c n quals               `thenDs` \ result ->
 
-    returnDs (Var buildId `App` Type elt_ty 
-                         `App` mkLams [n_tyvar, c, n] result)
+    dsLookupGlobalValue buildIdKey     `thenDs` \ build_id ->
+    returnDs (Var build_id `App` Type elt_ty 
+                          `App` mkLams [n_tyvar, c, n] result)
 \end{code}
 
 %************************************************************************
@@ -107,9 +106,9 @@ already desugared.  @dsListComp@ does the top TE rule mentioned above.
 \begin{code}
 deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
 
-deListComp [ReturnStmt expr] list              -- Figure 7.4, SLPJ, p 135, rule C above
+deListComp [ReturnStmt expr] list      -- Figure 7.4, SLPJ, p 135, rule C above
   = dsExpr expr                        `thenDs` \ core_expr ->
-    returnDs (mkConsExpr (coreExprType core_expr) core_expr list)
+    returnDs (mkConsExpr (exprType core_expr) core_expr list)
 
 deListComp (GuardStmt guard locn : quals) list -- rule B above
   = dsExpr guard                       `thenDs` \ core_guard ->
@@ -124,12 +123,12 @@ deListComp (LetStmt binds : quals) list
 deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
   = dsExpr list1                   `thenDs` \ core_list1 ->
     let
-       u3_ty@u1_ty = coreExprType core_list1   -- two names, same thing
+       u3_ty@u1_ty = exprType core_list1       -- two names, same thing
 
        -- u1_ty is a [alpha] type, and u2_ty = alpha
        u2_ty = outPatType pat
 
-       res_ty = coreExprType core_list2
+       res_ty = exprType core_list2
        h_ty   = u1_ty `mkFunTy` res_ty
     in
     newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] ->
@@ -144,8 +143,8 @@ deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
                rest_expr core_fail             `thenDs` \ core_match ->
     let
        rhs = Lam u1 $
-             Case (Var u1) u1 [(DataCon nilDataCon,  [],       core_list2),
-                               (DataCon consDataCon, [u2, u3], core_match)]
+             Case (Var u1) u1 [(DataAlt nilDataCon,  [],       core_list2),
+                               (DataAlt consDataCon, [u2, u3], core_match)]
     in
     returnDs (Let (Rec [(h, rhs)]) letrec_body)
 \end{code}
@@ -208,12 +207,13 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals)
     matchSimply (Var x) ListCompMatch pat core_rest (Var b)    `thenDs` \ core_expr ->
 
     -- now build the outermost foldr, and return
+    dsLookupGlobalValue foldrIdKey             `thenDs` \ foldr_id ->
     returnDs (
-      Var foldrId `App` Type x_ty 
-                 `App` Type b_ty
-                 `App` mkLams [x, b] core_expr
-                 `App` Var n_id
-                 `App` core_list1
+      Var foldr_id `App` Type x_ty 
+                  `App` Type b_ty
+                  `App` mkLams [x, b] core_expr
+                  `App` Var n_id
+                  `App` core_list1
     )
 \end{code}