X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=9a3e80520e74e22f3f1ec085b2a51431a0f8fa07;hb=3ad8f84f6a75f240383e62a14472d14eb372dcd1;hp=606139b116b62824e4ed3a05f2fb4532d9d252cb;hpb=202ac08f3e2afde0620e889cc81a95b2fd0ad9e1;p=ghc-hetmet.git

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 606139b..9a3e805 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -15,9 +15,8 @@ module RnSource (
 import {-# SOURCE #-} RnExpr( rnLExpr )
 
 import HsSyn
-import RdrName		( RdrName, isRdrDataCon, isRdrTyVar, rdrNameOcc, 
-			  elemLocalRdrEnv, globalRdrEnvElts, GlobalRdrElt(..),
-			  isLocalGRE )
+import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, 
+			  globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE )
 import RdrHsSyn		( extractGenericPatTyVars, extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes		( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
@@ -69,6 +68,7 @@ rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
 rnSrcDecls (HsGroup { hs_valds  = val_decls,
 		      hs_tyclds = tycl_decls,
 		      hs_instds = inst_decls,
+                      hs_derivds = deriv_decls,
 		      hs_fixds  = fix_decls,
 		      hs_depds  = deprec_decls,
 		      hs_fords  = foreign_decls,
@@ -103,6 +103,8 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
 	   <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
 	(rn_inst_decls,    src_fvs2)
 	   <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
+	(rn_deriv_decls,    src_fvs_deriv)
+	   <- mapFvRn (wrapLocFstM rnSrcDerivDecl) deriv_decls ;
 	(rn_rule_decls,    src_fvs3)
 	   <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
 	(rn_foreign_decls, src_fvs4)
@@ -114,13 +116,14 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
 	   rn_group = HsGroup { hs_valds  = rn_val_decls,
 			    	hs_tyclds = rn_tycl_decls,
 			    	hs_instds = rn_inst_decls,
+                                hs_derivds = rn_deriv_decls,
 			    	hs_fixds  = rn_fix_decls,
 			    	hs_depds  = [],
 			    	hs_fords  = rn_foreign_decls,
 			    	hs_defds  = rn_default_decls,
 			    	hs_ruleds = rn_rule_decls } ;
 
-	   other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, 
+	   other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3, 
 				src_fvs4, src_fvs5] ;
 	   src_dus = bind_dus `plusDU` usesOnly other_fvs 
 		-- Note: src_dus will contain *uses* for locally-defined types
@@ -366,6 +369,20 @@ extendTyVarEnvForMethodBinds tyvars thing_inside
 	thing_inside
 \end{code}
 
+%*********************************************************
+%*							*
+\subsection{Stand-alone deriving declarations}
+%*							*
+%*********************************************************
+
+\begin{code}
+rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
+rnSrcDerivDecl (DerivDecl ty n)
+  = do ty' <- rnLHsType (text "a deriving decl") ty
+       n'  <- lookupLocatedOccRn n
+       let fvs = extractHsTyNames ty' `addOneFV` unLoc n'
+       return (DerivDecl ty' n', fvs)
+\end{code}
 
 %*********************************************************
 %*							*
@@ -506,7 +523,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
   = ASSERT( isNothing sig )	-- In normal H98 form, kind signature on the 
 				-- data type is syntactically illegal
     bindTyVarsRn data_doc tyvars		$ \ tyvars' ->
-    do	{ tycon' <- lookupLocatedTopBndrRn tycon
+    do	{ tycon' <- if isIdxTyDecl tydecl
+		    then lookupLocatedOccRn     tycon -- may be imported family
+		    else lookupLocatedTopBndrRn tycon
 	; context' <- rnContext data_doc context
 	; typats' <- rnTyPats data_doc typatsMaybe
 	; (derivs', deriv_fvs) <- rn_derivs derivs
@@ -519,11 +538,17 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 		   delFVs (map hsLTyVarName tyvars')	$
 	     	   extractHsCtxtTyNames context'	`plusFV`
 	     	   plusFVs (map conDeclFVs condecls')   `plusFV`
-	     	   deriv_fvs) }
+	     	   deriv_fvs				`plusFV`
+		   (if isIdxTyDecl tydecl
+		   then unitFV (unLoc tycon')	-- type instance => use
+		   else emptyFVs)) 
+        }
 
   | otherwise	          -- GADT
   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
-    do	{ tycon' <- lookupLocatedTopBndrRn tycon
+    do	{ tycon' <- if isIdxTyDecl tydecl
+		    then lookupLocatedOccRn     tycon -- may be imported family
+		    else lookupLocatedTopBndrRn tycon
 	; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
     	; tyvars' <- bindTyVarsRn data_doc tyvars 
 				  (\ tyvars' -> return tyvars')
@@ -537,8 +562,12 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 			   tcdLName = tycon', tcdTyVars = tyvars', 
 			   tcdTyPats = Nothing, tcdKindSig = sig,
 			   tcdCons = condecls', tcdDerivs = derivs'}, 
-	     	   plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
-
+	     	   plusFVs (map conDeclFVs condecls') `plusFV` 
+		   deriv_fvs			      `plusFV`
+		   (if isIdxTyDecl tydecl
+		   then unitFV (unLoc tycon')	-- type instance => use
+		   else emptyFVs))
+        }
   where
     is_vanilla = case condecls of	-- Yuk
 		     [] 		   -> True
@@ -561,15 +590,22 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 rnTyClDecl (tydecl@TyFunction {}) =
   rnTySig tydecl bindTyVarsRn
 
-rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars,
-		       tcdTyPats = typatsMaybe, tcdSynRhs = ty})
+rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
+			      tcdTyPats = typatsMaybe, tcdSynRhs = ty})
   = bindTyVarsRn syn_doc tyvars		        $ \ tyvars' ->
-    do { name' <- lookupLocatedTopBndrRn name
+    do { name' <- if isIdxTyDecl tydecl
+		  then lookupLocatedOccRn     name -- may be imported family
+		  else lookupLocatedTopBndrRn name
        ; typats' <- rnTyPats syn_doc typatsMaybe
        ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
        ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', 
 			     tcdTyPats = typats', tcdSynRhs = ty'},
-	          delFVs (map hsLTyVarName tyvars') fvs) }
+	          delFVs (map hsLTyVarName tyvars') $
+		  fvs			      `plusFV`
+		   (if isIdxTyDecl tydecl
+		   then unitFV (unLoc name')	-- type instance => use
+		   else emptyFVs))
+       }
   where
     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 
@@ -756,7 +792,8 @@ rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon,
 			    tcdTyPats = Nothing, tcdKindSig = sig, 
 			    tcdCons = [], tcdDerivs = Nothing}, 
 		    delFVs (map hsLTyVarName tyvars') $
-	     	    extractHsCtxtTyNames context') } }
+	     	    extractHsCtxtTyNames context') 
+         } }
       where
 
 rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, 
@@ -767,7 +804,8 @@ rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
 	 ; tycon' <- lookupLocatedTopBndrRn tycon
 	 ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
 			        tcdIso = tcdIso tydecl, tcdKind = sig}, 
-		    emptyFVs) } }
+		    emptyFVs) 
+         } }
 
 ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
 needOneIdx = text "Kind signature requires at least one type index"