X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnBinds.lhs;h=bb6f9eac464d4868df879abb07b4f93c91f12f47;hb=c43a63d313214dbe0e1fe1d3fd2d982edff66cb1;hp=8a2932f854ae6b9c0a0586e39d481b26f9b1c6e6;hpb=f53c4074ff7554ceedaa6b7a5edb2bca7a2d3886;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 8a2932f..bb6f9ea 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -18,16 +18,16 @@ module RnBinds (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
 
 import HsSyn
 import HsBinds		( eqHsSig, sigName, hsSigDoc )
 import RdrHsSyn
 import RnHsSyn
 import RnMonad
+import RnTypes		( rnHsSigType, rnHsType )
 import RnExpr		( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
-import RnEnv		( bindLocatedLocalsRn, lookupBndrRn, 
-			  lookupGlobalOccRn, lookupSigOccRn,
+import RnEnv		( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr,
+			  lookupSigOccRn, bindPatSigTyVars,
 			  warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
 			)
 import CmdLineOpts	( DynFlag(..) )
@@ -162,21 +162,22 @@ rnTopBinds (MonoBind bind sigs _) 	  = rnTopMonoBinds bind sigs
 
 
 rnTopMonoBinds mbinds sigs
- =  mapRn lookupBndrRn binder_rdr_names		`thenRn` \ binder_names ->
+ =  mapRn lookupBndrRn binder_rdr_names			 `thenRn` \ binder_names ->
+    bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ 
     let
 	bndr_name_set = mkNameSet binder_names
     in
     renameSigsFVs (okBindSig bndr_name_set) sigs 	`thenRn` \ (siglist, sig_fvs) ->
-    doptRn Opt_WarnMissingSigs				`thenRn` \ warnMissing ->
-    let
-	type_sig_vars	= [n | Sig n _ _ <- siglist]
-	un_sigd_binders | warnMissing = nameSetToList (delListFromNameSet 
-                                                          bndr_name_set type_sig_vars)
-			| otherwise   = []
-    in
-    mapRn_ missingSigWarn un_sigd_binders	`thenRn_`
 
-    rn_mono_binds siglist mbinds		   `thenRn` \ (final_binds, bind_fvs) ->
+    ifOptRn Opt_WarnMissingSigs (
+	let
+	    type_sig_vars   = [n | Sig n _ _ <- siglist]
+	    un_sigd_binders = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars)
+	in
+        mapRn_ missingSigWarn un_sigd_binders
+    )						`thenRn_`
+
+    rn_mono_binds siglist mbinds		`thenRn` \ (final_binds, bind_fvs) ->
     returnRn (final_binds, bind_fvs `plusFV` sig_fvs)
   where
     binder_rdr_names = collectMonoBinders mbinds
@@ -217,8 +218,8 @@ rnMonoBinds mbinds sigs	thing_inside -- Non-empty monobinds
   =	-- Extract all the binders in this group,
 	-- and extend current scope, inventing new names for the new binders
 	-- This also checks that the names form a set
-    bindLocatedLocalsRn (text "a binding group") 
-			mbinders_w_srclocs	$ \ new_mbinders ->
+    bindLocatedLocalsRn doc mbinders_w_srclocs			$ \ new_mbinders ->
+    bindPatSigTyVars (collectSigTysFromMonoBinds mbinds)	$ 
     let
 	binder_set = mkNameSet new_mbinders
     in
@@ -246,6 +247,9 @@ rnMonoBinds mbinds sigs	thing_inside -- Non-empty monobinds
     returnRn (result, delListFromNameSet all_fvs new_mbinders)
   where
     mbinders_w_srclocs = collectLocatedMonoBinders mbinds
+    doc = text "In the binding group for" <+> pp_bndrs mbinders_w_srclocs
+    pp_bndrs [(b,_)] = quotes (ppr b)
+    pp_bndrs bs      = fsep (punctuate comma [ppr b | (b,_) <- bs])
 \end{code}
 
 
@@ -327,7 +331,7 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn)
 	names_bound_here = unitNameSet new_name
     in
     sigsForMe names_bound_here sigs			`thenRn` \ sigs_for_me ->
-    mapFvRn rnMatch matches				`thenRn` \ (new_matches, fvs) ->
+    mapFvRn (rnMatch (FunRhs name)) matches		`thenRn` \ (new_matches, fvs) ->
     mapRn_ (checkPrecMatch inf new_name) new_matches	`thenRn_`
     returnRn
       [(unitNameSet new_name,
@@ -363,21 +367,22 @@ in many ways the @op@ in an instance decl is just like an occurrence, not
 a binder.
 
 \begin{code}
-rnMethodBinds :: [Name]			-- Names for generic type variables
+rnMethodBinds :: Name			-- Class name
+	      -> [Name]			-- Names for generic type variables
 	      -> RdrNameMonoBinds
 	      -> RnMS (RenamedMonoBinds, FreeVars)
 
-rnMethodBinds gen_tyvars EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
+rnMethodBinds cls gen_tyvars EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
 
-rnMethodBinds gen_tyvars (AndMonoBinds mb1 mb2)
-  = rnMethodBinds gen_tyvars mb1	`thenRn` \ (mb1', fvs1) ->
-    rnMethodBinds gen_tyvars mb2	`thenRn` \ (mb2', fvs2) ->
+rnMethodBinds cls gen_tyvars (AndMonoBinds mb1 mb2)
+  = rnMethodBinds cls gen_tyvars mb1	`thenRn` \ (mb1', fvs1) ->
+    rnMethodBinds cls gen_tyvars mb2	`thenRn` \ (mb2', fvs2) ->
     returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)
 
-rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn)
+rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn)
   = pushSrcLocRn locn				   	$
 
-    lookupGlobalOccRn name				`thenRn` \ sel_name -> 
+    lookupInstDeclBndr cls name				`thenRn` \ sel_name -> 
 	-- We use the selector name as the binder
 
     mapFvRn rn_match matches				`thenRn` \ (new_matches, fvs) ->
@@ -386,17 +391,17 @@ rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn)
   where
 	-- Gruesome; bring into scope the correct members of the generic type variables
 	-- See comments in RnSource.rnSourceDecl(ClassDecl)
-    rn_match match@(Match _ (TypePatIn ty : _) _ _)
-	= extendTyVarEnvFVRn gen_tvs (rnMatch match)
+    rn_match match@(Match (TypePatIn ty : _) _ _)
+	= extendTyVarEnvFVRn gen_tvs (rnMatch (FunRhs name) match)
 	where
 	  tvs     = map rdrNameOcc (extractHsTyRdrNames ty)
 	  gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] 
 
-    rn_match match = rnMatch match
+    rn_match match = rnMatch (FunRhs name) match
 	
 
 -- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBinds gen_tyvars mbind@(PatMonoBind other_pat _ locn)
+rnMethodBinds cls gen_tyvars mbind@(PatMonoBind other_pat _ locn)
   = pushSrcLocRn locn	$
     failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)
 \end{code}
@@ -535,38 +540,10 @@ renameSig (FixSig (FixitySig v fix src_loc))
     lookupSigOccRn v		`thenRn` \ new_v ->
     returnRn (FixSig (FixitySig new_v fix src_loc))
 
-renameSig (InlineSig v p src_loc)
+renameSig (InlineSig b v p src_loc)
   = pushSrcLocRn src_loc $
     lookupSigOccRn v		`thenRn` \ new_v ->
-    returnRn (InlineSig new_v p src_loc)
-
-renameSig (NoInlineSig v p src_loc)
-  = pushSrcLocRn src_loc $
-    lookupSigOccRn v		`thenRn` \ new_v ->
-    returnRn (NoInlineSig new_v p src_loc)
-\end{code}
-
-\begin{code}
-renameIE :: (RdrName -> RnMS Name) -> IE RdrName -> RnMS (IE Name, FreeVars)
-renameIE lookup_occ_nm (IEVar v)
-  = lookup_occ_nm v		`thenRn` \ new_v ->
-    returnRn (IEVar new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingAbs v)
-  = lookup_occ_nm v		`thenRn` \ new_v ->
-    returnRn (IEThingAbs new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingAll v)
-  = lookup_occ_nm v		`thenRn` \ new_v ->
-    returnRn (IEThingAll new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingWith v vs)
-  = lookup_occ_nm v		`thenRn` \ new_v ->
-    mapRn lookup_occ_nm vs	`thenRn` \ new_vs ->
-    returnRn (IEThingWith new_v new_vs, plusFVs [ unitFV x | x <- new_v:new_vs ])
-
-renameIE lookup_occ_nm (IEModuleContents m)
-  = returnRn (IEModuleContents m, emptyFVs)
+    returnRn (InlineSig b new_v p src_loc)
 \end{code}