X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=bd9c549bb08be5f0da00cdbb42c96901c10af130;hb=ba40c9828ce8ce18e834af4f832792365d82e319;hp=9150440aeee654159d32276a54069cba77c03a52;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 9150440..bd9c549 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -20,7 +20,7 @@ import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts,
 import RdrHsSyn		( extractGenericPatTyVars, extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes		( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
-import RnBinds		( rnTopBinds, rnMethodBinds, renameSigs )
+import RnBinds		( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
 import RnEnv		( lookupLocalDataTcNames,
 			  lookupLocatedTopBndrRn, lookupLocatedOccRn,
 			  lookupOccRn, newLocalsRn, 
@@ -38,7 +38,7 @@ import NameSet
 import NameEnv
 import OccName		( occEnvElts )
 import Outputable
-import SrcLoc		( Located(..), unLoc, getLoc, noLoc )
+import SrcLoc		( Located(..), unLoc, noLoc )
 import DynFlags	( DynFlag(..) )
 import Maybes		( seqMaybe )
 import Maybe            ( isNothing )
@@ -80,8 +80,8 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
 
 		-- Deal with top-level fixity decls 
 		-- (returns the total new fixity env)
-	fix_env <- rnSrcFixityDeclsEnv fix_decls ;
         rn_fix_decls <- rnSrcFixityDecls fix_decls ;
+	fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ;
 	updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
 		  $ do {
 
@@ -157,11 +157,16 @@ rnSrcFixityDecls fix_decls
 
 rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
 rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
-    = do names <- lookupLocalDataTcNames rdr_name
+    = setSrcSpan nameLoc $
+        -- GHC extension: look up both the tycon and data con 
+	-- for con-like things
+	-- If neither are in scope, report an error; otherwise
+	-- add both to the fixity env
+      do names <- lookupLocalDataTcNames rdr_name
          return [ L loc (FixitySig (L nameLoc name) fixity)
                       | name <- names ]
 
-rnSrcFixityDeclsEnv :: [LFixitySig RdrName] -> RnM FixityEnv
+rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv
 rnSrcFixityDeclsEnv fix_decls
   = getGblEnv					`thenM` \ gbl_env ->
     foldlM rnFixityDeclEnv (tcg_fix_env gbl_env) 
@@ -169,24 +174,15 @@ rnSrcFixityDeclsEnv fix_decls
     traceRn (text "fixity env" <+> pprFixEnv fix_env)	`thenM_`
     returnM fix_env
 
-rnFixityDeclEnv :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
-rnFixityDeclEnv fix_env (L loc (FixitySig rdr_name fixity))
-  = setSrcSpan loc $
-        -- GHC extension: look up both the tycon and data con 
-	-- for con-like things
-	-- If neither are in scope, report an error; otherwise
-	-- add both to the fixity env
-     addLocM lookupLocalDataTcNames rdr_name	`thenM` \ names ->
-     foldlM add fix_env names
-  where
-    add fix_env name
-      = case lookupNameEnv fix_env name of
-          Just (FixItem _ _ loc') 
-		  -> addLocErr rdr_name (dupFixityDecl loc')	`thenM_`
-    		     returnM fix_env
-    	  Nothing -> returnM (extendNameEnv fix_env name fix_item)
-      where
-	fix_item = FixItem (nameOccName name) fixity (getLoc rdr_name)
+rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv
+rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity))
+  = case lookupNameEnv fix_env name of
+      Just (FixItem _ _ loc') 
+	  -> do addLocErr (L nameLoc name) (dupFixityDecl loc')
+    	        return fix_env
+      Nothing
+          -> return (extendNameEnv fix_env name fix_item)
+    where fix_item = FixItem (nameOccName name) fixity nameLoc
 
 pprFixEnv :: FixityEnv -> SDoc
 pprFixEnv env 
@@ -290,7 +286,8 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
     extendTyVarEnvForMethodBinds inst_tyvars (		
 	-- (Slightly strangely) the forall-d tyvars scope over
 	-- the method bindings too
-	rnMethodBinds cls [] mbinds
+	rnMethodBinds cls (\n->[]) 	-- No scoped tyvars
+		      [] mbinds
     )						`thenM` \ (mbinds', meth_fvs) ->
 	-- Rename the prags and signatures.
 	-- Note that the type variables are not in scope here,
@@ -542,7 +539,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
    	 in
    	 checkDupNames meth_doc meth_rdr_names_w_locs	`thenM_`
    	 newLocalsRn gen_rdr_tyvars_w_locs	`thenM` \ gen_tyvars ->
-   	 rnMethodBinds (unLoc cname') gen_tyvars mbinds
+   	 rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
     ) `thenM` \ (mbinds', meth_fvs) ->
 
     returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',