X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=088910904967ecfc28f44181dcc776e1e243ddf0;hb=8655d6ca41df4aa77a559d4067ad3815797b9803;hp=bf3f5f0878881791cee86d4960d9ce173d8d353e;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index bf3f5f0..0889109 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -1,49 +1,52 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
 
 \begin{code}
-#include "HsVersions.h"
-
 module DsMonad (
-	SYN_IE(DsM),
-	initDs, returnDs, thenDs, andDs, mapDs, listDs,
-	mapAndUnzipDs, zipWithDs,
+	DsM,
+	initDs, returnDs, thenDs, mapDs, listDs, fixDs,
+	mapAndUnzipDs, zipWithDs, foldlDs,
 	uniqSMtoDsM,
 	newTyVarsDs, cloneTyVarsDs,
-	duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
+	duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
 	newFailLocalDs,
 	getSrcLocDs, putSrcLocDs,
-	getModuleAndGroupDs,
-	extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
-	SYN_IE(DsIdEnv),
-	lookupId,
+	getModuleDs,
+	getUniqueDs, getUniquesDs,
+	UniqSupply, getUniqSupplyDs,
+	getDOptsDs,
+	dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
+
+	DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
-	dsShadowError,
-	DsMatchContext(..), DsMatchKind(..), pprDsWarnings
+	dsWarn, 
+	DsWarnings,
+	DsMatchContext(..)
     ) where
 
-IMP_Ubiq()
-
-import Bag		( emptyBag, snocBag, bagToList )
-import CmdLineOpts	( opt_SccGroup )
-import CoreSyn		( SYN_IE(CoreExpr) )
-import CoreUtils	( substCoreExpr )
-import HsSyn		( OutPat )
-import Id		( mkSysLocal, mkIdWithNewUniq,
-			  lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv)
-			)
-import PprType		( GenType, GenTyVar )
-import PprStyle		( PprStyle(..) )
-import Pretty
+#include "HsVersions.h"
+
+import TcHsSyn		( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
+import HscTypes		( TyThing(..) )
+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 )
+import Outputable
 import SrcLoc		( noSrcLoc, SrcLoc )
