X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnBinds.lhs;h=bfc67adc57ab7d22e1f5c82b86c92ef25e1ced7f;hb=0b445d919bc1f6e8014956d67a1154d8d2af3521;hp=ef5596b2d9e76cc6eb5e8c81631492950c7db3f7;hpb=6a562dd51c1d264ce74a9f6fdf020e21ce34d143;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index ef5596b..bfc67ad 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -27,20 +27,20 @@ import RnHsSyn
 import RnMonad
 import RnExpr		( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
 import RnEnv		( bindLocatedLocalsRn, lookupBndrRn, 
-			  lookupGlobalOccRn, lookupOccRn, lookupSigOccRn,
-			  warnUnusedLocalBinds, mapFvRn, 
-			  FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV,
-			  unknownNameErr
+			  lookupGlobalOccRn, lookupSigOccRn,
+			  warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
+			  FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV
 			)
-import CmdLineOpts	( opt_WarnMissingSigs )
+import CmdLineOpts	( DynFlag(..) )
 import Digraph		( stronglyConnComp, SCC(..) )
-import Name		( OccName, Name, nameOccName, mkUnboundName, isUnboundName )
+import Name		( OccName, Name, nameOccName )
 import NameSet
-import RdrName		( RdrName, rdrNameOcc  )
-import BasicTypes	( RecFlag(..), TopLevelFlag(..) )
+import RdrName		( RdrName, rdrNameOcc )
+import BasicTypes	( RecFlag(..) )
 import List		( partition )
 import Bag		( bagToList )
 import Outputable
+import PrelNames	( mkUnboundName, isUnboundName )
 \end{code}
 
 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
@@ -165,26 +165,25 @@ rnTopBinds (MonoBind bind sigs _) 	  = rnTopMonoBinds bind sigs
   -- The parser doesn't produce other forms
 
 
-rnTopMonoBinds EmptyMonoBinds sigs 
-  = returnRn (EmptyBinds, emptyFVs)
-
 rnTopMonoBinds mbinds sigs
  =  mapRn lookupBndrRn binder_rdr_names		`thenRn` \ binder_names ->
     let
 	bndr_name_set = mkNameSet binder_names
     in
-    renameSigs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) ->
+    renameSigs (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 | opt_WarnMissingSigs = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars)
-			| otherwise	      = []
+	un_sigd_binders | warnMissing = nameSetToList (delListFromNameSet 
+                                                          bndr_name_set type_sig_vars)
+			| otherwise   = []
     in
     mapRn_ (addWarnRn.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 = map fst (bagToList (collectMonoBinders mbinds))
+    binder_rdr_names = collectMonoBinders mbinds
 \end{code}
 
 %************************************************************************
@@ -218,8 +217,6 @@ rnMonoBinds :: RdrNameMonoBinds
 	    -> (RenamedHsBinds -> RnMS (result, FreeVars))
 	    -> RnMS (result, FreeVars)
 
-rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
-
 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
@@ -252,7 +249,7 @@ rnMonoBinds mbinds sigs	thing_inside -- Non-empty monobinds
     warnUnusedLocalBinds unused_binders	`thenRn_`
     returnRn (result, delListFromNameSet all_fvs new_mbinders)
   where
-    mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
+    mbinders_w_srclocs = collectLocatedMonoBinders mbinds
 \end{code}
 
 
@@ -284,7 +281,7 @@ rn_mono_binds siglist mbinds
     let 
         edges	    = mkEdges (mbinds_info `zip` [(0::Int)..])
 	scc_result  = stronglyConnComp edges
-	final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
+	final_binds = foldr (ThenBinds . reconstructCycle) EmptyBinds scc_result
 
 	 -- Deal with bound and free-var calculation
 	rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info]
@@ -370,27 +367,40 @@ in many ways the @op@ in an instance decl is just like an occurrence, not
 a binder.
 
 \begin{code}
-rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars)
+rnMethodBinds :: [Name]			-- Names for generic type variables
+	      -> RdrNameMonoBinds
+	      -> RnMS (RenamedMonoBinds, FreeVars)
 
-rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
+rnMethodBinds gen_tyvars EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
 
-rnMethodBinds (AndMonoBinds mb1 mb2)
-  = rnMethodBinds mb1	`thenRn` \ (mb1', fvs1) ->
-    rnMethodBinds mb2	`thenRn` \ (mb2', fvs2) ->
+rnMethodBinds gen_tyvars (AndMonoBinds mb1 mb2)
+  = rnMethodBinds gen_tyvars mb1	`thenRn` \ (mb1', fvs1) ->
+    rnMethodBinds gen_tyvars mb2	`thenRn` \ (mb2', fvs2) ->
     returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)
 
-rnMethodBinds (FunMonoBind name inf matches locn)
+rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn)
   = pushSrcLocRn locn				   	$
 
     lookupGlobalOccRn name				`thenRn` \ sel_name -> 
 	-- We use the selector name as the binder
 
-    mapFvRn rnMatch matches				`thenRn` \ (new_matches, fvs) ->
+    mapFvRn rn_match matches				`thenRn` \ (new_matches, fvs) ->
     mapRn_ (checkPrecMatch inf sel_name) new_matches	`thenRn_`
     returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name)
+  where
+	-- Gruesome; bring into scope the correct members of the generic type variables
+	-- See comments in RnSource.rnDecl(ClassDecl)
+    rn_match match@(Match _ (TypePatIn ty : _) _ _)
+	= extendTyVarEnvFVRn gen_tvs (rnMatch match)
+	where
+	  tvs     = map rdrNameOcc (extractHsTyRdrNames ty)
+	  gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] 
+
+    rn_match match = rnMatch match
+	
 
 -- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
+rnMethodBinds gen_tyvars mbind@(PatMonoBind other_pat _ locn)
   = pushSrcLocRn locn	$
     failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)
 \end{code}
@@ -502,7 +512,7 @@ renameSigs ok_sig sigs
 -- Doesn't seem worth much trouble to sort this.
 
 renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars)
-
+-- ClassOpSig is renamed elsewhere.
 renameSig (Sig v ty src_loc)
   = pushSrcLocRn src_loc $
     lookupSigOccRn v				`thenRn` \ new_v ->