Commit 15486d73 authored by bjorn@bringert.net's avatar bjorn@bringert.net

Renamer part of stand-alone deriving extension.

parent cb8044eb
......@@ -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
......
......@@ -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
......
......@@ -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}
%*********************************************************
%* *
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment