X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=22cb653f79f91a87f365e6b728474c597150b5aa;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=076f7d16d2a647f37e24939e94f72c949abba1b5;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 076f7d1..22cb653 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -7,54 +7,64 @@
 #include "HsVersions.h"
 
 module RnMonad (
-	RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R,
+	SYN_IE(RnMonad), SYN_IE(RnM), SYN_IE(RnM_Fixes), RnDown, SST_R,
 	initRn, thenRn, thenRn_, andRn, returnRn,
-	mapRn, mapAndUnzipRn,
+	mapRn, mapAndUnzipRn, mapAndUnzip3Rn,
 
 	addErrRn, addErrIfRn, addWarnRn, addWarnIfRn,
 	failButContinueRn, warnAndContinueRn,
-	setExtraRn, getExtraRn,
+	setExtraRn, getExtraRn, getRnEnv,
 	getModuleRn, pushSrcLocRn, getSrcLocRn,
 	getSourceRn, getOccurrenceUpRn,
-	getImplicitUpRn, ImplicitEnv(..),
+	getImplicitUpRn, SYN_IE(ImplicitEnv), emptyImplicitEnv,
 	rnGetUnique, rnGetUniques,
 
 	newLocalNames,
-	lookupValue, lookupValueMaybe,
-	lookupTyCon, lookupClass, lookupClassOp,
+	lookupValue, lookupConstr, lookupField, lookupClassOp,
+	lookupTyCon, lookupClass, lookupTyConOrClass,
 	extendSS2, extendSS,
 
-	TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
-	lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs
+	SYN_IE(TyVarNamesEnv), mkTyVarNamesEnv, domTyVarNamesEnv,
+	lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
+
+	fixIO
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(GHCbase(fixIO))
 
 import SST
 
 import HsSyn		( FixityDecl )
 import RnHsSyn		( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
 			  mkRnImplicitTyCon, mkRnImplicitClass, 
-			  isRnLocal, isRnWired, isRnTyCon, isRnClass, isRnClassOp,
-			  RenamedFixityDecl(..) )
-import RnUtils		( RnEnv(..), extendLocalRnEnv,
-			  lookupRnEnv, lookupTcRnEnv,
-			  unknownNameErr, badClassOpErr, qualNameErr,
-			  dupNamesErr, shadowedNameWarn )
+			  isRnLocal, isRnWired, isRnTyCon, isRnClass,
+			  isRnTyConOrClass, isRnConstr, isRnField,
+			  isRnClassOp, RenamedFixityDecl(..) )
+import RnUtils		( SYN_IE(RnEnv), extendLocalRnEnv,
+			  lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
+			  qualNameErr, dupNamesErr
+			)
 
 import Bag		( Bag, emptyBag, isEmptyBag, snocBag )
 import CmdLineOpts	( opt_WarnNameShadowing )
-import ErrUtils		( Error(..), Warning(..) )
-import FiniteMap	( FiniteMap, emptyFM, lookupFM, addToFM )
+import ErrUtils		( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
+			  SYN_IE(Error), SYN_IE(Warning)
+			)
+import FiniteMap	( FiniteMap, emptyFM, lookupFM, addToFM{-, fmToList ToDo:rm-} )
 import Maybes		( assocMaybe )
