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

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index ecddeb4..904d575 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -6,41 +6,43 @@
 \begin{code}
 module DsMonad (
 	DsM,
-	initDs, returnDs, thenDs, andDs, mapDs, listDs,
+	initDs, returnDs, thenDs, mapDs, listDs,
 	mapAndUnzipDs, zipWithDs, foldlDs,
 	uniqSMtoDsM,
 	newTyVarsDs, cloneTyVarsDs,
-	duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
+	duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
 	newFailLocalDs,
 	getSrcLocDs, putSrcLocDs,
 	getModuleDs,
-	getUniqueDs,
+	getUniqueDs, getUniquesDs,
 	getDOptsDs,
-	dsLookupGlobalValue,
+	dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
+
+	DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
 	dsWarn, 
 	DsWarnings,
-	DsMatchContext(..), DsMatchKind(..)
+	DsMatchContext(..)
     ) where
 
 #include "HsVersions.h"
 
+import TcHsSyn		( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
+import HscTypes		( TyThing(..) )
 import Bag		( emptyBag, snocBag, Bag )
-import ErrUtils 	( WarnMsg )
+import TyCon		( TyCon )
 import Id		( mkSysLocal, setIdUnique, Id )
 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,
+import UniqSupply	( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs, 
 			  UniqSM, UniqSupply )
-import Unique		( Unique )
-import Util		( zipWithEqual )
-import Name		( Name, lookupNameEnv )
-import HscTypes		( HomeSymbolTable, PersistentCompilerState(..), 
-			  TyThing(..), TypeEnv, lookupTypeEnv )
+import Unique		( Unique ) 
+import Name		( Name, nameOccName )
+import NameEnv
+import OccName          ( occNameFS )
 import CmdLineOpts	( DynFlags )
 
 infixr 9 `thenDs`
@@ -50,19 +52,39 @@ Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 a @UniqueSupply@ and some annotations, which
 presumably include source-file location information:
 \begin{code}
-type DsM result =
-	DynFlags
-	-> UniqSupply
-        -> (Name -> Id)		-- Lookup well-known Ids
-	-> SrcLoc		-- to put in pattern-matching error msgs
-	-> Module       	-- module: for SCC profiling
-	-> DsWarnings
-	-> (result, DsWarnings)
+newtype DsM result
+  = DsM (DsEnv -> DsWarnings -> UniqSM (result, DsWarnings))
+
+unDsM (DsM x) = x	
+
+data DsEnv = DsEnv {
+	ds_dflags :: DynFlags,
+	ds_globals :: Name -> TyThing,	-- Lookup well-known Ids
+	ds_meta	   :: DsMetaEnv,	-- Template Haskell bindings
+	ds_loc	   :: SrcLoc,		-- to put in pattern-matching error msgs
+	ds_mod	   :: Module       	-- module: for SCC profiling
+     }
+
+-- Inside [| |] brackets, the desugarer looks 
+-- up variables in the DsMetaEnv
+type DsMetaEnv = NameEnv DsMetaVal
 
-type DsWarnings = Bag WarnMsg           -- The desugarer reports matches which are
+data DsMetaVal
+   = Bound Id		-- Bound by a pattern inside the [| |]. 
+			-- Will be dynamically alpha renamed.
+			-- The Id has type String
+
+   | Splice TypecheckedHsExpr	-- These bindings are introduced by
+				-- the PendingSplices on a HsBracketOut
+
+instance Monad DsM where
+  return = returnDs
+  (>>=)  = thenDs
+
+type DsWarnings = Bag DsWarning         -- The desugarer reports matches which are
 					-- completely shadowed or incomplete patterns
+type DsWarning = (SrcLoc, SDoc)
 
-{-# INLINE andDs #-}
 {-# INLINE thenDs #-}
 {-# INLINE returnDs #-}
 
@@ -70,46 +92,26 @@ type DsWarnings = Bag WarnMsg           -- The desugarer reports matches which a
 
 initDs  :: DynFlags
 	-> UniqSupply
-	-> (HomeSymbolTable, PersistentCompilerState, TypeEnv)
+	-> (Name -> TyThing)
 	-> Module   -- module name: for profiling
 	-> DsM a
 	-> (a, DsWarnings)
 
-initDs dflags init_us (hst,pcs,local_type_env) mod action
-  = action dflags init_us lookup noSrcLoc mod emptyBag
+initDs dflags init_us lookup mod (DsM action)
+  = initUs_ init_us (action ds_env 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)
-               }}
+    ds_env = DsEnv { ds_dflags = dflags, ds_globals = lookup,
+		     ds_loc = noSrcLoc, ds_mod = mod,
+		     ds_meta = emptyNameEnv }
 
 thenDs :: DsM a -> (a -> DsM b) -> DsM b
-andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
 
-thenDs m1 m2 dflags us genv loc mod warns
-  = case splitUniqSupply us		    of { (s1, s2) ->
-    case (m1 dflags s1 genv loc mod warns)  of { (result, warns1) ->
-    m2 result dflags s2 genv loc mod warns1}}
-
-andDs combiner m1 m2 dflags us genv loc mod warns
-  = case splitUniqSupply us		    of { (s1, s2) ->
-    case (m1 dflags s1 genv loc mod warns)  of { (result1, warns1) ->
-    case (m2 dflags s2 genv loc mod warns1) of { (result2, warns2) ->
-    (combiner result1 result2, warns2) }}}
+thenDs (DsM m1) m2 = DsM( \ env warns ->
+    m1 env warns	`thenUs` \ (result, warns1) ->
+    unDsM (m2 result) env warns1)
 
 returnDs :: a -> DsM a
-returnDs result dflags us genv loc mod warns = (result, warns)
+returnDs result = DsM (\ env warns -> returnUs (result, warns))
 
 listDs :: [DsM a] -> DsM [a]
 listDs []     = returnDs []
@@ -155,76 +157,108 @@ functions are defined with it.  The difference in name-strings makes
 it easier to read debugging output.
 
 \begin{code}
-newSysLocalDs, newFailLocalDs :: Type -> DsM Id
-newSysLocalDs ty dflags us genv loc mod warns
-  = case uniqFromSupply us of { assigned_uniq ->
-    (mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
-
-newSysLocalsDs tys = mapDs newSysLocalDs tys
-
-newFailLocalDs ty dflags us genv loc mod warns
-  = case uniqFromSupply us of { assigned_uniq ->
-    (mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
-	-- The UserLocal bit just helps make the code a little clearer
+uniqSMtoDsM :: UniqSM a -> DsM a
+uniqSMtoDsM u_action = DsM(\ env warns -> 
+	u_action	`thenUs` \ res ->
+	returnUs (res, warns))
 
+    
 getUniqueDs :: DsM Unique
-getUniqueDs dflags us genv loc mod warns
-  = case (uniqFromSupply us) of { assigned_uniq ->
-    (assigned_uniq, warns) }
+getUniqueDs = DsM (\ env warns -> 
+    getUniqueUs		`thenUs` \ uniq -> 
+    returnUs (uniq, warns))
 
-getDOptsDs :: DsM DynFlags
-getDOptsDs dflags us genv loc mod warns
-  = (dflags, warns)
+getUniquesDs :: DsM [Unique]
+getUniquesDs = DsM(\ env warns -> 
+    getUniquesUs		`thenUs` \ uniqs -> 
+    returnUs (uniqs, warns))
+
+-- Make a new Id with the same print name, but different type, and new unique
+newUniqueId :: Name -> Type -> DsM Id
+newUniqueId id ty
+  = getUniqueDs 	`thenDs` \ uniq ->
+    returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
 
 duplicateLocalDs :: Id -> DsM Id
-duplicateLocalDs old_local dflags us genv loc mod warns
-  = case uniqFromSupply us of { assigned_uniq ->
-    (setIdUnique old_local assigned_uniq, warns) }
+duplicateLocalDs old_local 
+  = getUniqueDs 	`thenDs` \ uniq ->
+    returnDs (setIdUnique old_local uniq)
 
-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) }
+newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDs ty
+  = getUniqueDs 	`thenDs` \ uniq ->
+    returnDs (mkSysLocal FSLIT("ds") uniq ty)
+
+newSysLocalsDs tys = mapDs newSysLocalDs tys
+
+newFailLocalDs ty 
+  = getUniqueDs 	`thenDs` \ uniq ->
+    returnDs (mkSysLocal FSLIT("fail") uniq ty)
+	-- The UserLocal bit just helps make the code a little clearer
 \end{code}
 
 \begin{code}
-newTyVarsDs :: [TyVar] -> DsM [TyVar]
+cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
+cloneTyVarsDs tyvars 
+  = getUniquesDs	`thenDs` \ uniqs ->
+    returnDs (zipWith setTyVarUnique tyvars uniqs)
 
-newTyVarsDs tyvar_tmpls dflags us genv loc mod warns
-  = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
-    (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
+newTyVarsDs :: [TyVar] -> DsM [TyVar]
+newTyVarsDs tyvar_tmpls 
+  = getUniquesDs	`thenDs` \ uniqs ->
+    returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs)
 \end{code}
 
 We can also reach out and either set/grab location information from
 the @SrcLoc@ being carried around.
+
 \begin{code}
-uniqSMtoDsM :: UniqSM a -> DsM a
+getDOptsDs :: DsM DynFlags
+getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns))
 
-uniqSMtoDsM u_action dflags us genv loc mod warns
-  = (initUs_ us u_action, warns)
+getModuleDs :: DsM Module
+getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns))
 
 getSrcLocDs :: DsM SrcLoc
