[project @ 2001-07-03 16:46:21 by rrt]

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

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index bf73147..9868a37 100644 (file)
--- 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,16 +33,11 @@ import Module               ( Module )
 import Var             ( TyVar, setTyVarUnique )
 import Outputable
 import SrcLoc          ( noSrcLoc, SrcLoc )
-import TcHsSyn         ( TypecheckedPat )
-import Type             ( Type )
+import TcType           ( Type )
 import UniqSupply      ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
                          UniqSM, UniqSupply )
 import Unique          ( Unique )
-import Util            ( zipWithEqual )
 import Name            ( Name )
-import Name            ( lookupNameEnv )
-import HscTypes                ( HomeSymbolTable, PersistentCompilerState(..), 
-                         TyThing(..), TypeEnv, lookupType )
 import CmdLineOpts     ( DynFlags )
 
 infixr 9 `thenDs`
@@ -71,26 +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
-    pte = pcs_PTE pcs
-    lookup n = case lookupType hst pte 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
@@ -167,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
@@ -181,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
@@ -234,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}