X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=2c43a5410993cc01c7b32b635b98edafc535b19a;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=c916626e8b73669f0d6a6f2ea0ec5648f46c4ab7;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index c916626..2c43a54 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -5,13 +5,14 @@
 
 \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,
-	getSrcLocDs, putSrcLocDs,
+	getSrcSpanDs, putSrcSpanDs,
 	getModuleDs,
 	newUnique, 
 	UniqSupply, newUniqueSupply,
@@ -20,40 +21,93 @@ 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 TcHsSyn		( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
 import TcRnMonad
-import IfaceEnv		( tcIfaceGlobal )
+import CoreSyn		( CoreExpr )
+import HsSyn		( HsExpr, HsMatchContext, Pat )
+import TcIface		( tcIfaceGlobal )
+import RdrName		( GlobalRdrEnv )
 import HscTypes		( TyThing(..), TypeEnv, HscEnv, 
-			  IsBootInterface,
-			  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, ModuleName, ModuleEnv )
+import Module		( Module )
 import Var		( TyVar, setTyVarUnique )
 import Outputable
-import SrcLoc		( noSrcLoc, SrcLoc )
+import SrcLoc		( noSrcSpan, SrcSpan )
 import Type             ( Type )
 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) [Pat Id] 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:
@@ -66,21 +120,25 @@ thenDs   = thenM
 returnDs = returnM
 listDs   = sequenceM
 foldlDs  = foldlM
+foldrDs  = foldrM
 mapAndUnzipDs = mapAndUnzipM
 
 
-type DsWarning = (SrcLoc, SDoc)
+type DsWarning = (SrcSpan, SDoc)
+	-- Not quite the same as a WarnMsg, we have an SDoc here 
+	-- and we'll do the print_unqual stuff later on to turn it
+	-- into a Doc.
 
 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
     }
 
 data DsLclEnv = DsLclEnv {
 	ds_meta	   :: DsMetaEnv,	-- Template Haskell bindings
-	ds_loc	   :: SrcLoc		-- to put in pattern-matching error msgs
+	ds_loc	   :: SrcSpan		-- to put in pattern-matching error msgs
      }
 
 -- Inside [| |] brackets, the desugarer looks 
@@ -90,36 +148,46 @@ type DsMetaEnv = NameEnv DsMetaVal
 data DsMetaVal
    = Bound Id		-- Bound by a pattern inside the [| |]. 
 			-- Will be dynamically alpha renamed.
-			-- The Id has type String
+			-- The Id has type THSyntax.Var
 
-   | Splice TypecheckedHsExpr	-- These bindings are introduced by
-				-- the PendingSplices on a HsBracketOut
+   | Splice (HsExpr Id)	-- These bindings are introduced by
+			-- the PendingSplices on a HsBracketOut
 
 -- initDs returns the UniqSupply out the end (not just the result)
 
 initDs  :: HscEnv
-	-> Module -> TypeEnv
-	-> ModuleEnv (ModuleName,IsBootInterface)	
+	-> Module -> GlobalRdrEnv -> TypeEnv
 	-> DsM a
-	-> IO (a, Bag DsWarning)
+	-> IO (a, Bag WarnMsg)
 
-initDs hsc_env mod type_env is_boot 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),
-				    if_is_boot = is_boot }
+	; 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 = noSrcLoc } }
+				     ds_loc = noSrcSpan } }
 
 	; 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
@@ -158,7 +226,7 @@ newTyVarsDs tyvar_tmpls
 \end{code}
 
 We can also reach out and either set/grab location information from
-the @SrcLoc@ being carried around.
+the @SrcSpan@ being carried around.
 
 \begin{code}
 getDOptsDs :: DsM DynFlags
@@ -167,14 +235,18 @@ getDOptsDs = getDOpts
 getModuleDs :: DsM Module
 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 
-getSrcLocDs :: DsM SrcLoc
-getSrcLocDs = do { env <- getLclEnv; return (ds_loc env) }
+getSrcSpanDs :: DsM SrcSpan
+getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 
-putSrcLocDs :: SrcLoc -> DsM a -> DsM a
-putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
+putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
+putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 
-dsWarn :: DsWarning -> DsM ()
-dsWarn warn = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` warn) }
+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}
 
 \begin{code}
@@ -182,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
@@ -211,15 +283,3 @@ dsExtendMetaEnv menv thing_inside
 \end{code}
 
 
-%************************************************************************
-%*									*
-\subsection{Type synonym @EquationInfo@ and access functions for its pieces}
-%*									*
-%************************************************************************
-
-\begin{code}
-data DsMatchContext
-  = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
-  | NoMatchContext
-  deriving ()
-\end{code}