-getSrcLocDs dflags us genv loc mod warns
-  = (loc, warns)
+getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns))
 
 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
-putSrcLocDs new_loc expr dflags us genv old_loc mod warns
-  = expr dflags us genv new_loc mod warns
-
-dsWarn :: WarnMsg -> DsM ()
-dsWarn warn dflags us genv loc mod warns = ((), warns `snocBag` warn)
+putSrcLocDs new_loc (DsM expr) = DsM(\ env warns ->
+    expr (env { ds_loc = new_loc }) warns)
 
+dsWarn :: DsWarning -> DsM ()
+dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn))
 \end{code}
 
 \begin{code}
-getModuleDs :: DsM Module
-getModuleDs dflags us genv loc mod warns = (mod, warns)
+dsLookupGlobal :: Name -> DsM TyThing
+dsLookupGlobal name 
+  = DsM(\ env warns -> returnUs (ds_globals env name, warns))
+
+dsLookupGlobalId :: Name -> DsM Id
+dsLookupGlobalId name 
+  = dsLookupGlobal name		`thenDs` \ thing ->
+    returnDs (get_id name thing)
+
+dsLookupTyCon :: Name -> DsM TyCon
+dsLookupTyCon name
+  = dsLookupGlobal name		`thenDs` \ thing ->
+    returnDs (get_tycon name thing)
+
+get_id name (AnId id) = id
+get_id name other     = pprPanic "dsLookupGlobalId" (ppr name)
+
+get_tycon name (ATyCon tc) = tc
+get_tycon name other       = pprPanic "dsLookupTyCon" (ppr name)
 \end{code}
 
 \begin{code}
-dsLookupGlobalValue :: Name -> DsM Id
-dsLookupGlobalValue name dflags us genv loc mod warns
-  = (genv name, warns)
+dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
+dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns))
+
+dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
+dsExtendMetaEnv menv (DsM m)
+  = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns)
 \end{code}
 
 
@@ -236,18 +270,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}