\begin{code}
module RnSource (
- rnSrcDecls, rnExtCoreDecls, checkModDeprec,
+ rnSrcDecls, checkModDeprec,
rnTyClDecl, rnIfaceRuleDecl, rnInstDecl,
- rnBinds, rnStats,
+ rnBinds, rnBindsAndThen, rnStats,
) where
#include "HsVersions.h"
-import RnExpr
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
-import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, RdrNameHsDecl,
+import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl,
RdrNameDeprecation, RdrNameFixitySig,
RdrNameHsBinds,
extractGenericPatTyVars
)
import RnHsSyn
import HsCore
-
-import RnNames ( importsFromLocalDecls )
+import RnExpr ( rnExpr )
import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds,
- renameSigs, renameSigsFVs )
+ rnMonoBindsAndThen, renameSigs, checkSigs )
import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr,
newLocalsRn, lookupGlobalOccRn,
bindLocalsFVRn, bindPatSigTyVars,
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
checkDupOrQualNames, checkDupNames, mapFvRn,
lookupTopSrcBndr_maybe, lookupTopSrcBndr,
- dataTcOccs, unknownNameErr,
- plusGlobalRdrEnv
+ dataTcOccs, newIPName, unknownNameErr
)
import TcRnMonad
\begin{code}
-rnSrcDecls :: [RdrNameHsDecl] -> RnM (TcGblEnv, [RenamedHsDecl], FreeVars)
-
-rnSrcDecls decls
- = do { (rdr_env, imports) <- importsFromLocalDecls decls ;
- updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
- tcg_rdr_env gbl,
- tcg_imports = imports `plusImportAvails`
- tcg_imports gbl })
- $ do {
-
- -- Deal with deprecations (returns only the extra deprecations)
- deprecs <- rnSrcDeprecDecls [d | DeprecD d <- decls] ;
+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, FreeVars)
+
+rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _,
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_fixds = fix_decls,
+ hs_depds = deprec_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_decls,
+ hs_ruleds = rule_decls,
+ hs_coreds = core_decls })
+
+ = do { -- Deal with deprecations (returns only the extra deprecations)
+ deprecs <- rnSrcDeprecDecls deprec_decls ;
updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
$ do {
-- Deal with top-level fixity decls
-- (returns the total new fixity env)
- fix_env <- rnSrcFixityDecls decls ;
+ fix_env <- rnSrcFixityDecls fix_decls ;
updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
$ do {
- -- Rename remaining declarations
- (rn_src_decls, src_fvs) <- rn_src_decls decls ;
-
+ -- Rename other declarations
+ (rn_val_decls, src_fvs1) <- rnTopMonoBinds binds sigs ;
+ (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ;
+ (rn_tycl_decls, src_fvs3) <- mapFvRn rnSrcTyClDecl tycl_decls ;
+ (rn_rule_decls, src_fvs4) <- mapFvRn rnHsRuleDecl rule_decls ;
+ (rn_foreign_decls, src_fvs5) <- mapFvRn rnHsForeignDecl foreign_decls ;
+ (rn_default_decls, src_fvs6) <- mapFvRn rnDefaultDecl default_decls ;
+ (rn_core_decls, src_fvs7) <- mapFvRn rnCoreDecl core_decls ;
+
+ let {
+ rn_group = HsGroup { hs_valds = rn_val_decls,
+ hs_tyclds = rn_tycl_decls,
+ hs_instds = rn_inst_decls,
+ hs_fixds = [],
+ hs_depds = [],
+ hs_fords = rn_foreign_decls,
+ hs_defds = rn_default_decls,
+ hs_ruleds = rn_rule_decls,
+ hs_coreds = rn_core_decls } ;
+ src_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+ src_fvs5, src_fvs6, src_fvs7] } ;
+
+ traceRn (text "rnSrcDecls" <+> ppr (nameSetToList src_fvs)) ;
tcg_env <- getGblEnv ;
- return (tcg_env, rn_src_decls, src_fvs)
- }}}}
-
-rnExtCoreDecls :: [RdrNameHsDecl] -> RnM ([RenamedHsDecl], FreeVars)
-rnExtCoreDecls decls = rn_src_decls decls
-
-rn_src_decls decls -- Declarartions get reversed, but no matter
- = go emptyFVs [] decls
- where
- -- Fixity and deprecations have been dealt with already; ignore them
- go fvs ds' [] = returnM (ds', fvs)
- go fvs ds' (FixD _:ds) = go fvs ds' ds
- go fvs ds' (DeprecD _:ds) = go fvs ds' ds
- go fvs ds' (d:ds) = rnSrcDecl d `thenM` \(d', fvs') ->
- go (fvs `plusFV` fvs') (d':ds') ds
+ return (tcg_env, rn_group, src_fvs)
+ }}}
\end{code}
%*********************************************************
\begin{code}
-rnSrcFixityDecls :: [RdrNameHsDecl] -> TcRn m FixityEnv
-rnSrcFixityDecls decls
+rnSrcFixityDecls :: [RdrNameFixitySig] -> TcRn m FixityEnv
+rnSrcFixityDecls fix_decls
= getGblEnv `thenM` \ gbl_env ->
foldlM rnFixityDecl (tcg_fix_env gbl_env)
fix_decls `thenM` \ fix_env ->
traceRn (text "fixity env" <+> ppr fix_env) `thenM_`
returnM fix_env
- where
- fix_decls = foldr get_fix_sigs [] decls
-
- -- Get fixities from top level decls, and from class decl sigs too
- get_fix_sigs (FixD fix) acc = fix:acc
- get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc
- = [sig | FixSig sig <- sigs] ++ acc
- get_fix_sigs other_decl acc = acc
rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv
rnFixityDecl fix_env (FixitySig rdr_name fixity loc)
%*********************************************************
\begin{code}
-rnSrcDecl :: RdrNameHsDecl -> RnM (RenamedHsDecl, FreeVars)
-
-rnSrcDecl (ValD binds) = rnTopBinds binds `thenM` \ (new_binds, fvs) ->
- returnM (ValD new_binds, fvs)
-
-rnSrcDecl (TyClD tycl_decl)
+rnSrcTyClDecl tycl_decl
= rnTyClDecl tycl_decl `thenM` \ new_decl ->
finishSourceTyClDecl tycl_decl new_decl `thenM` \ (new_decl', fvs) ->
- returnM (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
+ returnM (new_decl', fvs `plusFV` tyClDeclFVs new_decl')
-rnSrcDecl (InstD inst)
+rnSrcInstDecl inst
= rnInstDecl inst `thenM` \ new_inst ->
finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) ->
- returnM (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
-
-rnSrcDecl (RuleD rule)
- = rnHsRuleDecl rule `thenM` \ (new_rule, fvs) ->
- returnM (RuleD new_rule, fvs)
-
-rnSrcDecl (ForD ford)
- = rnHsForeignDecl ford `thenM` \ (new_ford, fvs) ->
- returnM (ForD new_ford, fvs)
+ returnM (new_inst', fvs `plusFV` instDeclFVs new_inst')
-rnSrcDecl (DefD (DefaultDecl tys src_loc))
+rnDefaultDecl (DefaultDecl tys src_loc)
= addSrcLoc src_loc $
mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
- returnM (DefD (DefaultDecl tys' src_loc), fvs)
+ returnM (DefaultDecl tys' src_loc, fvs)
where
doc_str = text "In a `default' declaration"
-rnSrcDecl (CoreD (CoreDecl name ty rhs loc))
+rnCoreDecl (CoreDecl name ty rhs loc)
= addSrcLoc loc $
lookupTopBndrRn name `thenM` \ name' ->
rnHsTypeFVs doc_str ty `thenM` \ (ty', ty_fvs) ->
rnCoreExpr rhs `thenM` \ rhs' ->
- returnM (CoreD (CoreDecl name' ty' rhs' loc),
+ returnM (CoreDecl name' ty' rhs' loc,
ty_fvs `plusFV` ufExprFVs rhs')
where
doc_str = text "In the Core declaration for" <+> quotes (ppr name)
rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
-- The parser doesn't produce other forms
-rnBinds :: RdrNameHsBinds
- -> (RenamedHsBinds -> RnM (result, FreeVars))
- -> RnM (result, FreeVars)
-rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
-rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
- -- the parser doesn't produce other forms
+rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
+-- This version assumes that the binders are already in scope
+-- It's used only in 'mdo'
+rnBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
+rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs
+rnBinds b@(IPBinds bind _) = addErr (badIpBinds b) `thenM_`
+ returnM (EmptyBinds, emptyFVs)
+
+rnBindsAndThen :: RdrNameHsBinds
+ -> (RenamedHsBinds -> RnM (result, FreeVars))
+ -> RnM (result, FreeVars)
+-- This version (a) assumes that the binding vars are not already in scope
+-- (b) removes the binders from the free vars of the thing inside
+-- The parser doesn't produce ThenBinds
+rnBindsAndThen EmptyBinds thing_inside = thing_inside EmptyBinds
+rnBindsAndThen (MonoBind bind sigs _) thing_inside = rnMonoBindsAndThen bind sigs thing_inside
+rnBindsAndThen (IPBinds binds is_with) thing_inside
+ = warnIf is_with withWarning `thenM_`
+ rnIPBinds binds `thenM` \ (binds',fv_binds) ->
+ thing_inside (IPBinds binds' is_with) `thenM` \ (thing, fvs_thing) ->
+ returnM (thing, fvs_thing `plusFV` fv_binds)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
+%* *
+%************************************************************************
+
+\begin{code}
+rnIPBinds [] = returnM ([], emptyFVs)
+rnIPBinds ((n, expr) : binds)
+ = newIPName n `thenM` \ name ->
+ rnExpr expr `thenM` \ (expr',fvExpr) ->
+ rnIPBinds binds `thenM` \ (binds',fvBinds) ->
+ returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
+
\end{code}
lookupOccRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
returnM (ForeignExport name' ty' spec isDeprec src_loc,
- mkFVs [bindIOName, returnIOName] `plusFV` fvs)
+ mkFVs [name', bindIOName, returnIOName] `plusFV` fvs )
+ -- NB: a foreign export is an *occurrence site* for name, so
+ -- we add it to the free-variable list. It might, for example,
+ -- be imported from another module
fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
\end{code}
rnMethodBinds cls [] mbinds
) `thenM` \ (mbinds', meth_fvs) ->
let
- binders = collectMonoBinders mbinds'
- binder_set = mkNameSet binders
+ binders = collectMonoBinders mbinds'
in
-- Rename the prags and signatures.
-- Note that the type variables are not in scope here,
-- works OK.
--
-- But the (unqualified) method names are in scope
- bindLocalNames binders (
- renameSigsFVs (okInstDclSig binder_set) uprags
- ) `thenM` \ (uprags', prag_fvs) ->
+ bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' ->
+ checkSigs okInstDclSig (mkNameSet binders) uprags' `thenM_`
returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
- meth_fvs `plusFV` prag_fvs)
+ meth_fvs `plusFV` hsSigsFVs uprags')
\end{code}
%*********************************************************
let
binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
in
- renameSigs (okClsDclSig binders) non_op_sigs `thenM` \ non_ops' ->
-
+ renameSigs non_op_sigs `thenM` \ non_ops' ->
+ checkSigs okClsDclSig binders non_ops' `thenM_`
-- Typechecker is responsible for checking that we only
-- give default-method bindings for things in this class.
-- The renamer *could* check this for class decls, but can't
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
+
+withWarning
+ = sep [quotes (ptext SLIT("with")),
+ ptext SLIT("is deprecated, use"),
+ quotes (ptext SLIT("let")),
+ ptext SLIT("instead")]
+
+badIpBinds binds
+ = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4
+ (ppr binds)
\end{code}
+
projects / ghc-hetmet.git / blobdiff