\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,
+ bindLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
checkDupOrQualNames, checkDupNames, mapFvRn,
lookupTopSrcBndr_maybe, lookupTopSrcBndr,
- dataTcOccs, unknownNameErr,
- plusGlobalRdrEnv
+ dataTcOccs, newIPName, unknownNameErr
)
import TcRnMonad
-import BasicTypes ( FixitySig(..) )
+import BasicTypes ( FixitySig(..), TopLevelFlag(..) )
import HscTypes ( ExternalPackageState(..), FixityEnv,
Deprecations(..), plusDeprecs )
import Module ( moduleEnvElts )
import NameSet
import NameEnv
import ErrUtils ( dumpIfSet )
-import PrelNames ( newStablePtrName, bindIOName, returnIOName )
+import PrelNames ( newStablePtrName, bindIOName, returnIOName
+ -- dotnet interop
+ , objectTyConName,
+ , unmarshalObjectName, marshalObjectName
+ , unmarshalStringName, marshalStringName
+ , checkDotnetResName
+ )
import List ( partition )
import Bag ( bagToList )
import Outputable
\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, DefUses)
+
+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 {
- failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-
- -- Rename remaining declarations
- (rn_src_decls, src_fvs) <- rn_src_decls decls ;
+ -- Rename other declarations
+ (rn_val_decls, bind_dus) <- rnTopMonoBinds binds sigs ;
+
+ -- You might think that we could build proper def/use information
+ -- for type and class declarations, but they can be involved
+ -- in mutual recursion across modules, and we only do the SCC
+ -- analysis for them in the type checker.
+ -- So we content ourselves with gathering uses only; that
+ -- means we'll only report a declaration as unused if it isn't
+ -- mentioned at all. Ah well.
+ (rn_tycl_decls, src_fvs1) <- mapFvRn rnSrcTyClDecl tycl_decls ;
+ (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ;
+ (rn_rule_decls, src_fvs3) <- mapFvRn rnHsRuleDecl rule_decls ;
+ (rn_foreign_decls, src_fvs4) <- mapFvRn rnHsForeignDecl foreign_decls ;
+ (rn_default_decls, src_fvs5) <- mapFvRn rnDefaultDecl default_decls ;
+ (rn_core_decls, src_fvs6) <- 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 } ;
+
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
+ src_fvs4, src_fvs5, src_fvs6] ;
+ src_dus = bind_dus `plusDU` usesOnly other_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_dus)
+ }}}
\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')
+ returnM (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)
-
-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)
of the loop too, and it must be defined in this module.
\begin{code}
-rnTopBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
-rnTopBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
-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, DefUses)
+-- This version assumes that the binders are already in scope
+-- It's used only in 'mdo'
+rnBinds EmptyBinds = returnM (EmptyBinds, emptyDUs)
+rnBinds (MonoBind bind sigs _) = rnMonoBinds NotTopLevel bind sigs
+rnBinds b@(IPBinds bind _) = addErr (badIpBinds b) `thenM_`
+ returnM (EmptyBinds, emptyDUs)
+
+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}
returnM (ForeignImport name' ty' spec isDeprec src_loc,
fvs `plusFV` extras spec)
where
- extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
- bindIOName, returnIOName]
+ extras (CImport _ _ _ _ CWrapper)
+ = mkFVs [ newStablePtrName
+ , bindIOName
+ , returnIOName
+ ]
+ extras (DNImport _)
+ = mkFVs [ bindIOName
+ , objectTyConName
+ , unmarshalObjectName
+ , marshalObjectName
+ , marshalStringName
+ , unmarshalStringName
+ , checkDotnetResName
+ ]
extras _ = emptyFVs
rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
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}
%*********************************************************
returnM (IfaceRuleOut fn' rule)
rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
- = addSrcLoc src_loc $
- bindPatSigTyVars (collectRuleBndrSigTys vars) $
+ = addSrcLoc src_loc $
+ bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $
- bindLocalsFVRn doc (map get_var vars) $ \ ids ->
+ bindLocalsFV doc (map get_var vars) $ \ ids ->
mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) ->
rnExpr lhs `thenM` \ (lhs', fv_lhs) ->
in
checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_`
mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' ->
- 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 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
rnNote (UfSCC cc) = returnM (UfSCC cc)
rnNote UfInlineCall = returnM UfInlineCall
rnNote UfInlineMe = returnM UfInlineMe
-
+rnNote (UfCoreNote s) = returnM (UfCoreNote s)
rnUfCon UfDefault
= returnM UfDefault
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