-import TcHsSyn		( SYN_IE(TypecheckedPat) )
-import TyVar		( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
-import Unique		( Unique{-instances-} )
-import UniqSupply	( splitUniqSupply, getUnique, getUniques,
-			  mapUs, thenUs, returnUs, SYN_IE(UniqSM) )
-import Util		( assoc, mapAccumL, zipWithEqual, panic )
+import Type             ( Type )
+import UniqSupply	( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs, 
+			  fixUs, UniqSM, UniqSupply, getUs )
+import Unique		( Unique ) 
+import Name		( Name, nameOccName )
+import NameEnv
+import OccName          ( occNameFS )
+import CmdLineOpts	( DynFlags )
 
 infixr 9 `thenDs`
 \end{code}
@@ -52,52 +55,69 @@ 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 =
-	UniqSupply
-	-> SrcLoc			-- to put in pattern-matching error msgs
-	-> (FAST_STRING, FAST_STRING)	-- "module"+"group" : for SCC profiling
-	-> DsIdEnv
-	-> DsWarnings
-	-> (result, DsWarnings)
-
-type DsWarnings = Bag DsMatchContext	-- The desugarer reports matches which are
-					-- completely shadowed
-{-# INLINE andDs #-}
+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
+
+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 thenDs #-}
 {-# INLINE returnDs #-}
 
 -- initDs returns the UniqSupply out the end (not just the result)
 
-initDs  :: UniqSupply
-	-> DsIdEnv
-	-> FAST_STRING -- module name: for profiling; (group name: from switches)
+initDs  :: DynFlags
+	-> UniqSupply
+	-> (Name -> TyThing)
+	-> Module   -- module name: for profiling
 	-> DsM a
 	-> (a, DsWarnings)
 
-initDs init_us env mod_name action
-  = action init_us noSrcLoc module_and_group env emptyBag
+initDs dflags init_us lookup mod (DsM action)
+  = initUs_ init_us (action ds_env emptyBag)
   where
-    module_and_group = (mod_name, grp_name)
-    grp_name  = case opt_SccGroup of
-		    Just xx -> _PK_ xx
-		    Nothing -> mod_name	-- default: module name
+    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 us loc mod_and_grp env warns
-  = case splitUniqSupply us		    of { (s1, s2) ->
-    case (m1 s1 loc mod_and_grp env warns)  of { (result, warns1) ->
-    m2 result s2 loc mod_and_grp env warns1}}
-
-andDs combiner m1 m2 us loc mod_and_grp env warns
-  = case splitUniqSupply us		    of { (s1, s2) ->
-    case (m1 s1 loc mod_and_grp env warns)  of { (result1, warns1) ->
-    case (m2 s2 loc mod_and_grp env 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 us loc mod_and_grp env warns = (result, warns)
+returnDs result = DsM (\ env warns -> returnUs (result, warns))
+
+fixDs :: (a -> DsM a) -> DsM a
+fixDs f = DsM (\env warns -> fixUs (\ ~(a, _warns') -> unDsM (f a) env warns))
 
 listDs :: [DsM a] -> DsM [a]
 listDs []     = returnDs []
@@ -114,6 +134,12 @@ mapDs f (x:xs)
     mapDs f xs	`thenDs` \ rs ->
     returnDs (r:rs)
 
+foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
+
+foldlDs k z []     = returnDs z
+foldlDs k z (x:xs) = k z x `thenDs` \ r ->
+		     foldlDs k r xs
+
 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 
 mapAndUnzipDs f []     = returnDs ([], [])
@@ -124,159 +150,143 @@ mapAndUnzipDs f (x:xs)
 
 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 
-zipWithDs f []	   [] = returnDs []
+zipWithDs f []	   ys = returnDs []
 zipWithDs f (x:xs) (y:ys)
   = f x y		`thenDs` \ r  ->
     zipWithDs f xs ys	`thenDs` \ rs ->
     returnDs (r:rs)
--- Note: crashes if lists not equal length (like zipWithEqual)
 \end{code}
 
 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
 it easier to read debugging output.
-\begin{code}
-newLocalDs :: FAST_STRING -> Type -> DsM Id
-newLocalDs nm ty us loc mod_and_grp env warns
-  = case (getUnique us) of { assigned_uniq ->
-    (mkSysLocal nm assigned_uniq ty loc, warns) }
 
-newSysLocalDs	    = newLocalDs SLIT("ds")
-newSysLocalsDs tys  = mapDs (newLocalDs SLIT("ds")) tys
-newFailLocalDs	    = newLocalDs SLIT("fail")
+\begin{code}
+uniqSMtoDsM :: UniqSM a -> DsM a
+uniqSMtoDsM u_action = DsM(\ env warns -> 
+	u_action	`thenUs` \ res ->
+	returnUs (res, warns))
+
+    
+getUniqueDs :: DsM Unique
+getUniqueDs = DsM (\ env warns -> 
+    getUniqueUs		`thenUs` \ uniq -> 
+    returnUs (uniq, warns))
+
+getUniquesDs :: DsM [Unique]
+getUniquesDs = DsM(\ env warns -> 
+    getUniquesUs		`thenUs` \ uniqs -> 
+    returnUs (uniqs, warns))
+
+getUniqSupplyDs :: DsM UniqSupply
+getUniqSupplyDs = DsM(\ env warns -> 
+    getUs		`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 us loc mod_and_grp env warns
-  = case (getUnique us) of { assigned_uniq ->
-    (mkIdWithNewUniq old_local assigned_uniq, warns) }
+duplicateLocalDs old_local 
+  = getUniqueDs 	`thenDs` \ uniq ->
+    returnDs (setIdUnique old_local uniq)
 
-cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
-cloneTyVarsDs tyvars us loc mod_and_grp env warns
-  = case (getUniques (length tyvars) us) of { uniqs ->
-    (zipWithEqual "cloneTyVarsDs" cloneTyVar 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 us loc mod_and_grp env warns
-  = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
-    (zipWithEqual "newTyVarsDs" cloneTyVar 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 us loc mod_and_grp env warns
-  = (u_action us, warns)
+getModuleDs :: DsM Module
+getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns))
 
 getSrcLocDs :: DsM SrcLoc
-getSrcLocDs us loc mod_and_grp env warns
-  = (loc, warns)
+getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns))
 
 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
-putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
-  = expr us new_loc mod_and_grp env warns
+putSrcLocDs new_loc (DsM expr) = DsM(\ env warns ->
+    expr (env { ds_loc = new_loc }) warns)
 
-dsShadowError :: DsMatchContext -> DsM ()
-dsShadowError cxt us loc mod_and_grp env warns
-  = ((), warns `snocBag` cxt)
+dsWarn :: DsWarning -> DsM ()
+dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn))
 \end{code}
 
 \begin{code}
-getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
-getModuleAndGroupDs us loc mod_and_grp env warns
-  = (mod_and_grp, 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 $ case thing of
+		AnId id -> id
+		other   -> pprPanic "dsLookupGlobalId" (ppr name)
+
+dsLookupTyCon :: Name -> DsM TyCon
+dsLookupTyCon name
+  = dsLookupGlobal name		`thenDs` \ thing ->
+    returnDs $ case thing of
+		 ATyCon tc -> tc
+		 other     -> pprPanic "dsLookupTyCon" (ppr name)
+
+dsLookupDataCon :: Name -> DsM DataCon
+dsLookupDataCon name
+  = dsLookupGlobal name		`thenDs` \ thing ->
+    returnDs $ case thing of
+		 ADataCon dc -> dc
+		 other       -> pprPanic "dsLookupDataCon" (ppr name)
 \end{code}
 
 \begin{code}
-type DsIdEnv = IdEnv CoreExpr
+dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
+dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns))
 
-extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
-
-extendEnvDs pairs then_do us loc mod_and_grp old_env warns
-  = case splitUniqSupply us 	    of { (s1, s2) ->
-    let
-	revised_pairs = subst_all pairs s1
-    in
-    then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
-    }
-  where
-    subst_all pairs = mapUs subst pairs
-
-    subst (v, expr)
-      = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr ->
-	returnUs (v, new_expr)
-
-lookupEnvDs :: Id -> DsM (Maybe CoreExpr)
-lookupEnvDs id us loc mod_and_grp env warns
-  = (lookupIdEnv env id, warns)
-  -- Note: we don't assert anything about the Id
-  -- being looked up.  There's not really anything
-  -- much to say about it. (WDP 94/06)
-
-lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
-lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
-  = (case (lookupIdEnv env id) of
-      Nothing -> deflt
-      Just xx -> xx,
-     warns)
-
-lookupId :: [(Id, a)] -> Id -> a
-lookupId env id
-  = assoc "lookupId" env id
+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}
 
+
 %************************************************************************
 %*									*
-%* type synonym EquationInfo and access functions for its pieces	*
+\subsection{Type synonym @EquationInfo@ and access functions for its pieces}
 %*									*
 %************************************************************************
 
 \begin{code}
 data DsMatchContext
-  = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
+  = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
   | NoMatchContext
-
-data DsMatchKind
-  = FunMatch Id
-  | CaseMatch
-  | LambdaMatch
-  | PatBindMatch
-  | DoBindMatch
-
-pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
-pprDsWarnings sty warns
-  = ppAboves (map pp_cxt (bagToList warns))
-  where
-    pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what")
-    pp_cxt (DsMatchContext kind pats loc)
-      = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
-	     4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:"))
-		     4 (pp_match kind pats))
-
-    pp_match (FunMatch fun) pats
-      = ppHang (ppr sty fun)
-	4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")])
-
-    pp_match CaseMatch pats
-      = ppHang (ppPStr SLIT("in a case alternative:"))
-	4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
-
-    pp_match PatBindMatch pats
-      = ppHang (ppPStr SLIT("in a pattern binding:"))
-	4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
-
-    pp_match LambdaMatch pats
-      = ppHang (ppPStr SLIT("in a lambda abstraction:"))
-	4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
-
-    pp_match DoBindMatch pats
-      = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
-	4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
-
-    pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
+  deriving ()
 \end{code}