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
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 )
-- 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?
| 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}
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,
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
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
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}
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
(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}
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
-- 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}
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
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}
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
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}
mkGenOcc2,
)
import PrelNames ( negate_RDR )
-import RdrName ( RdrName, isRdrTyVar, mkRdrIfaceUnqual, rdrNameOcc,
+import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
)
import List ( nub )
import BasicTypes ( RecFlag(..) )
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
-- 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}
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,
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 }
| 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 }
--------------------------------------------------------------------------
| 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 -}
| 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] }
deprec : deprec_name STRING { ($1, $2) }
deprec_name :: { RdrName }
- : var_name { $1 }
- | tc_name { $1 }
+ : qvar_name { $1 }
+ | qtc_name { $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) }
| 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 }
: 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 : { [] }
: 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 }
---------------------------------------------------
cls_name :: { RdrName }
- : data_fs { mkRdrIfaceUnqual (mkSysOccFS clsName $1) }
+ : data_fs { mkRdrUnqual (mkSysOccFS clsName $1) }
qcls_name :: { RdrName }
: cls_name { $1 }
---------------------------------------------------
uv_name :: { RdrName }
- : VARID { mkRdrIfaceUnqual (mkSysOccFS uvName $1) }
+ : VARID { mkRdrUnqual (mkSysOccFS uvName $1) }
uv_bndr :: { RdrName }
: uv_name { $1 }
---------------------------------------------------
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 }
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)
-> 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 ->
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,
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 ()
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!
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
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
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?
-- 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
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
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
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 ->
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
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
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
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
-> Maybe AvailInfo -- Resulting available;
-- 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}
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
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)
-- "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))
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}
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
(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
\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) ->
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) ->
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,
(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 ->
projects / ghc-hetmet.git / commitdiff