X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=f24dee4905257e0dbb16c1c0a4f45fc4e697eca0;hb=3c245de9199f522f75ace92219256badbd928bd6;hp=b5b85987bec7b50f36139a0f8b8d00814e5bf864;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index b5b8598..f24dee4 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -5,10 +5,11 @@
 
 \begin{code}
 module DsMonad (
-	DsM, mappM,
-	initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, foldlDs,
+	DsM, mappM, mapAndUnzipM,
+	initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, 
+	foldlDs, foldrDs,
 
-	newTyVarsDs, 
+	newTyVarsDs, newLocalName,
 	duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
 	newFailLocalDs,
 	getSrcSpanDs, putSrcSpanDs,
@@ -20,22 +21,27 @@ module DsMonad (
 
 	DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
-	dsWarn, 
-	DsWarning,
-	DsMatchContext(..)
+	-- Warnings
+	DsWarning, dsWarn, 
+
+	-- Data types
+	DsMatchContext(..),
+	EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
+	CanItFail(..), orFail
     ) where
 
 #include "HsVersions.h"
 
 import TcRnMonad
+import CoreSyn		( CoreExpr )
 import HsSyn		( HsExpr, HsMatchContext, Pat )
 import TcIface		( tcIfaceGlobal )
+import RdrName		( GlobalRdrEnv )
 import HscTypes		( TyThing(..), TypeEnv, HscEnv, 
-			  tyThingId, tyThingTyCon, tyThingDataCon  )
+			  tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope )
 import Bag		( emptyBag, snocBag, Bag )
 import DataCon		( DataCon )
 import TyCon		( TyCon )
-import DataCon		( DataCon )
 import Id		( mkSysLocal, setIdUnique, Id )
 import Module		( Module )
 import Var		( TyVar, setTyVarUnique )
@@ -46,13 +52,62 @@ import UniqSupply	( UniqSupply, uniqsFromSupply )
 import Name		( Name, nameOccName )
 import NameEnv
 import OccName          ( occNameFS )
-import CmdLineOpts	( DynFlags )
+import DynFlags	( DynFlags )
+import ErrUtils		( WarnMsg, mkWarnMsg )
+import Bag		( mapBag )
 
 import DATA_IOREF	( newIORef, readIORef )
 
 infixr 9 `thenDs`
 \end{code}
 
+%************************************************************************
+%*									*
+		Data types for the desugarer
+%*									*
+%************************************************************************
+
+\begin{code}
+data DsMatchContext
+  = DsMatchContext (HsMatchContext Name) SrcSpan
+  | NoMatchContext
+  deriving ()
+
+data EquationInfo
+  = EqnInfo { eqn_wrap :: DsWrapper,	-- Bindings
+	      eqn_pats :: [Pat Id],    	-- The patterns for an eqn
+	      eqn_rhs  :: MatchResult }	-- What to do after match
+
+type DsWrapper = CoreExpr -> CoreExpr
+idWrapper e = e
+
+-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
+--	\fail. wrap (case vs of { pats -> rhs fail })
+-- where vs are not bound by wrap
+
+
+-- A MatchResult is an expression with a hole in it
+data MatchResult
+  = MatchResult
+	CanItFail	-- Tells whether the failure expression is used
+	(CoreExpr -> DsM CoreExpr)
+			-- Takes a expression to plug in at the
+			-- failure point(s). The expression should
+			-- be duplicatable!
+
+data CanItFail = CanFail | CantFail
+
+orFail CantFail CantFail = CantFail
+orFail _        _	 = CanFail
+\end{code}
+
+
+%************************************************************************
+%*									*
+		Monad stuff
+%*									*
+%************************************************************************
+
 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:
@@ -65,6 +120,7 @@ thenDs   = thenM
 returnDs = returnM
 listDs   = sequenceM
 foldlDs  = foldlM
+foldrDs  = foldrM
 mapAndUnzipDs = mapAndUnzipM
 
 
@@ -76,7 +132,7 @@ type DsWarning = (SrcSpan, SDoc)
 data DsGblEnv = DsGblEnv {
 	ds_mod	   :: Module,       		-- For SCC profiling
 	ds_warns   :: IORef (Bag DsWarning),	-- Warning messages
-	ds_if_env  :: IfGblEnv			-- Used for looking up global, 
+	ds_if_env  :: (IfGblEnv, IfLclEnv)	-- Used for looking up global, 
 						-- possibly-imported things
     }
 
@@ -100,15 +156,16 @@ data DsMetaVal
 -- initDs returns the UniqSupply out the end (not just the result)
 
 initDs  :: HscEnv
-	-> Module -> TypeEnv
+	-> Module -> GlobalRdrEnv -> TypeEnv
 	-> DsM a
-	-> IO (a, Bag DsWarning)
+	-> IO (a, Bag WarnMsg)
 
-initDs hsc_env mod type_env thing_inside
+initDs hsc_env mod rdr_env type_env thing_inside
   = do 	{ warn_var <- newIORef emptyBag
-	; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+	; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+	      ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
 	      ; gbl_env = DsGblEnv { ds_mod = mod, 
-				     ds_if_env = if_env, 
+				     ds_if_env = (if_genv, if_lenv),
 				     ds_warns = warn_var }
 	      ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv, 
 				     ds_loc = noSrcSpan } }
@@ -116,10 +173,21 @@ initDs hsc_env mod type_env thing_inside
 	; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
 
 	; warns <- readIORef warn_var
-	; return (res, warns)
+	; return (res, mapBag mk_warn warns)
 	}
+   where
+    print_unqual = unQualInScope rdr_env
+
+    mk_warn :: (SrcSpan,SDoc) -> WarnMsg
+    mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
 \end{code}
 
+%************************************************************************
+%*									*
+		Operations in the monad
+%*									*
+%************************************************************************
+
 And all this mysterious stuff is so we can occasionally reach out and
 grab one or more names.  @newLocalDs@ isn't exported---exported
 functions are defined with it.  The difference in name-strings makes
@@ -173,8 +241,10 @@ getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 
-dsWarn :: DsWarning -> DsM ()
-dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
+dsWarn :: SDoc -> DsM ()
+dsWarn warn = do { env <- getGblEnv 
+		 ; loc <- getSrcSpanDs
+		 ; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
 	    where
 	      msg = ptext SLIT("Warning:") <+> warn
 \end{code}
@@ -184,7 +254,7 @@ dsLookupGlobal :: Name -> DsM TyThing
 -- Very like TcEnv.tcLookupGlobal
 dsLookupGlobal name 
   = do	{ env <- getGblEnv
-	; setEnvs (ds_if_env env, ())
+	; setEnvs (ds_if_env env)
 		  (tcIfaceGlobal name) }
 
 dsLookupGlobalId :: Name -> DsM Id
@@ -213,15 +283,3 @@ dsExtendMetaEnv menv thing_inside
 \end{code}
 
 
-%************************************************************************
-%*									*
-\subsection{Type synonym @EquationInfo@ and access functions for its pieces}
-%*									*
-%************************************************************************
-
-\begin{code}
-data DsMatchContext
-  = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
-  | NoMatchContext
-  deriving ()
-\end{code}