From: bjorn@bringert.net <unknown>
Date: Sun, 17 Sep 2006 21:54:20 +0000 (+0000)
Subject: Renamer part of stand-alone deriving extension.
X-Git-Tag: 2006-10-05~15
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=15486d73d84483243f40fa245e63e7e88d5ed0ad

Renamer part of stand-alone deriving extension.
---

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 2310551..f6beb23 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -96,6 +96,7 @@ data HsGroup id
 	hs_valds  :: HsValBinds id,
 	hs_tyclds :: [LTyClDecl id],
 	hs_instds :: [LInstDecl id],
+        hs_derivds :: [LDerivDecl id],
 
 	hs_fixds  :: [LFixitySig id],
 		-- Snaffled out of both top-level fixity signatures,
@@ -111,7 +112,7 @@ emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
 emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 
-emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [],
+emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
 		       hs_fixds = [], hs_defds = [], hs_fords = [], 
 		       hs_depds = [], hs_ruleds = [],
 		       hs_valds = error "emptyGroup hs_valds: Can't happen" }
@@ -122,6 +123,7 @@ appendGroups
 	hs_valds  = val_groups1,
 	hs_tyclds = tyclds1, 
 	hs_instds = instds1,
+        hs_derivds = derivds1,
 	hs_fixds  = fixds1, 
 	hs_defds  = defds1,
 	hs_fords  = fords1, 
@@ -131,6 +133,7 @@ appendGroups
 	hs_valds  = val_groups2,
 	hs_tyclds = tyclds2, 
 	hs_instds = instds2,
+        hs_derivds = derivds2,
 	hs_fixds  = fixds2, 
 	hs_defds  = defds2,
 	hs_fords  = fords2, 
@@ -141,6 +144,7 @@ appendGroups
 	hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
 	hs_tyclds = tyclds1 ++ tyclds2, 
 	hs_instds = instds1 ++ instds2,
+        hs_derivds = derivds1 ++ derivds2,
 	hs_fixds  = fixds1 ++ fixds2, 
 	hs_defds  = defds1 ++ defds2,
 	hs_fords  = fords1 ++ fords2, 
@@ -165,6 +169,7 @@ instance OutputableBndr name => Outputable (HsGroup name) where
     ppr (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,
@@ -174,6 +179,7 @@ instance OutputableBndr name => Outputable (HsGroup name) where
 		ppr_ds deprec_decls, ppr_ds rule_decls,
 		ppr val_decls,
 		ppr_ds tycl_decls, ppr_ds inst_decls,
+                ppr_ds deriv_decls,
 		ppr_ds foreign_decls]
 	where
 	  ppr_ds [] = empty
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 7373ec0..87741b9 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -312,6 +312,8 @@ add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
 -- The rest are routine
 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
   = addl (gp { hs_instds = L l d : ts }) ds
+add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
+  = addl (gp { hs_derivds = L l d : ts }) ds
 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
   = addl (gp { hs_defds = L l d : ts }) ds
 add gp@(HsGroup {hs_fords  = ts})  l (ForD d) ds
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 6053098..6445b91 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -68,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,
@@ -102,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)
@@ -113,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
@@ -365,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 cls ty)
+  = do cls' <- lookupLocatedOccRn cls
+       ty' <- rnLHsType (text "a deriving decl") ty
+       let fvs = extractHsTyNames ty'
+       return (DerivDecl cls' ty', fvs)
+\end{code}
 
 %*********************************************************
 %*							*