#include "HsVersions.h"
import HsSyn
-import HsPragmas ( DataPragmas(..) )
import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation )
-import RnHsSyn ( RenamedHsModule, RenamedHsDecl,
+import RnHsSyn ( RenamedHsDecl,
extractHsTyNames, extractHsCtxtTyNames
)
import RnIfaces ( getImportedInstDecls, importDecl, mkImportInfo,
getInterfaceExports,
getImportedRules, getSlurped, removeContext,
- ImportDeclResult(..), findAndReadIface
+ ImportDeclResult(..)
)
import RnEnv ( availName, availsToNameSet,
emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
- lookupOrigNames, unknownNameErr,
+ lookupOrigNames, lookupGlobalRn,
FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
)
import Module ( Module, ModuleName, WhereFrom(..),
- moduleNameUserString, moduleName, mkModuleInThisPackage,
+ moduleNameUserString, moduleName,
lookupModuleEnv
)
import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
nameOccName, nameUnique, nameModule,
- isUserExportedName, toRdrName,
+ isUserExportedName,
mkNameEnv, nameEnvElts, extendNameEnv
)
-import OccName ( occNameFlavour, isValOcc )
+import OccName ( occNameFlavour )
import Id ( idType )
import TyCon ( isSynTyCon, getSynTyConDefn )
import NameSet
)
import PrelInfo ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv )
import Type ( namesOfType, funTyCon )
-import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit )
-import BasicTypes ( Version, initialVersion )
+import ErrUtils ( printErrorsAndWarnings, dumpIfSet )
import Bag ( isEmptyBag, bagToList )
import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM,
addToFM_C, elemFM, addToFM
)
-import UniqSupply ( UniqSupply )
import UniqFM ( lookupUFM )
-import SrcLoc ( noSrcLoc )
-import Maybes ( maybeToBool, expectJust )
+import Maybes ( maybeToBool, catMaybes )
import Outputable
import IO ( openFile, IOMode(..) )
import HscTypes ( Finder, PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
ModIface(..), TyThing(..),
GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo,
- Provenance(..), pprNameProvenance, ImportReason(..),
- lookupDeprec
+ Provenance(..), ImportReason(..), initialVersionInfo,
+ Deprecations(..), lookupDeprec
)
import List ( partition, nub )
\end{code}
\end{code}
\begin{code}
-rename :: Module -> RdrNameHsModule -> RnMG (Maybe ModIface, IO ())
+rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl]), IO ())
rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc)
= -- FIND THE GLOBAL NAME ENVIRONMENT
getGlobalNames this_mod `thenRn` \ maybe_stuff ->
case maybe_stuff of {
Nothing -> -- Everything is up to date; no need to recompile further
rnDump [] [] `thenRn` \ dump_action ->
- returnRn (Nothing, dump_action) ;
+ returnRn (Nothing, [], dump_action) ;
Just (gbl_env, local_gbl_env, export_avails, global_avail_env) ->
-- DEAL WITH DEPRECATIONS
- rnDeprecs local_gbl_env mod_deprec local_decls `thenRn` \ my_deprecs ->
+ rnDeprecs local_gbl_env mod_deprec
+ [d | DeprecD d <- local_decls] `thenRn` \ my_deprecs ->
-- DEAL WITH LOCAL FIXITIES
fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env ->
direct_import_mods :: [ModuleName]
direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports]
- -- *don't* just pick the forward edges. It's entirely possible
- -- that a module is only reachable via back edges.
- user_import ImportByUser = True
- user_import ImportByUserSource = True
- user_import _ = False
-
- -- Export only those fixities that are for names that are
- -- (a) defined in this module
- -- (b) exported
- exported_fixities
- = mkNameEnv [ (name, fixity)
- | FixitySig name fixity loc <- nameEnvElts local_fixity_env,
- isUserExportedName name
- ]
+ -- We record fixities even for things that aren't exported,
+ -- so that we can change into the context of this moodule easily
+ fixities = mkNameEnv [ (name, fixity)
+ | FixitySig name fixity loc <- nameEnvElts local_fixity_env
+ ]
-- Sort the exports to make them easier to compare for versions
my_exports = sortAvails export_avails
mod_iface = ModIface { mi_module = this_module,
- mi_version = panic "mi_version: not filled in yet",
+ mi_version = initialVersionInfo,
mi_orphan = any isOrphanDecl rn_local_decls,
mi_exports = my_exports,
+ mi_globals = gbl_env,
mi_usages = my_usages,
- mi_fixities = exported_fixities,
+ mi_fixities = fixities,
mi_deprecs = my_deprecs,
- mi_decls = rn_local_decls ++ rn_imp_decls
+ mi_decls = panic "mi_decls"
}
+
+ final_decls = rn_local_decls ++ rn_imp_decls
in
-- REPORT UNUSED NAMES, AND DEBUG DUMP
export_avails source_fvs
rn_imp_decls `thenRn_`
- returnRn (Just mod_iface, dump_action) }
- where
- trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
- trashed_imports = {-trace "rnSource:trashed_imports"-} []
+ returnRn (Just (mod_iface, final_decls), dump_action) }
\end{code}
@implicitFVs@ forces the renamer to slurp in some things which aren't
string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
eqString_RDR]
- get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _ _))
+ get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _))
= concat (map get_deriv deriv_classes)
get other = []
\end{code}
-\begin{code}
-dupDefaultDeclErrRn (DefaultDecl _ locn1 : dup_things)
- = pushSrcLocRn locn1 $
- addErrRn msg
- where
- msg = hang (ptext SLIT("Multiple default declarations"))
- 4 (vcat (map pp dup_things))
- pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
-\end{code}
-
-
%*********************************************************
%* *
\subsection{Slurping declarations}
ASSERT( isEmptyFVs fvs )
returnRn decls1
-stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc name1 name2))
- = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc
+stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2))
+ = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc
name1 name2))
-- Nuke the context and constructors
-- But retain the *number* of constructors!
getGates source_fvs (SigD (IfaceSig _ ty _ _))
= extractHsTyNames ty
-getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ ))
+getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ ))
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
(hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
-getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _ _))
+getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _))
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
(hsTyVarNames tvs)
`addOneToNameSet` tycon
getFixities warn_uu acc (FixD fix)
= fix_decl warn_uu acc fix
- getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ ))
+ getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
= foldlRn (fix_decl warn_uu) acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too.
getFixities warn_uu acc other_decl
fix_decl warn_uu acc sig@(FixitySig rdr_name fixity loc)
= -- Check for fixity decl for something not declared
- case lookupRdrEnv gbl_env rdr_name of {
- Nothing | warn_uu
- -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity))
- `thenRn_` returnRn acc
- | otherwise -> returnRn acc ;
-
- Just ((name,_):_) ->
+ pushSrcLocRn loc $
+ lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name ->
+ case maybe_name of {
+ Nothing -> checkRn (not warn_uu) (unusedFixityDecl rdr_name fixity) `thenRn_`
+ returnRn acc ;
+
+ Just name ->
-- Check for duplicate fixity decl
case lookupNameEnv acc name of {
\begin{code}
rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt
- -> [RdrNameHsDecl] -> RnMG [RdrNameDeprecation]
-rnDeprecs gbl_env mod_deprec decls
- = mapRn rn_deprec deprecs `thenRn_`
- returnRn (extra_deprec ++ deprecs)
+ -> [RdrNameDeprecation] -> RnMG Deprecations
+rnDeprecs gbl_env Nothing []
+ = returnRn NoDeprecs
+
+rnDeprecs gbl_env (Just txt) decls
+ = mapRn (addErrRn . badDeprec) decls `thenRn_`
+ returnRn (DeprecAll txt)
+
+rnDeprecs gbl_env Nothing decls
+ = mapRn rn_deprec decls `thenRn` \ pairs ->
+ returnRn (DeprecSome (mkNameEnv (catMaybes pairs)))
where
- deprecs = [d | DeprecD d <- decls]
- extra_deprec = case mod_deprec of
- Nothing -> []
- Just txt -> [Deprecation (IEModuleContents undefined) txt noSrcLoc]
-
- rn_deprec (Deprecation ie txt loc)
- = pushSrcLocRn loc $
- mapRn check (ieNames ie)
-
- check n = case lookupRdrEnv gbl_env n of
- Nothing -> addErrRn (unknownNameErr n)
- Just _ -> returnRn ()
+ rn_deprec (Deprecation rdr_name txt loc)
+ = pushSrcLocRn loc $
+ lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name ->
+ case maybe_name of
+ Just n -> returnRn (Just (n,txt))
+ Nothing -> returnRn Nothing
\end{code}
= vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext SLIT("at ") <+> ppr loc1,
ptext SLIT("and") <+> ppr loc2]
+
+badDeprec d
+ = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
+ nest 4 (ppr d)]
\end{code}
projects / ghc-hetmet.git / blobdiff