X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=6fc4aa7494fec24cc5d61159a0c5f6ac26a2d6d5;hb=ec269b1201dd73f6173d7d66ddbe2bbbc2244bf2;hp=ecddeb4757be4027b029709f82268a16e0ee65da;hpb=99073d876ea762016683fb0b22b9d343ff864eb4;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index ecddeb4..6fc4aa7 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -14,17 +14,18 @@ module DsMonad (
 	newFailLocalDs,
 	getSrcLocDs, putSrcLocDs,
 	getModuleDs,
-	getUniqueDs,
+	getUniqueDs, getUniquesDs,
 	getDOptsDs,
 	dsLookupGlobalValue,
 
 	dsWarn, 
 	DsWarnings,
-	DsMatchContext(..), DsMatchKind(..)
+	DsMatchContext(..)
     ) where
 
 #include "HsVersions.h"
 
+import TcHsSyn		( TypecheckedPat, TypecheckedMatchContext )
 import Bag		( emptyBag, snocBag, Bag )
 import ErrUtils 	( WarnMsg )
 import Id		( mkSysLocal, setIdUnique, Id )
@@ -32,15 +33,11 @@ import Module		( Module )
 import Var		( TyVar, setTyVarUnique )
 import Outputable
 import SrcLoc		( noSrcLoc, SrcLoc )
-import TcHsSyn		( TypecheckedPat )
 import Type             ( Type )
 import UniqSupply	( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
 			  UniqSM, UniqSupply )
 import Unique		( Unique )
-import Util		( zipWithEqual )
-import Name		( Name, lookupNameEnv )
-import HscTypes		( HomeSymbolTable, PersistentCompilerState(..), 
-			  TyThing(..), TypeEnv, lookupTypeEnv )
+import Name		( Name )
 import CmdLineOpts	( DynFlags )
 
 infixr 9 `thenDs`
@@ -70,29 +67,13 @@ type DsWarnings = Bag WarnMsg           -- The desugarer reports matches which a
 
 initDs  :: DynFlags
 	-> UniqSupply
-	-> (HomeSymbolTable, PersistentCompilerState, TypeEnv)
+	-> (Name -> Id)
 	-> Module   -- module name: for profiling
 	-> DsM a
 	-> (a, DsWarnings)
 
-initDs dflags init_us (hst,pcs,local_type_env) mod action
+initDs dflags init_us lookup mod action
   = action dflags init_us lookup noSrcLoc mod emptyBag
-  where
-	-- This lookup is used for well-known Ids, 
-	-- such as fold, build, cons etc, so the chances are
-	-- it'll be found in the package symbol table.  That's
-	-- why we don't merge all these tables
-    pst = pcs_PST pcs
-    lookup n = case lookupTypeEnv pst n of {
-		 Just (AnId v) -> v ;
-		 other -> 
-	       case lookupTypeEnv hst n of {
-		 Just (AnId v) -> v ;
-		 other -> 
-	       case lookupNameEnv local_type_env n of
-		 Just (AnId v) -> v ;
-		 other	       -> pprPanic "initDS: lookup:" (ppr n)
-               }}
 
 thenDs :: DsM a -> (a -> DsM b) -> DsM b
 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
@@ -169,8 +150,11 @@ newFailLocalDs ty dflags us genv loc mod warns
 
 getUniqueDs :: DsM Unique
 getUniqueDs dflags us genv loc mod warns
-  = case (uniqFromSupply us) of { assigned_uniq ->
-    (assigned_uniq, warns) }
+  = (uniqFromSupply us, warns)
+
+getUniquesDs :: DsM [Unique]
+getUniquesDs dflags us genv loc mod warns
+  = (uniqsFromSupply us, warns)
 
 getDOptsDs :: DsM DynFlags
 getDOptsDs dflags us genv loc mod warns
@@ -183,16 +167,13 @@ duplicateLocalDs old_local dflags us genv loc mod warns
 
 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 cloneTyVarsDs tyvars dflags us genv loc mod warns
-  = case uniqsFromSupply (length tyvars) us of { uniqs ->
-    (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
+  = (zipWith setTyVarUnique tyvars (uniqsFromSupply us), warns)
 \end{code}
 
 \begin{code}
 newTyVarsDs :: [TyVar] -> DsM [TyVar]
-
 newTyVarsDs tyvar_tmpls dflags us genv loc mod warns
-  = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
-    (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
+  = (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply us), warns)
 \end{code}
 
 We can also reach out and either set/grab location information from
@@ -236,18 +217,7 @@ dsLookupGlobalValue name dflags us genv loc mod warns
 
 \begin{code}
 data DsMatchContext
-  = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
+  = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
   | NoMatchContext
   deriving ()
-
-data DsMatchKind
-  = FunMatch Id
-  | CaseMatch
-  | LambdaMatch
-  | PatBindMatch
-  | DoBindMatch
-  | ListCompMatch
-  | LetMatch
-  | RecUpdMatch
-  deriving ()
 \end{code}