diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs
index 16ab432d94468ac3ee8d90500ea6ea9da2817782..820a3b95754e06ce00d450a374ffe25d4538959a 100644
--- a/ghc/compiler/basicTypes/BasicTypes.lhs
+++ b/ghc/compiler/basicTypes/BasicTypes.lhs
@@ -86,7 +86,7 @@ bogusVersion = error "bogusVersion"
bumpVersion :: Bool -> Version -> Version
-- Bump if the predicate (typically equality between old and new) is false
bumpVersion False v = v+1
-bumpVersion True v = v+1
+bumpVersion True v = v
initialVersion :: Version
initialVersion = 1
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index abe6679d6a12aacc385f1f2f659a159085be54d4..5888124fc32f12908052290a40c676d168581808 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -45,7 +45,7 @@ module Name (
import OccName -- All of it
import Module ( Module, moduleName, mkVanillaModule,
printModulePrefix, isModuleInThisPackage )
-import RdrName ( RdrName, mkRdrOrig, mkRdrIfaceUnqual, rdrNameOcc, rdrNameModule )
+import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule )
import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 )
@@ -355,7 +355,7 @@ nameRdrName :: Name -> RdrName
-- Makes a qualified name for top-level (Global) names, whether locally defined or not
-- and an unqualified name just for Locals
nameRdrName (Name { n_occ = occ, n_sort = Global mod }) = mkRdrOrig (moduleName mod) occ
-nameRdrName (Name { n_occ = occ }) = mkRdrIfaceUnqual occ
+nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ
isDllName :: Name -> Bool
-- Does this name refer to something in a different DLL?
@@ -471,32 +471,19 @@ pprLocal sty uniq occ pp_export
| otherwise = pprOccName occ
pprGlobal sty uniq mod occ
- | codeStyle sty
- || ifaceStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
+ | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
| debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <>
text "{-" <> pprUnique10 uniq <> text "-}"
- | printModulePrefix mod = ppr (moduleName mod) <> dot <> pprOccName occ
- | otherwise = pprOccName occ
+ | ifaceStyle sty
+ || printModulePrefix mod = ppr (moduleName mod) <> dot <> pprOccName occ
+
+ | otherwise = pprOccName occ
pprSysLocal sty uniq occ
| codeStyle sty = pprUnique uniq
| otherwise = pprOccName occ <> char '_' <> pprUnique uniq
-
-{-
-pprNameBndr :: Name -> SDoc
--- Print a binding occurrence of a name.
--- In interface files we can omit the "M." prefix, which tides things up a lot
-pprNameBndr name
- = getPprStyle $ \ sty ->
- case sort of
- Global mod | ifaceStyle sty -> pprLocal sty uniq occ empty
- | otherwise -> pprGlobal sty uniq mod occ
- System -> pprSysLocal sty uniq occ
- Local -> pprLocal sty uniq occ empty
- Exported -> pprLocal sty uniq occ (char 'x')
--}
\end{code}
diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs
index a3572ba50d7d7b14477c68ad399522597d3a628a..1d45301d791040ceefd76aef49c5fda7bab261ce 100644
--- a/ghc/compiler/basicTypes/RdrName.lhs
+++ b/ghc/compiler/basicTypes/RdrName.lhs
@@ -9,14 +9,14 @@ module RdrName (
RdrName,
-- Construction
- mkRdrUnqual, mkRdrQual, mkRdrOrig, mkRdrIfaceUnqual,
+ mkRdrUnqual, mkRdrQual, mkRdrOrig, mkRdrUnqual,
mkUnqual, mkQual, mkIfaceOrig, mkOrig,
qualifyRdrName, mkRdrNameWkr,
dummyRdrVarName, dummyRdrTcName,
-- Destruction
rdrNameModule, rdrNameOcc, setRdrNameOcc,
- isRdrDataCon, isRdrTyVar, isQual, isSourceQual, isUnqual, isIface,
+ isRdrDataCon, isRdrTyVar, isQual, isUnqual, isOrig,
-- Environment
RdrNameEnv,
@@ -55,10 +55,6 @@ data RdrName = RdrName Qual OccName
data Qual = Unqual
- | IfaceUnqual -- An unqualified name from an interface file;
- -- implicitly its module is that of the enclosing
- -- interface file; don't look it up in the environment
-
| Qual ModuleName -- A qualified name written by the user in source code
-- The module isn't necessarily the module where
-- the thing is defined; just the one from which it
@@ -92,9 +88,6 @@ setRdrNameOcc (RdrName q _) occ = RdrName q occ
mkRdrUnqual :: OccName -> RdrName
mkRdrUnqual occ = RdrName Unqual occ
-mkRdrIfaceUnqual :: OccName -> RdrName
-mkRdrIfaceUnqual occ = RdrName IfaceUnqual occ
-
mkRdrQual :: ModuleName -> OccName -> RdrName
mkRdrQual mod occ = RdrName (Qual mod) occ
@@ -139,18 +132,14 @@ dummyRdrTcName = RdrName Unqual (mkOccFS tcName SLIT("TC-DUMMY"))
isRdrDataCon (RdrName _ occ) = isDataOcc occ
isRdrTyVar (RdrName _ occ) = isTvOcc occ
-isUnqual (RdrName Unqual _) = True
-isUnqual (RdrName IfaceUnqual _) = True
-isUnqual other = False
-
-isQual rdr_name = not (isUnqual rdr_name)
+isUnqual (RdrName Unqual _) = True
+isUnqual other = False
-isSourceQual (RdrName (Qual _) _) = True
-isSourceQual _ = False
+isQual (RdrName (Qual _) _) = True
+isQual _ = False
-isIface (RdrName (Orig _) _) = True
-isIface (RdrName IfaceUnqual _) = True
-isIface other = False
+isOrig (RdrName (Orig _) _) = True
+isOrig other = False
\end{code}
@@ -165,7 +154,6 @@ instance Outputable RdrName where
ppr (RdrName qual occ) = pp_qual qual <> ppr occ
where
pp_qual Unqual = empty
- pp_qual IfaceUnqual = empty
pp_qual (Qual mod) = ppr mod <> dot
pp_qual (Orig mod) = ppr mod <> dot
@@ -186,12 +174,9 @@ instance Ord RdrName where
(q1 `cmpQual` q2)
cmpQual Unqual Unqual = EQ
-cmpQual IfaceUnqual IfaceUnqual = EQ
cmpQual (Qual m1) (Qual m2) = m1 `compare` m2
cmpQual (Orig m1) (Orig m2) = m1 `compare` m2
cmpQual Unqual _ = LT
-cmpQual IfaceUnqual (Qual _) = LT
-cmpQual IfaceUnqual (Orig _) = LT
cmpQual (Qual _) (Orig _) = LT
cmpQual _ _ = GT
\end{code}
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 72a4cf7333e397d8e20d6520a7ed2a2cb04fcad4..bf5857eafdd09475dc638d5e1d626d42999e1dcd 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -223,7 +223,10 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch
mkFinalIface dflags location maybe_old_iface new_iface new_details
= case completeIface maybe_old_iface new_iface new_details of
(new_iface, Nothing) -- no change in the interfacfe
- -> return new_iface
+ -> do if dopt Opt_D_dump_hi_diffs dflags then
+ printDump (text "INTERFACE UNCHANGED")
+ else return ()
+ return new_iface
(new_iface, Just sdoc)
-> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "NEW INTERFACE" sdoc
-- Write the interface file
diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 3b0444fb281e4e76977d6eafbbafdb411b2fd60e..444a4f62efbb6f7070ed6d22ab9ae33ea6e1a069 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -331,6 +331,16 @@ data GenAvailInfo name = Avail name -- An ordinary identifier
-- Equality used when deciding if the interface has changed
type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it
+
+instance Outputable n => Outputable (GenAvailInfo n) where
+ ppr = pprAvail
+
+pprAvail :: Outputable n => GenAvailInfo n -> SDoc
+pprAvail (AvailTC n ns) = ppr n <> case {- filter (/= n) -} ns of
+ [] -> empty
+ ns' -> braces (hsep (punctuate comma (map ppr ns')))
+
+pprAvail (Avail n) = ppr n
\end{code}
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 18735999eb86f441ba3166271b52fe2ace23a336..8540f9f5f4936e1e315e4ff166e8057f414749dc 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -223,8 +223,6 @@ ifaceTyCls (ATyCon tycon) so_far
mk_field strict_mark field_label
= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
-ifaceTyCls (ATyCon tycon) so_far = pprPanic "ifaceTyCls" (ppr tycon)
-
ifaceTyCls (AnId id) so_far
| omitIfaceSigForId id = so_far
| otherwise = iface_sig : so_far
@@ -657,20 +655,17 @@ pprExport :: (ModuleName, Avails) -> SDoc
pprExport (mod, items)
= hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
where
- ppr_name :: Name -> SDoc -- Print the occurrence name only
- ppr_name n = ppr (nameOccName n)
-
pp_avail :: AvailInfo -> SDoc
- pp_avail (Avail name) = ppr_name name
- pp_avail (AvailTC name []) = empty
- pp_avail (AvailTC name ns) = hcat [ppr_name name, bang, pp_export ns']
- where
- bang | name `elem` ns = empty
- | otherwise = char '|'
- ns' = filter (/= name) ns
+ pp_avail (Avail name) = pprOcc name
+ pp_avail (AvailTC n []) = empty
+ pp_avail (AvailTC n (n':ns)) | n==n' = pprOcc n <> pp_export ns
+ | otherwise = pprOcc n <> char '|' <> pp_export (n':ns)
pp_export [] = empty
- pp_export names = braces (hsep (map ppr_name names))
+ pp_export names = braces (hsep (map pprOcc names))
+
+pprOcc :: Name -> SDoc -- Print the occurrence name only
+pprOcc n = pprOccName (nameOccName n)
\end{code}
@@ -691,7 +686,7 @@ pprUsage (m, has_orphans, is_boot, whats_imported)
pp_versions NothingAtAll = empty
pp_versions (Everything v) = dcolon <+> int v
pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr
- <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
+ <+> hsep [ pprOcc n <+> int v | (n,v) <- nvs ]
-- HACK for the moment: print the export-list version even if
-- we don't use it, so that syntax of interface files doesn't change
@@ -733,5 +728,5 @@ pprDeprecs deprecs = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
where
- pp_deprec (name, txt) = pprOccName (nameOccName name) <+> ptext txt
+ pp_deprec (name, txt) = pprOcc name <+> ptext txt
\end{code}
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index cc6f64c543e676785a880fdbcbeb46ef44418193..b76c269fd1ae1e60a48b6ae03c48ab317542e649 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -68,7 +68,7 @@ import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
mkGenOcc2,
)
import PrelNames ( negate_RDR )
-import RdrName ( RdrName, isRdrTyVar, mkRdrIfaceUnqual, rdrNameOcc,
+import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
)
import List ( nub )
import BasicTypes ( RecFlag(..) )
@@ -216,10 +216,10 @@ mkClassDecl cxt cname tyvars fds sigs mbinds loc
where
cls_occ = rdrNameOcc cname
data_occ = mkClassDataConOcc cls_occ
- dname = mkRdrIfaceUnqual data_occ
- dwname = mkRdrIfaceUnqual (mkWorkerOcc data_occ)
- tname = mkRdrIfaceUnqual (mkClassTyConOcc cls_occ)
- sc_sel_names = [ mkRdrIfaceUnqual (mkSuperDictSelOcc n cls_occ)
+ dname = mkRdrUnqual data_occ
+ dwname = mkRdrUnqual (mkWorkerOcc data_occ)
+ tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
+ sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
| n <- [1..length cxt]]
-- We number off the superclass selectors, 1, 2, 3 etc so that we
-- can construct names for the selectors. Thus
@@ -233,22 +233,22 @@ mkClassDecl cxt cname tyvars fds sigs mbinds loc
-- mkTyData :: ??
mkTyData new_or_data context tname list_var list_con i maybe src
= let t_occ = rdrNameOcc tname
- name1 = mkRdrIfaceUnqual (mkGenOcc1 t_occ)
- name2 = mkRdrIfaceUnqual (mkGenOcc2 t_occ)
+ name1 = mkRdrUnqual (mkGenOcc1 t_occ)
+ name2 = mkRdrUnqual (mkGenOcc2 t_occ)
in TyData new_or_data context
tname list_var list_con i maybe src name1 name2
mkClassOpSig (DefMeth x) op ty loc
= ClassOpSig op (Just (DefMeth dm_rn)) ty loc
where
- dm_rn = mkRdrIfaceUnqual (mkDefaultMethodOcc (rdrNameOcc op))
+ dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
mkClassOpSig x op ty loc =
ClassOpSig op (Just x) ty loc
mkConDecl cname ex_vars cxt details loc
= ConDecl cname wkr_name ex_vars cxt details loc
where
- wkr_name = mkRdrIfaceUnqual (mkWorkerOcc (rdrNameOcc cname))
+ wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
\end{code}
\begin{code}
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 8cb756f91e97a576475c0be8d5afa777523479c5..c1419389721449e30e6f6ac93146bcab901f8e98 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -53,7 +53,7 @@ import HscTypes ( WhetherHasOrphans, IsBootInterface, GenAvailInfo(..),
ImportVersion, WhatsImported(..),
RdrAvailInfo )
-import RdrName ( RdrName, mkRdrIfaceUnqual, mkIfaceOrig )
+import RdrName ( RdrName, mkRdrUnqual, mkIfaceOrig )
import Name ( OccName )
import OccName ( mkSysOccFS,
tcName, varName, ipName, dataName, clsName, tvName, uvName,
@@ -283,11 +283,8 @@ entity :: { RdrAvailInfo }
entity : var_occ { Avail $1 }
| tc_occ { AvailTC $1 [$1] }
| tc_occ '|' stuff_inside { AvailTC $1 $3 }
- | tc_occ stuff_inside { AvailTC $1 (insert $1 $2) }
- -- The 'insert' is important. The stuff_inside is sorted, and
- -- insert keeps it that way. This is important when comparing
- -- against the new interface file, which has the stuff in sorted order
- -- If they differ, we'll bump the module number when it's unnecessary
+ | tc_occ stuff_inside { AvailTC $1 ($1:$2) }
+ -- Note that the "main name" comes at the beginning
stuff_inside :: { [OccName] }
stuff_inside : '{' val_occs '}' { $2 }
@@ -333,10 +330,10 @@ csigs1 : { [] }
| csig ';' csigs1 { $1 : $3 }
csig :: { RdrNameSig }
-csig : src_loc var_name '::' type { mkClassOpSig NoDefMeth $2 $4 $1 }
- | src_loc var_name '=' '::' type { mkClassOpSig (DefMeth (error "DefMeth") )
+csig : src_loc qvar_name '::' type { mkClassOpSig NoDefMeth $2 $4 $1 }
+ | src_loc qvar_name '=' '::' type { mkClassOpSig (DefMeth (error "DefMeth") )
$2 $5 $1 }
- | src_loc var_name ';' '::' type { mkClassOpSig GenDefMeth $2 $5 $1 }
+ | src_loc qvar_name ';' '::' type { mkClassOpSig GenDefMeth $2 $5 $1 }
--------------------------------------------------------------------------
@@ -345,7 +342,7 @@ instance_decl_part : {- empty -} { [] }
| instance_decl_part inst_decl { $2 : $1 }
inst_decl :: { RdrNameInstDecl }
-inst_decl : src_loc 'instance' type '=' var_name ';'
+inst_decl : src_loc 'instance' type '=' qvar_name ';'
{ InstDecl $3
EmptyMonoBinds {- No bindings -}
[] {- No user pragmas -}
@@ -361,15 +358,15 @@ decls_part
| opt_version decl ';' decls_part { ($1,$2):$4 }
decl :: { RdrNameTyClDecl }
-decl : src_loc var_name '::' type maybe_idinfo
+decl : src_loc qvar_name '::' type maybe_idinfo
{ IfaceSig $2 $4 ($5 $2) $1 }
- | src_loc 'type' tc_name tv_bndrs '=' type
+ | src_loc 'type' qtc_name tv_bndrs '=' type
{ TySynonym $3 $4 $6 $1 }
- | src_loc 'data' opt_decl_context tc_name tv_bndrs constrs
+ | src_loc 'data' opt_decl_context qtc_name tv_bndrs constrs
{ mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1 }
- | src_loc 'newtype' opt_decl_context tc_name tv_bndrs newtype_constr
+ | src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr
{ mkTyData NewType $3 $4 $5 $6 1 Nothing $1 }
- | src_loc 'class' opt_decl_context tc_name tv_bndrs fds csigs
+ | src_loc 'class' opt_decl_context qtc_name tv_bndrs fds csigs
{ mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds $1 }
maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] }
@@ -452,8 +449,8 @@ deprec :: { (RdrName,DeprecTxt) }
deprec : deprec_name STRING { ($1, $2) }
deprec_name :: { RdrName }
- : var_name { $1 }
- | tc_name { $1 }
+ : qvar_name { $1 }
+ | qtc_name { $1 }
-----------------------------------------------------------------------------
@@ -479,13 +476,13 @@ constrs1 : constr { [$1] }
| constr '|' constrs1 { $1 : $3 }
constr :: { RdrNameConDecl }
-constr : src_loc ex_stuff data_name batypes { mk_con_decl $3 $2 (VanillaCon $4) $1 }
- | src_loc ex_stuff data_name '{' fields1 '}' { mk_con_decl $3 $2 (RecCon $5) $1 }
+constr : src_loc ex_stuff qdata_name batypes { mk_con_decl $3 $2 (VanillaCon $4) $1 }
+ | src_loc ex_stuff qdata_name '{' fields1 '}' { mk_con_decl $3 $2 (RecCon $5) $1 }
-- We use "data_fs" so as to include ()
newtype_constr :: { [RdrNameConDecl] {- Not allowed to be empty -} }
-newtype_constr : src_loc '=' ex_stuff data_name atype { [mk_con_decl $4 $3 (VanillaCon [Unbanged $5]) $1] }
- | src_loc '=' ex_stuff data_name '{' var_name '::' atype '}'
+newtype_constr : src_loc '=' ex_stuff qdata_name atype { [mk_con_decl $4 $3 (VanillaCon [Unbanged $5]) $1] }
+ | src_loc '=' ex_stuff qdata_name '{' qvar_name '::' atype '}'
{ [mk_con_decl $4 $3 (RecCon [([$6], Unbanged $8)]) $1] }
ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) }
@@ -506,9 +503,9 @@ fields1 : field { [$1] }
| field ',' fields1 { $1 : $3 }
field :: { ([RdrName], RdrNameBangType) }
-field : var_names1 '::' type { ($1, Unbanged $3) }
- | var_names1 '::' '!' type { ($1, Banged $4) }
- | var_names1 '::' '!' '!' type { ($1, Unpacked $5) }
+field : qvar_names1 '::' type { ($1, Unbanged $3) }
+ | qvar_names1 '::' '!' type { ($1, Banged $4) }
+ | qvar_names1 '::' '!' '!' type { ($1, Unpacked $5) }
--------------------------------------------------------------------------
type :: { RdrNameHsType }
@@ -606,14 +603,18 @@ var_occ :: { OccName }
: var_fs { mkSysOccFS varName $1 }
var_name :: { RdrName }
-var_name : var_occ { mkRdrIfaceUnqual $1 }
+var_name : var_occ { mkRdrUnqual $1 }
qvar_name :: { RdrName }
qvar_name : var_name { $1 }
| qvar_fs { mkIfaceOrig varName $1 }
ipvar_name :: { RdrName }
- : IPVARID { mkRdrIfaceUnqual (mkSysOccFS ipName (tailFS $1)) }
+ : IPVARID { mkRdrUnqual (mkSysOccFS ipName (tailFS $1)) }
+
+qvar_names1 :: { [RdrName] }
+qvar_names1 : qvar_name { [$1] }
+ | qvar_name qvar_names1 { $1 : $2 }
var_names :: { [RdrName] }
var_names : { [] }
@@ -640,22 +641,22 @@ data_occ :: { OccName }
: data_fs { mkSysOccFS dataName $1 }
data_name :: { RdrName }
- : data_occ { mkRdrIfaceUnqual $1 }
+ : data_occ { mkRdrUnqual $1 }
qdata_name :: { RdrName }
qdata_name : data_name { $1 }
| qdata_fs { mkIfaceOrig dataName $1 }
var_or_data_name :: { RdrName }
- : var_name { $1 }
- | data_name { $1 }
+ : qvar_name { $1 }
+ | qdata_name { $1 }
---------------------------------------------------
tc_occ :: { OccName }
: data_fs { mkSysOccFS tcName $1 }
tc_name :: { RdrName }
- : tc_occ { mkRdrIfaceUnqual $1 }
+ : tc_occ { mkRdrUnqual $1 }
qtc_name :: { RdrName }
: tc_name { $1 }
@@ -663,7 +664,7 @@ qtc_name :: { RdrName }
---------------------------------------------------
cls_name :: { RdrName }
- : data_fs { mkRdrIfaceUnqual (mkSysOccFS clsName $1) }
+ : data_fs { mkRdrUnqual (mkSysOccFS clsName $1) }
qcls_name :: { RdrName }
: cls_name { $1 }
@@ -671,7 +672,7 @@ qcls_name :: { RdrName }
---------------------------------------------------
uv_name :: { RdrName }
- : VARID { mkRdrIfaceUnqual (mkSysOccFS uvName $1) }
+ : VARID { mkRdrUnqual (mkSysOccFS uvName $1) }
uv_bndr :: { RdrName }
: uv_name { $1 }
@@ -682,8 +683,8 @@ uv_bndrs :: { [RdrName] }
---------------------------------------------------
tv_name :: { RdrName }
- : VARID { mkRdrIfaceUnqual (mkSysOccFS tvName $1) }
- | VARSYM { mkRdrIfaceUnqual (mkSysOccFS tvName $1) {- Allow t2 as a tyvar -} }
+ : VARID { mkRdrUnqual (mkSysOccFS tvName $1) }
+ | VARSYM { mkRdrUnqual (mkSysOccFS tvName $1) {- Allow t2 as a tyvar -} }
tv_bndr :: { HsTyVarBndr RdrName }
: tv_name '::' akind { IfaceTyVar $1 $3 }
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index f080bd942ef0c320444e181e11153926c64e6c9e..a54934d32afa15c2196e5e982693de10986a1eff 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -239,8 +239,8 @@ implicitFVs mod_name decls
implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
-- Virtually every program has error messages in it somewhere
- string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
- eqString_RDR]
+ string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR,
+ unpackCStringUtf8_RDR, eqString_RDR]
get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _))
= concat (map get_deriv deriv_classes)
@@ -385,7 +385,8 @@ checkOldIface dflags hit hst pcs iface_path source_unchanged maybe_iface
-> do read_result <- readIface do_traceRn iface_path
case read_result of
Left err -> -- Old interface file not found, or garbled; give up
- return (pcs, False, (outOfDate, Nothing))
+ do { ioTraceRn (text "Bad old interface file" $$ nest 4 err) ;
+ return (pcs, False, (outOfDate, Nothing)) }
Right parsed_iface
-> startRn (pi_mod parsed_iface) $
loadOldIface parsed_iface `thenRn` \ m_iface ->
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 4fc26e15cc090f058bce521cd25bc3cf01b8ab45..a3c31d692edb8c5d7ac5cf6107445ccd92c45367 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -10,13 +10,13 @@ module RnEnv where -- Export everything
import HsSyn
import RdrHsSyn ( RdrNameIE )
-import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isSourceQual, isUnqual, isIface,
- mkRdrUnqual, mkRdrIfaceUnqual, qualifyRdrName, lookupRdrEnv
+import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
+ mkRdrUnqual, mkRdrUnqual, qualifyRdrName, lookupRdrEnv
)
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
ImportReason(..), GlobalRdrEnv, AvailEnv,
- AvailInfo, Avails, GenAvailInfo(..), RdrAvailInfo )
+ AvailInfo, Avails, GenAvailInfo(..) )
import RnMonad
import Name ( Name, NamedThing(..),
getSrcLoc,
@@ -57,11 +57,11 @@ newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
newTopBinder mod rdr_name loc
= -- First check the cache
- traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
+ -- traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
-- There should never be a qualified name in a binding position (except in instance decls)
-- The parser doesn't check this because the same parser parses instance decls
- (if isSourceQual rdr_name then
+ (if isQual rdr_name then
qualNameErr (text "its declaration") (rdr_name,loc)
else
returnRn ()
@@ -86,7 +86,7 @@ newTopBinder mod rdr_name loc
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us, new_cache, ipcache) `thenRn_`
- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
+ -- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
returnRn new_name
-- Miss in the cache!
@@ -100,7 +100,7 @@ newTopBinder mod rdr_name loc
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us', new_cache, ipcache) `thenRn_`
- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
+ -- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
returnRn new_name
@@ -128,11 +128,11 @@ newGlobalName mod_name occ
key = (mod_name, occ)
in
case lookupFM cache key of
- Just name -> traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
+ Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
returnRn name
- Nothing -> setNameSupplyRn (us', new_cache, ipcache) `thenRn_`
- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_`
+ Nothing -> setNameSupplyRn (us', new_cache, ipcache) `thenRn_`
+ -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_`
returnRn name
where
(us', us1) = splitUniqSupply us
@@ -171,15 +171,16 @@ lookupBndrRn rdr_name
Nothing -> lookupTopBndrRn rdr_name
lookupTopBndrRn rdr_name
- | isIface rdr_name
- = lookupOrigName rdr_name
+ = getModeRn `thenRn` \ mode ->
+ case mode of
+ InterfaceMode -> lookupIfaceName rdr_name
- | otherwise -- Source mode, so look up a *qualified* version
- = -- of the name, so that we get the right one even
- -- if there are many with the same occ name
- -- There must *be* a binding
- getModuleRn `thenRn` \ mod ->
- lookupSrcGlobalOcc (qualifyRdrName (moduleName mod) rdr_name)
+ SourceMode -> -- Source mode, so look up a *qualified* version
+ -- of the name, so that we get the right one even
+ -- if there are many with the same occ name
+ -- There must *be* a binding
+ getModuleRn `thenRn` \ mod ->
+ lookupSrcGlobalOcc (qualifyRdrName (moduleName mod) rdr_name)
-- lookupSigOccRn is used for type signatures and pragmas
-- Is this valid?
@@ -208,14 +209,17 @@ lookupOccRn rdr_name
-- class op names in class and instance decls
lookupGlobalOccRn rdr_name
- | isIface rdr_name
+ | isOrig rdr_name -- Can occur in source code too
= lookupOrigName rdr_name
| otherwise
- = lookupSrcGlobalOcc rdr_name
+ = getModeRn `thenRn` \ mode ->
+ case mode of
+ SourceMode -> lookupSrcGlobalOcc rdr_name
+ InterfaceMode -> lookupIfaceUnqual rdr_name
lookupSrcGlobalOcc rdr_name
- -- Lookup a source-code rdr-name
+ -- Lookup a source-code rdr-name; may be qualified or not
= getGlobalNameEnv `thenRn` \ global_env ->
case lookupRdrEnv global_env rdr_name of
Just [(name,_)] -> returnRn name
@@ -224,6 +228,25 @@ lookupSrcGlobalOcc rdr_name
Nothing -> failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
+lookupOrigName :: RdrName -> RnM d Name
+lookupOrigName rdr_name
+ = ASSERT( isOrig rdr_name )
+ newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+
+lookupIfaceUnqual :: RdrName -> RnM d Name
+lookupIfaceUnqual rdr_name
+ = ASSERT( isUnqual rdr_name )
+ -- An Unqual is allowed; interface files contain
+ -- unqualified names for locally-defined things, such as
+ -- constructors of a data type.
+ getModuleRn `thenRn ` \ mod ->
+ newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
+
+lookupIfaceName :: RdrName -> RnM d Name
+lookupIfaceName rdr_name
+ | isUnqual rdr_name = lookupIfaceUnqual rdr_name
+ | otherwise = lookupOrigName rdr_name
+
lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name)
-- Checks that there is exactly one
lookupGlobalRn global_env rdr_name
@@ -233,7 +256,6 @@ lookupGlobalRn global_env rdr_name
returnRn (Just name)
Nothing -> returnRn Nothing
\end{code}
-%
@lookupOrigName@ takes an RdrName representing an {\em original}
name, and adds it to the occurrence pool so that it'll be loaded
@@ -255,18 +277,6 @@ whether there are any instance decls in this module are ``special''.
The name cache should have the correct provenance, though.
\begin{code}
-lookupOrigName :: RdrName -> RnM d Name
-lookupOrigName rdr_name
- = ASSERT( isIface rdr_name )
- if isQual rdr_name then
- newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
- else
- -- An Unqual is allowed; interface files contain
- -- unqualified names for locally-defined things, such as
- -- constructors of a data type.
- getModuleRn `thenRn ` \ mod ->
- newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
-
lookupOrigNames :: [RdrName] -> RnM d NameSet
lookupOrigNames rdr_names
= mapRn lookupOrigName rdr_names `thenRn` \ names ->
@@ -371,17 +381,11 @@ bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' ->
thing_inside (name':names')
bindLocalNames names enclosed_scope
- = getModeRn `thenRn` \ mode ->
- let
- -- This is gruesome, but I can't think of a better way just now
- mk_rdr_name = case mode of
- SourceMode -> mkRdrUnqual
- InterfaceMode -> mkRdrIfaceUnqual
- pairs = [(mk_rdr_name (nameOccName n), n) | n <- names]
- in
- getLocalNameEnv `thenRn` \ name_env ->
+ = getLocalNameEnv `thenRn` \ name_env ->
setLocalNameEnv (addListToRdrEnv name_env pairs)
enclosed_scope
+ where
+ pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
-------------------------------------
bindLocalRn doc rdr_name enclosed_scope
@@ -473,7 +477,7 @@ checkDupOrQualNames doc_str rdr_names_w_loc
mapRn_ (qualNameErr doc_str) quals `thenRn_`
checkDupNames doc_str rdr_names_w_loc
where
- quals = filter (isSourceQual . fst) rdr_names_w_loc
+ quals = filter (isQual . fst) rdr_names_w_loc
checkDupNames doc_str rdr_names_w_loc
= -- Check for duplicated names in a binding group
@@ -558,7 +562,7 @@ plusAvail (Avail n1) (Avail n2) = Avail n1
plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
-- Added SOF 4/97
#ifdef DEBUG
-plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
+plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
#endif
addAvail :: AvailEnv -> AvailInfo -> AvailEnv
@@ -592,13 +596,6 @@ addSysAvails :: AvailInfo -> [Name] -> AvailInfo
addSysAvails avail [] = avail
addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
--------------------------------------
-rdrAvailInfo :: AvailInfo -> RdrAvailInfo
--- Used when building the avails we are going to put in an interface file
--- We sort the components to reduce needless wobbling of interfaces
-rdrAvailInfo (Avail n) = Avail (nameOccName n)
-rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns))
-
-------------------------------------
filterAvail :: RdrNameIE -- Wanted
-> AvailInfo -- Available
@@ -649,26 +646,29 @@ groupAvails this_mod avails
-- get a canonical ordering
groupFM = foldl add emptyFM avails
- add env avail = addToFM_C combine env mod_fs [avail]
+ add env avail = addToFM_C combine env mod_fs [avail']
where
mod_fs = moduleNameFS (moduleName avail_mod)
avail_mod = case nameModule_maybe (availName avail) of
Just m -> m
Nothing -> this_mod
- combine old _ = avail:old
+ combine old _ = avail':old
+ avail' = sortAvail avail
a1 `lt` a2 = occ1 < occ2
where
occ1 = nameOccName (availName a1)
occ2 = nameOccName (availName a2)
-
--------------------------------------
-pprAvail :: AvailInfo -> SDoc
-pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
- [] -> empty
- ns' -> parens (hsep (punctuate comma (map ppr ns')))
-pprAvail (Avail n) = ppr n
+sortAvail :: AvailInfo -> AvailInfo
+-- Sort the sub-names into canonical order.
+-- The canonical order has the "main name" at the beginning
+-- (if it's there at all)
+sortAvail (Avail n) = Avail n
+sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
+ | otherwise = AvailTC n ( sortLt lt ns)
+ where
+ n1 `lt` n2 = nameOccName n1 < nameOccName n2
\end{code}
diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs
index 26f905b17a20ae880a1be576d627c0a46bfd0628..4af718ed1a6fab2c4aa633781c80c454a753193b 100644
--- a/ghc/compiler/rename/RnHiFiles.lhs
+++ b/ghc/compiler/rename/RnHiFiles.lhs
@@ -263,24 +263,6 @@ loadExports (vers, items)
loadExport :: Module -> ExportItem -> RnM d (ModuleName, Avails)
loadExport this_mod (mod, entities)
- | mod == moduleName this_mod = returnRn (mod, [])
- -- If the module exports anything defined in this module, just ignore it.
- -- Reason: otherwise it looks as if there are two local definition sites
- -- for the thing, and an error gets reported. Easiest thing is just to
- -- filter them out up front. This situation only arises if a module
- -- imports itself, or another module that imported it. (Necessarily,
- -- this invoves a loop.) Consequence: if you say
- -- module A where
- -- import B( AType )
- -- type AType = ...
- --
- -- module B( AType ) where
- -- import {-# SOURCE #-} A( AType )
- --
- -- then you'll get a 'B does not export AType' message. A bit bogus
- -- but it's a bogus thing to do!
-
- | otherwise
= mapRn (load_entity mod) entities `thenRn` \ avails ->
returnRn (mod, avails)
where
@@ -359,7 +341,7 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
free_names = extractHsTyRdrNames munged_inst_ty
in
setModuleRn mod $
- mapRn lookupOrigName free_names `thenRn` \ gate_names ->
+ mapRn lookupIfaceName free_names `thenRn` \ gate_names ->
returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts)
@@ -393,7 +375,7 @@ loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl
-- "Gate" the rule simply by whether the rule variable is
-- needed. We can refine this later.
loadRule mod decl@(IfaceRule _ _ var _ _ src_loc)
- = lookupOrigName var `thenRn` \ var_name ->
+ = lookupIfaceName var `thenRn` \ var_name ->
returnRn (unitNameSet var_name, (mod, RuleD decl))
@@ -408,7 +390,7 @@ 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 ->
+ = lookupIfaceName n `thenRn` \ name ->
traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_`
returnRn (extendNameEnv deprec_env name (name,txt))
\end{code}
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 70844a07c101e854072763c4adef8aab28da03f6..b1a9d0f8ee1a538773d1778da09852fecfd9a477 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -458,7 +458,7 @@ getSlurped
recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = (imp_mods, imp_names) })
avail
- = ASSERT2( not (isLocalName (availName avail)), pprAvail avail )
+ = ASSERT2( not (isLocalName (availName avail)), ppr avail )
ifaces { iSlurp = new_slurped_names, iVSlurp = new_vslurp }
where
main_name = availName avail
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index dd4450509fbc02c4d09079546c0b1edc52d4a634..f62fc86f3f6103758d341d688bc965dc298ebffd 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -88,9 +88,11 @@ getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc)
(source, ordinary) = partition is_source_import all_imports
is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True
is_source_import other = False
+
+ get_imports = importsFromImportDecl this_mod_name rec_unqual_fn
in
- mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
- mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
+ mapAndUnzipRn get_imports ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
+ mapAndUnzipRn get_imports source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
-- COMBINE RESULTS
-- We put the local env second, so that a local provenance
@@ -141,12 +143,13 @@ getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc)
\end{code}
\begin{code}
-importsFromImportDecl :: (Name -> Bool) -- OK to omit qualifier
+importsFromImportDecl :: ModuleName
+ -> (Name -> Bool) -- OK to omit qualifier
-> RdrNameImportDecl
-> RnMG (GlobalRdrEnv,
ExportAvails)
-importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc)
+importsFromImportDecl this_mod_name is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc)
= pushSrcLocRn iloc $
getInterfaceExports imp_mod_name from `thenRn` \ (imp_mod, avails_by_module) ->
@@ -158,7 +161,26 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i
let
avails :: Avails
- avails = concat (map snd avails_by_module)
+ avails = [ avail | (mod_name, avails) <- avails_by_module,
+ mod_name /= this_mod_name,
+ avail <- avails ]
+ -- If the module exports anything defined in this module, just ignore it.
+ -- Reason: otherwise it looks as if there are two local definition sites
+ -- for the thing, and an error gets reported. Easiest thing is just to
+ -- filter them out up front. This situation only arises if a module
+ -- imports itself, or another module that imported it. (Necessarily,
+ -- this invoves a loop.)
+ --
+ -- Tiresome consequence: if you say
+ -- module A where
+ -- import B( AType )
+ -- type AType = ...
+ --
+ -- module B( AType ) where
+ -- import {-# SOURCE #-} A( AType )
+ --
+ -- then you'll get a 'B does not export AType' message. Oh well.
+
in
filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index b3c0e8f7ff9c40becf8843b54a50d633b1426827..efeef3da288750ffc3a97688cb95fe3d82942462 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -22,7 +22,7 @@ import RnHsSyn
import HsCore
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
-import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName,
+import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, lookupIfaceName,
lookupOrigNames, lookupSysBinder, newLocalsRn,
bindLocalsFVRn, bindUVarRn,
bindTyVarsRn, bindTyVars2Rn,
@@ -168,7 +168,7 @@ rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
(case maybe_dfun_rdr_name of
Nothing -> returnRn Nothing
- Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name ->
+ Just dfun_rdr_name -> lookupIfaceName dfun_rdr_name `thenRn` \ dfun_name ->
returnRn (Just dfun_name)
) `thenRn` \ maybe_dfun_name ->