-import Name		( Module(..), RdrName(..), isQual,
-			  Name, mkLocalName, mkImplicitName,
-			  getOccName
+import Name		( SYN_IE(Module), RdrName(..), isQual,
+			  OrigName(..), Name, mkLocalName, mkImplicitName,
+			  getOccName, pprNonSym
 			)
-import Pretty		( Pretty(..), PrettyRep )
+import PrelInfo		( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
+import PrelMods		( pRELUDE )
+--import PprStyle{-ToDo:rm-}
+--import Outputable{-ToDo:rm-}
+import Pretty
 import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
 import UniqFM		( UniqFM, emptyUFM )
-import UniqSet		( UniqSet(..), mkUniqSet, minusUniqSet )
+import UniqSet		( SYN_IE(UniqSet), mkUniqSet, minusUniqSet )
 import UniqSupply	( UniqSupply, getUnique, getUniques, splitUniqSupply )
 import Unique		( Unique )
 import Util
@@ -83,34 +93,41 @@ data RnMode s
  = RnSource (MutableVar s (Bag (RnName, RdrName)))
 	-- Renaming source; returning occurences
 
- | RnIface  (MutableVar s ImplicitEnv)
+ | RnIface  BuiltinNames BuiltinKeys
+	    (MutableVar s ImplicitEnv)
 	-- Renaming interface; creating and returning implicit names
-	-- One map for Values and one for TyCons/Classes.
-
-type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
+	-- ImplicitEnv: one map for Values and one for TyCons/Classes.
 
+type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName)
+emptyImplicitEnv :: ImplicitEnv
+emptyImplicitEnv = (emptyFM, emptyFM)
 
--- With a builtin polymorphic type for _runSST the type for
--- initTc should use  RnM s r  instead of  RnM _RealWorld r 
+-- With a builtin polymorphic type for runSST the type for
+-- initTc should use  RnM s r  instead of  RnM RealWorld r 
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD GHCbuiltins.RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
 
 initRn :: Bool		-- True => Source; False => Iface
        -> Module
        -> RnEnv
        -> UniqSupply
-       -> RnM _RealWorld r
+       -> RnM REAL_WORLD r
        -> (r, Bag Error, Bag Warning)
 
 initRn source mod env us do_rn
-  = _runSST (
+  = runSST (
 	newMutVarSST emptyBag			`thenSST` \ occ_var ->
-	newMutVarSST (emptyFM,emptyFM)		`thenSST` \ imp_var ->
+	newMutVarSST emptyImplicitEnv		`thenSST` \ imp_var ->
 	newMutVarSST us 			`thenSST` \ us_var ->
       	newMutVarSST (emptyBag,emptyBag)	`thenSST` \ errs_var ->
 	let
 	    mode = if source then
 		       RnSource occ_var
 	           else
-		       RnIface imp_var
+		       RnIface builtinNameMaps builtinKeysMap imp_var
 
 	    rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
 	in
@@ -154,6 +171,12 @@ mapAndUnzipRn f (x:xs)
   = f x		    	`thenRn` \ (r1,  r2)  ->
     mapAndUnzipRn f xs	`thenRn` \ (rs1, rs2) ->
     returnRn (r1:rs1, r2:rs2)
+
+mapAndUnzip3Rn f [] = returnRn ([],[],[])
+mapAndUnzip3Rn f (x:xs)
+  = f x		    	`thenRn` \ (r1,  r2,  r3)  ->
+    mapAndUnzip3Rn f xs	`thenRn` \ (rs1, rs2, rs3) ->
+    returnRn (r1:rs1, r2:rs2, r3:rs3)
 \end{code}
 
 For errors and warnings ...
@@ -187,6 +210,10 @@ addWarnIfRn False warn = returnRn ()
 
 
 \begin{code}
+getRnEnv :: RnMonad x s RnEnv
+getRnEnv (RnDown _ _ _ _ env _ _)
+  = returnSST env
+
 setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
 setExtraRn x m (RnDown _ mod locn mode env us errs)
   = m (RnDown x mod locn mode env us errs)
@@ -208,17 +235,17 @@ getSrcLocRn (RnDown _ _ locn _ _ _ _)
   = returnSST locn
 
 getSourceRn :: RnMonad x s Bool
-getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
-getSourceRn (RnDown _ _ _ (RnIface  _) _ _ _) = returnSST False
+getSourceRn (RnDown _ _ _ (RnSource _)    _ _ _) = returnSST True
+getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
 
 getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
 getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
   = readMutVarSST occ_var
-getOccurrenceUpRn (RnDown _ _ _ (RnIface _) _ _ _)
+getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
   = panic "getOccurrenceUpRn:RnIface"
 
-getImplicitUpRn :: RnMonad x s (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
-getImplicitUpRn (RnDown _ _ _ (RnIface imp_var) _ _ _)
+getImplicitUpRn :: RnMonad x s ImplicitEnv
+getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
   = readMutVarSST imp_var
 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
   = panic "getImplicitUpRn:RnIface"
@@ -274,11 +301,11 @@ newLocalNames :: String 		-- Documentation string
 	      -> RnMonad x s [RnName]
 
 newLocalNames str names_w_loc
-  = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
-    mapRn (addErrRn . dupNamesErr str) dups  `thenRn_`
+  = mapRn (addErrRn . qualNameErr str) quals 	`thenRn_`
+    mapRn (addErrRn . dupNamesErr str) dups  	`thenRn_`
     mkLocalNames these
   where
-    quals         = filter (isQual.fst) names_w_loc
+    quals = filter (isQual.fst) names_w_loc
     (these, dups) = removeDups cmp_fst names_w_loc
     cmp_fst (a,_) (b,_) = cmp a b
 \end{code}
@@ -287,10 +314,10 @@ newLocalNames str names_w_loc
 mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
 mkLocalNames names_w_locs
   = rnGetUniques (length names_w_locs) 	`thenRn` \ uniqs ->
-    returnRn (zipWithEqual new_local uniqs names_w_locs)
+    returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs)
   where
     new_local uniq (Unqual str, srcloc)
-      = mkRnName (mkLocalName uniq str srcloc)
+      = mkRnName (mkLocalName uniq str False{-emph names-} srcloc)
 \end{code}
 
 
@@ -312,19 +339,28 @@ If not found create new implicit name, adding it to the implicit env.
 
 \begin{code}
 lookupValue      :: RdrName -> RnMonad x s RnName
+lookupConstr     :: RdrName -> RnMonad x s RnName
+lookupField      :: RdrName -> RnMonad x s RnName
 lookupClassOp    :: RnName  -> RdrName -> RnMonad x s RnName
 
 lookupValue rdr
-  = lookup_val rdr (\ rn -> True) (unknownNameErr "value")
+  = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
+
+lookupConstr rdr
+  = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
+
+lookupField rdr
+  = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
 
 lookupClassOp cls rdr
-  = lookup_val rdr (isRnClassOp cls) (badClassOpErr cls)
+  = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
 
+-- Note: the lookup checks are only performed when renaming source
 
-lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
-  = case lookupRnEnv env rdr of
+lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
+  = case lookup env rdr of
 	Just name | check name -> succ name
-		  | otherwise   -> fail
+		  | otherwise  -> fail
 	Nothing                -> fail
 
   where
@@ -335,29 +371,34 @@ lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
 		    returnSST name
     fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
 
-lookup_val rdr check do_err down@(RnDown _ _ locn (RnIface imp_var) env us_var _)
-  = case lookupRnEnv env rdr of
-	Just name | check name -> returnSST name
-		  | otherwise  -> failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
-	Nothing                -> lookup_or_create_implicit_val imp_var us_var rdr
-
-lookup_or_create_implicit_val imp_var us_var rdr
-  = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)->
-    case lookupFM implicit_val_fm rdr of
+lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
+  = case lookup env rdr of
+      Just name -> returnSST name
+      Nothing   -> case rdr of
+		     Unqual n -> panic ("lookup_val:"++ _UNPK_ n)
+		     Qual m n ->
+		       lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n)
+
+lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig
+  = case (lookupFM b_names orig) of
+      Just xx -> returnSST xx
+      Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig
+
+lookup_or_create_implicit_val b_key imp_var us_var orig
+  = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
+    case (lookupFM implicit_val_fm orig) of
 	Just implicit -> returnSST implicit
 	Nothing ->
-	    get_unique us_var			`thenSST` \ uniq -> 
-	    let
-		implicit   = mkRnImplicit (mkImplicitName uniq rdr)
-		new_val_fm = addToFM implicit_val_fm rdr implicit
-	    in
-	    writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
-	    returnSST implicit
-
-
-lookupValueMaybe :: RdrName -> RnMonad x s (Maybe RnName)
-lookupValueMaybe rdr down@(RnDown _ _ _ (RnSource _) env _ _)
-  = returnSST (lookupRnEnv env rdr)
+	  (case (lookupFM b_key orig) of
+		Just (u,_) -> returnSST u
+		_          -> get_unique us_var
+	  )							`thenSST` \ uniq -> 
+	  let
+	      implicit   = mkRnImplicit (mkImplicitName uniq orig)
+	      new_val_fm = addToFM implicit_val_fm orig implicit
+	  in
+	  writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) 	`thenSST_`
+	  returnSST implicit
 \end{code}
 
 
