summaryrefslogtreecommitdiff
path: root/ghc/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/rename')
-rw-r--r--ghc/compiler/rename/ParseIface.y80
-rw-r--r--ghc/compiler/rename/Rename.lhs138
-rw-r--r--ghc/compiler/rename/RnBinds.lhs3
-rw-r--r--ghc/compiler/rename/RnEnv.lhs11
-rw-r--r--ghc/compiler/rename/RnExpr.lhs2
-rw-r--r--ghc/compiler/rename/RnHsSyn.lhs10
-rw-r--r--ghc/compiler/rename/RnIfaces.lhs97
-rw-r--r--ghc/compiler/rename/RnMonad.lhs12
-rw-r--r--ghc/compiler/rename/RnNames.lhs7
-rw-r--r--ghc/compiler/rename/RnSource.lhs18
10 files changed, 158 insertions, 220 deletions
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 70cbf6bd96..94f29f12f8 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -43,13 +43,12 @@ import BasicTypes ( Fixity(..), FixityDirection(..),
)
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
import CallConv ( cCallConv )
-import HsPragmas ( noDataPragmas, noClassPragmas )
import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind )
import IdInfo ( exactArity, InlinePragInfo(..) )
import PrimOp ( CCall(..), CCallTarget(..) )
import Lex
-import RnMonad ( ParsedIface(..), ExportItem )
+import RnMonad ( ParsedIface(..), ExportItem, IfaceDeprecs )
import HscTypes ( WhetherHasOrphans, IsBootInterface, GenAvailInfo(..),
ImportVersion, WhatsImported(..),
RdrAvailInfo )
@@ -207,9 +206,7 @@ iface_stuff :: { IfaceStuff }
iface_stuff : iface { PIface $1 }
| type { PType $1 }
| id_info { PIdInfo $1 }
- | '__R' rules { PRules $2 }
- | '__D' deprecs { PDeprecs $2 }
-
+ | rules_and_deprecs { PRulesAndDeprecs $1 }
iface :: { ParsedIface }
iface : '__interface' package mod_name
@@ -220,7 +217,7 @@ iface : '__interface' package mod_name
fix_decl_part
instance_decl_part
decls_part
- rules_and_deprecs
+ rules_and_deprecs_part
{ ParsedIface {
pi_mod = mkModule $3 $2, -- Module itself
pi_vers = $4, -- Module version
@@ -369,12 +366,11 @@ decl : src_loc var_name '::' type maybe_idinfo
| src_loc 'type' tc_name tv_bndrs '=' type
{ TyClD (TySynonym $3 $4 $6 $1) }
| src_loc 'data' opt_decl_context tc_name tv_bndrs constrs
- { TyClD (mkTyData DataType $3 $4 $5 $6 (length $6) Nothing noDataPragmas $1) }
+ { TyClD (mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1) }
| src_loc 'newtype' opt_decl_context tc_name tv_bndrs newtype_constr
- { TyClD (mkTyData NewType $3 $4 $5 $6 1 Nothing noDataPragmas $1) }
+ { TyClD (mkTyData NewType $3 $4 $5 $6 1 Nothing $1) }
| src_loc 'class' opt_decl_context tc_name tv_bndrs fds csigs
- { TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds
- noClassPragmas $1) }
+ { TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds $1) }
maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] }
maybe_idinfo : {- empty -} { \_ -> [] }
@@ -394,26 +390,23 @@ pragma : src_loc PRAGMA { parseIface $2 PState{ bol = 0#, atbol = 1#,
-----------------------------------------------------------------------------
-rules_and_deprecs :: { ([RdrNameRuleDecl], [RdrNameDeprecation]) }
-rules_and_deprecs : {- empty -} { ([], []) }
- | rules_and_deprecs rule_or_deprec
- { let
- append2 (xs1,ys1) (xs2,ys2) =
- (xs1 `app` xs2, ys1 `app` ys2)
- xs `app` [] = xs -- performance paranoia
- xs `app` ys = xs ++ ys
- in append2 $1 $2
- }
+rules_and_deprecs_part :: { ([RdrNameRuleDecl], IfaceDeprecs) }
+rules_and_deprecs_part : {- empty -} { ([], Nothing) }
+ | pragma { case $1 of
+ POk _ (PRulesAndDeprecs rds) -> rds
+ PFailed err -> pprPanic "Rules/Deprecations parse failed" err
+ }
-rule_or_deprec :: { ([RdrNameRuleDecl], [RdrNameDeprecation]) }
-rule_or_deprec : pragma { case $1 of
- POk _ (PRules rules) -> (rules,[])
- POk _ (PDeprecs deprecs) -> ([],deprecs)
- PFailed err -> pprPanic "Rules/Deprecations parse failed" err
- }
+rules_and_deprecs :: { ([RdrNameRuleDecl], IfaceDeprecs) }
+rules_and_deprecs : rule_prag deprec_prag { ($1, $2) }
+
-----------------------------------------------------------------------------
+rule_prag :: { [RdrNameRuleDecl] }
+rule_prag : {- empty -} { [] }
+ | '__R' rules { $2 }
+
rules :: { [RdrNameRuleDecl] }
: {- empty -} { [] }
| rule ';' rules { $1:$3 }
@@ -427,18 +420,24 @@ rule_forall : '__forall' '{' core_bndrs '}' { $3 }
-----------------------------------------------------------------------------
-deprecs :: { [RdrNameDeprecation] }
-deprecs : {- empty -} { [] }
- | deprec ';' deprecs { $1 : $3 }
+deprec_prag :: { IfaceDeprecs }
+deprec_prag : {- empty -} { Nothing }
+ | '__D' deprecs { Just $2 }
+
+deprecs :: { Either DeprecTxt [(RdrName,DeprecTxt)] }
+deprecs : STRING { Left $1 }
+ | deprec_list { Right $1 }
+
+deprec_list :: { [(RdrName,DeprecTxt)] }
+deprec_list : deprec { [$1] }
+ | deprec ';' deprec_list { $1 : $3 }
-deprec :: { RdrNameDeprecation }
-deprec : src_loc STRING { Deprecation (IEModuleContents undefined) $2 $1 }
- | src_loc deprec_name STRING { Deprecation $2 $3 $1 }
+deprec :: { (RdrName,DeprecTxt) }
+deprec : deprec_name STRING { ($1, $2) }
--- SUP: TEMPORARY HACK
-deprec_name :: { RdrNameIE }
- : var_name { IEVar $1 }
- | data_name { IEThingAbs $1 }
+deprec_name :: { RdrName }
+ : var_name { $1 }
+ | tc_name { $1 }
-----------------------------------------------------------------------------
@@ -925,11 +924,10 @@ checkVersion :: { () }
happyError :: P a
happyError buf PState{ loc = loc } = PFailed (ifaceParseErr buf loc)
-data IfaceStuff = PIface ParsedIface
- | PIdInfo [HsIdInfo RdrName]
- | PType RdrNameHsType
- | PRules [RdrNameRuleDecl]
- | PDeprecs [RdrNameDeprecation]
+data IfaceStuff = PIface ParsedIface
+ | PIdInfo [HsIdInfo RdrName]
+ | PType RdrNameHsType
+ | PRulesAndDeprecs ([RdrNameRuleDecl], IfaceDeprecs)
mk_con_decl name (ex_tvs, ex_ctxt) details loc = mkConDecl name ex_tvs ex_ctxt details loc
}
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 8790ef0843..0cc7b3f040 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -9,9 +9,8 @@ module Rename ( renameModule ) where
#include "HsVersions.h"
import HsSyn
-import HsPragmas ( DataPragmas(..) )
import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation )
-import RnHsSyn ( RenamedHsModule, RenamedHsDecl,
+import RnHsSyn ( RenamedHsDecl,
extractHsTyNames, extractHsCtxtTyNames
)
@@ -22,24 +21,24 @@ import RnSource ( rnSourceDecls, rnDecl )
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
@@ -51,23 +50,20 @@ import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
)
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}
@@ -105,7 +101,7 @@ renameModule dflags finder hit hst old_pcs this_module
\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 ->
@@ -114,12 +110,13 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls
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 ->
@@ -165,34 +162,28 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls
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
@@ -201,10 +192,7 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls
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
@@ -240,7 +228,7 @@ implicitFVs mod_name decls
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 = []
@@ -279,17 +267,6 @@ isOrphanDecl other = False
\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}
@@ -464,8 +441,8 @@ slurpDeferredDecls decls
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!
@@ -498,7 +475,7 @@ vars of the source program, and extracts from the decl the gate names.
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)
@@ -523,7 +500,7 @@ getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
(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
@@ -600,7 +577,7 @@ fixitiesFromLocalDecls gbl_env decls
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
@@ -608,13 +585,13 @@ fixitiesFromLocalDecls gbl_env decls
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 {
@@ -638,23 +615,24 @@ gather them together.
\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}
@@ -933,6 +911,10 @@ dupFixityDecl rdr_name loc1 loc2
= 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}
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index bfc67adc57..f27407afee 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -38,9 +38,8 @@ import NameSet
import RdrName ( RdrName, rdrNameOcc )
import BasicTypes ( RecFlag(..) )
import List ( partition )
-import Bag ( bagToList )
import Outputable
-import PrelNames ( mkUnboundName, isUnboundName )
+import PrelNames ( isUnboundName )
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index d4ff303608..adcdb82b11 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -11,7 +11,7 @@ module RnEnv where -- Export everything
import HsSyn
import RdrHsSyn ( RdrNameIE )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
- mkRdrUnqual, qualifyRdrName
+ mkRdrUnqual, qualifyRdrName, lookupRdrEnv
)
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
@@ -223,6 +223,15 @@ lookupGlobalOccRn rdr_name
failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
}
+
+lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name)
+ -- Checks that there is exactly one
+lookupGlobalRn global_env rdr_name
+ = case lookupRdrEnv global_env rdr_name of
+ Just [(name,_)] -> returnRn (Just name)
+ Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_`
+ returnRn (Just name)
+ Nothing -> returnRn Nothing
\end{code}
%
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 3cf439db09..134a5405ef 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -39,7 +39,7 @@ import PrelNames ( hasKey, assertIdKey,
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
)
-import TysWiredIn ( intTyCon, integerTyCon )
+import TysWiredIn ( intTyCon )
import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc )
import NameSet
import UniqFM ( isNullUFM )
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 58e86b0db2..7ef1cc3e39 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -9,8 +9,6 @@ module RnHsSyn where
#include "HsVersions.h"
import HsSyn
-import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas )
-
import TysWiredIn ( tupleTyCon, listTyCon, charTyCon )
import Name ( Name, getName, isTyVarName )
import NameSet
@@ -27,7 +25,6 @@ type RenamedContext = HsContext Name
type RenamedHsDecl = HsDecl Name RenamedPat
type RenamedRuleDecl = RuleDecl Name RenamedPat
type RenamedTyClDecl = TyClDecl Name RenamedPat
-type RenamedSpecDataSig = SpecDataSig Name
type RenamedDefaultDecl = DefaultDecl Name
type RenamedForeignDecl = ForeignDecl Name
type RenamedGRHS = GRHS Name RenamedPat
@@ -47,12 +44,7 @@ type RenamedStmt = Stmt Name RenamedPat
type RenamedFixitySig = FixitySig Name
type RenamedDeprecation = DeprecDecl Name
type RenamedHsOverLit = HsOverLit Name
-
-type RenamedClassOpPragmas = ClassOpPragmas Name
-type RenamedClassPragmas = ClassPragmas Name
-type RenamedDataPragmas = DataPragmas Name
-type RenamedGenPragmas = GenPragmas Name
-type RenamedInstancePragmas = InstancePragmas Name
+type RenamedIfaceSig = IfaceSig Name
\end{code}
%************************************************************************
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 62993fd30f..4452723002 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -22,17 +22,16 @@ where
#include "HsVersions.h"
import CmdLineOpts ( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
+import HscTypes
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
- HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
+ HsType(..), ConDecl(..),
ForeignDecl(..), ForKind(..), isDynamicExtName,
FixitySig(..), RuleDecl(..),
- isClassOpSig, DeprecDecl(..)
+ tyClDeclNames
)
-import HsImpExp ( ImportDecl(..), ieNames )
-import CoreSyn ( CoreRule )
+import HsImpExp ( ImportDecl(..) )
import BasicTypes ( Version, defaultFixity )
import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameRuleDecl,
- RdrNameDeprecation, RdrNameIE,
extractHsTyRdrNames
)
import RnEnv
@@ -47,23 +46,21 @@ import Name ( Name {-instance NamedThing-}, nameOccName,
import Module ( Module, ModuleEnv,
moduleName, isModuleInThisPackage,
ModuleName, WhereFrom(..),
- emptyModuleEnv, extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName,
+ emptyModuleEnv, extendModuleEnv, lookupModuleEnvByName,
extendModuleEnv_C, lookupWithDefaultModuleEnv
)
import RdrName ( RdrName, rdrNameOcc )
import NameSet
import SrcLoc ( mkSrcLoc, SrcLoc )
-import PrelInfo ( cCallishTyKeys, wiredInThingEnv )
+import PrelInfo ( wiredInThingEnv )
import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
import ErrUtils ( Message )
-import Util ( sortLt )
import Lex
import FiniteMap
import Outputable
import Bag
-import HscTypes
import List ( nub )
\end{code}
@@ -436,16 +433,16 @@ loadRule mod decl@(IfaceRule _ _ var _ _ src_loc)
-- Loading Deprecations
-----------------------------------------------------
-loadDeprecs :: Module -> [RdrNameDeprecation] -> RnM d Deprecations
-loadDeprecs m [] = returnRn NoDeprecs
-loadDeprecs m [Deprecation (IEModuleContents _) txt _] = returnRn (DeprecAll txt)
-loadDeprecs m deprecs = setModuleRn m $
- foldlRn loadDeprec emptyNameEnv deprecs `thenRn` \ env ->
- returnRn (DeprecSome env)
-loadDeprec deprec_env (Deprecation ie txt _)
- = mapRn lookupOrigName (ieNames ie) `thenRn` \ names ->
- traceRn (text "Loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_`
- returnRn (extendNameEnvList deprec_env (zip names (repeat txt)))
+loadDeprecs :: Module -> IfaceDeprecs -> RnM d Deprecations
+loadDeprecs m Nothing = returnRn NoDeprecs
+loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt)
+loadDeprecs m (Just (Right prs)) = setModuleRn m $
+ foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env ->
+ returnRn (DeprecSome env)
+loadDeprec deprec_env (n, txt)
+ = lookupOrigName n `thenRn` \ name ->
+ traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_`
+ returnRn (extendNameEnv deprec_env name txt)
\end{code}
@@ -501,7 +498,7 @@ getNonWiredInDecl needed_name
case lookupNameEnv (iDecls ifaces) needed_name of
{- OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS
- Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _ _)))
+ Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _)))
-- This case deals with deferred import of algebraic data types
| not opt_NoPruneTyDecls
@@ -914,36 +911,16 @@ getDeclBinders :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function
-> RdrNameHsDecl
-> RnM d (Maybe AvailInfo)
-getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc _ _))
- = new_name tycon src_loc `thenRn` \ tycon_name ->
- getConFieldNames new_name condecls `thenRn` \ sub_names ->
- returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names)))
- -- The "nub" is because getConFieldNames can legitimately return duplicates,
- -- when a record declaration has the same field in multiple constructors
-
-getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc))
- = new_name tycon src_loc `thenRn` \ tycon_name ->
- returnRn (Just (AvailTC tycon_name [tycon_name]))
-
-getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ src_loc))
- = new_name cname src_loc `thenRn` \ class_name ->
-
- -- Record the names for the class ops
- let
- -- just want class-op sigs
- op_sigs = filter isClassOpSig sigs
- in
- mapRn (getClassOpNames new_name) op_sigs `thenRn` \ sub_names ->
-
- returnRn (Just (AvailTC class_name (class_name : sub_names)))
+getDeclBinders new_name (TyClD tycl_decl)
+ = mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
+ returnRn (Just (AvailTC main_name (main_name : sub_names)))
+ where
+ do_one (name,loc) = new_name name loc
getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
= new_name var src_loc `thenRn` \ var_name ->
returnRn (Just (Avail var_name))
-getDeclBinders new_name (FixD _) = returnRn Nothing
-getDeclBinders new_name (DeprecD _) = returnRn Nothing
-
-- foreign declarations
getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
| binds_haskell_name kind dyn
@@ -954,30 +931,15 @@ getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
= lookupOrigName nm `thenRn_`
returnRn Nothing
-getDeclBinders new_name (DefD _) = returnRn Nothing
-getDeclBinders new_name (InstD _) = returnRn Nothing
-getDeclBinders new_name (RuleD _) = returnRn Nothing
+getDeclBinders new_name (FixD _) = returnRn Nothing
+getDeclBinders new_name (DeprecD _) = returnRn Nothing
+getDeclBinders new_name (DefD _) = returnRn Nothing
+getDeclBinders new_name (InstD _) = returnRn Nothing
+getDeclBinders new_name (RuleD _) = returnRn Nothing
binds_haskell_name (FoImport _) _ = True
binds_haskell_name FoLabel _ = True
binds_haskell_name FoExport ext_nm = isDynamicExtName ext_nm
-
-----------------
-getConFieldNames new_name (ConDecl con _ _ _ (RecCon fielddecls) src_loc : rest)
- = mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs ->
- getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (cfs ++ ns)
- where
- fields = concat (map fst fielddecls)
-
-getConFieldNames new_name (ConDecl con _ _ _ condecl src_loc : rest)
- = new_name con src_loc `thenRn` \ n ->
- getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (n : ns)
-
-getConFieldNames new_name [] = returnRn []
-
-getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
\end{code}
@getDeclSysBinders@ gets the implicit binders introduced by a decl.
@@ -990,11 +952,10 @@ and the dict fun of an instance decl, because both of these have
bindings of their own elsewhere.
\begin{code}
-getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ names
- src_loc))
+getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ names src_loc))
= sequenceRn [new_name n src_loc | n <- names]
-getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _ _))
+getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _))
= sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
getDeclSysBinders new_name other_decl
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 1b3bcfc8ef..17c5c716e3 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -51,7 +51,7 @@ import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
)
import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
RdrNameEnv, emptyRdrEnv, extendRdrEnv,
- lookupRdrEnv, addListToRdrEnv, rdrEnvToList, rdrEnvElts
+ addListToRdrEnv, rdrEnvToList, rdrEnvElts
)
import Name ( Name, OccName, NamedThing(..), getSrcLoc,
isLocallyDefinedName, nameModule, nameOccName,
@@ -193,7 +193,11 @@ type ExportAvails = (FiniteMap ModuleName Avails,
%===================================================
\begin{code}
-type ExportItem = (ModuleName, [RdrAvailInfo])
+type ExportItem = (ModuleName, [RdrAvailInfo])
+type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)])
+ -- Nothing => NoDeprecs
+ -- Just (Left t) => DeprecAll
+ -- Just (Right p) => DeprecSome
data ParsedIface
= ParsedIface {
@@ -202,11 +206,11 @@ data ParsedIface
pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
pi_usages :: [ImportVersion OccName], -- Usages
pi_exports :: (Version, [ExportItem]), -- Exports
- pi_insts :: [RdrNameInstDecl], -- Local instance declarations
pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions
pi_fixity :: [RdrNameFixitySig], -- Local fixity declarations,
+ pi_insts :: [RdrNameInstDecl], -- Local instance declarations
pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version
- pi_deprecs :: [RdrNameDeprecation] -- Deprecations
+ pi_deprecs :: IfaceDeprecs -- Deprecations
}
\end{code}
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index fb0b5c623a..9a61325d9b 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -10,7 +10,7 @@ module RnNames (
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_NoImplicitPrelude )
+import CmdLineOpts ( DynFlag(..), opt_NoImplicitPrelude )
import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
collectTopBinders
@@ -19,7 +19,7 @@ import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
RdrNameHsModule, RdrNameHsDecl
)
import RnIfaces ( getInterfaceExports, getDeclBinders,
- recordLocalSlurps, findAndReadIface )
+ recordLocalSlurps )
import RnEnv
import RnMonad
@@ -33,8 +33,7 @@ import Name ( Name, nameSrcLoc,
setLocalNameSort, nameOccName, nameEnvElts )
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
GenAvailInfo(..), AvailInfo, Avails, AvailEnv )
-import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual,
- isQual, isUnqual )
+import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isUnqual )
import OccName ( setOccNameSpace, dataName )
import NameSet ( elemNameSet, emptyNameSet )
import Outputable
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index b0d5e4669d..86729ae527 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -10,7 +10,6 @@ module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
import RnExpr
import HsSyn
-import HsPragmas
import HsTypes ( hsTyVarNames, pprHsContext )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
@@ -36,22 +35,20 @@ import FunDeps ( oclose )
import Class ( FunDep, DefMeth (..) )
import Name ( Name, OccName, nameOccName, NamedThing(..) )
import NameSet
-import OccName ( mkDefaultMethodOcc, isTvOcc )
import FiniteMap ( elemFM )
import PrelInfo ( derivableClassKeys, cCallishClassKeys )
import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
bindIO_RDR, returnIO_RDR
)
-import Bag ( bagToList )
import List ( partition, nub )
import Outputable
import SrcLoc ( SrcLoc )
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import CmdLineOpts ( DynFlag(..) )
-- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
import ErrUtils ( Message )
import CStrings ( isCLabelString )
-import ListSetOps ( minusList, removeDupsEq )
+import ListSetOps ( removeDupsEq )
\end{code}
@rnDecl@ `renames' declarations.
@@ -136,7 +133,7 @@ and then go over it again to rename the tyvars!
However, we can also do some scoping checks at the same time.
\begin{code}
-rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc gen_name1 gen_name2))
+rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2))
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
@@ -146,9 +143,8 @@ rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivin
lookupSysBinder gen_name1 `thenRn` \ name1' ->
lookupSysBinder gen_name2 `thenRn` \ name2' ->
rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
- ASSERT(isNoDataPragmas pragmas)
returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
- derivings' noDataPragmas src_loc name1' name2'),
+ derivings' src_loc name1' name2'),
cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
where
data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
@@ -169,8 +165,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc))
unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
unquantify glaExys ty = ty
-rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
- names src_loc))
+rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds names src_loc))
= pushSrcLocRn src_loc $
lookupTopBndrRn cname `thenRn` \ cname' ->
@@ -232,9 +227,8 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
-- The renamer *could* check this for class decls, but can't
-- for instance decls.
- ASSERT(isNoClassPragmas pragmas)
returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
- NoClassPragmas names' src_loc),
+ names' src_loc),
sig_fvs `plusFV`
fix_fvs `plusFV`
View Lorry Controller Status