X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=f74c71244e1309bda2020269a6685577dcf6042a;hb=a7d8f43718b167689c0a4a4c23b33a325e0239f1;hp=a56b09988f7cc0f234809230a878e48cc286ce46;hpb=9ed152764fdc44fbc077751b3442fc7f59306596;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index a56b099..f74c712 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -5,42 +5,39 @@ \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 ) @@ -50,7 +47,13 @@ import Name ( Name ) 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 @@ -78,48 +81,65 @@ Checks the @(..)@ etc constraints in the export list. \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} @@ -130,21 +150,13 @@ rn_src_decls decls -- Declarartions get reversed, but no matter %********************************************************* \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) @@ -213,43 +225,30 @@ badDeprec d %********************************************************* \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) @@ -266,17 +265,44 @@ is just one hi-boot file (for RnSource). rnSrcDecls is part 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} @@ -294,8 +320,20 @@ rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc) 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) @@ -353,8 +391,7 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) 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, @@ -363,12 +400,11 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) -- 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} %********************************************************* @@ -391,10 +427,10 @@ rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way 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) -> @@ -546,11 +582,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, 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 @@ -856,7 +889,7 @@ rnNote (UfCoerce ty) rnNote (UfSCC cc) = returnM (UfSCC cc) rnNote UfInlineCall = returnM UfInlineCall rnNote UfInlineMe = returnM UfInlineMe - +rnNote (UfCoreNote s) = returnM (UfCoreNote s) rnUfCon UfDefault = returnM UfDefault @@ -954,4 +987,15 @@ badRuleVar name var 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} +