@@ -371,6 +412,9 @@ lookupTyCon rdr
 lookupClass rdr
   = lookup_tc rdr isRnClass mkRnImplicitClass "class"
 
+lookupTyConOrClass rdr
+  = lookup_tc rdr isRnTyConOrClass
+	      (panic "lookupTC:mk_implicit") "class or type constructor"
 
 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
   = case lookupTcRnEnv env rdr of
@@ -382,27 +426,36 @@ lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var)
 		returnSST name
     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 
-lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface imp_var) env us_var _)
+lookup_tc rdr@(Qual m n) check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
   = case lookupTcRnEnv env rdr of
 	Just name | check name -> returnSST name
 		  | otherwise  -> fail
-	Nothing -> lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr
+	Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n)
   where
     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 
-lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr
-  = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)->
-    case lookupFM implicit_tc_fm rdr of
+lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var orig--@(OrigName m n)
+  = --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $
+    case (lookupFM b_names orig) of
+      Just xx -> returnSST xx
+      Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
+
+lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
+  = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
+    case (lookupFM implicit_tc_fm orig) of
 	Just implicit | check implicit -> returnSST implicit
 		      | otherwise      -> fail
 	Nothing ->
-	    get_unique us_var			`thenSST` \ uniq -> 
-	    let
-		implicit  = mk_implicit (mkImplicitName uniq rdr)
-		new_tc_fm = addToFM implicit_tc_fm rdr implicit
-	    in
-	    writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
-	    returnSST implicit
+	  (case (lookupFM b_key orig) of
+		Just (u,_) -> returnSST u
+		_          -> get_unique us_var
+	  )							`thenSST` \ uniq -> 
+	  let
+	      implicit  = mk_implicit (mkImplicitName uniq orig)
+	      new_tc_fm = addToFM implicit_tc_fm orig implicit
+	  in
+	  writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) 	`thenSST_`
+	  returnSST implicit
 \end{code}
 
 
@@ -490,3 +543,39 @@ lookupTyVarName env occ
 		   failButContinueRn (mkRnUnbound occ)
 		       (unknownNameErr "type variable" occ loc)
 \end{code}
+
+
+\begin{code}
+#if __GLASGOW_HASKELL__ >= 200
+    -- can get it from GHCbase
+#else
+fixIO :: (a -> IO a) -> IO a
+
+fixIO k s = let
+		result          = k loop s
+		(Right loop, _) = result
+	    in
+	    result
+#endif
+\end{code}
+
+*********************************************************
+*							*
+\subsection{Errors used in RnMonad}
+*							*
+*********************************************************
+
+\begin{code}
+unknownNameErr descriptor name locn
+  = addShortErrLocLine locn $ \ sty ->
+    ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
+
+badClassOpErr clas op locn
+  = addErrLoc locn "" $ \ sty ->
+    ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
+	      ppr sty clas, ppStr "'"]
+
+shadowedNameWarn locn shadow
+  = addShortWarnLocLine locn $ \ sty ->
+    ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]
+\end{code}