Commit 2ffefc1b authored by simonpj's avatar simonpj
Browse files

[project @ 2000-11-01 17:15:28 by simonpj]

More renamer commits

Versioning now works properly I think.

The main irritation is that interface files now have fuly-qualified names for
*everything*, even things defined in that module.  This is a deficiency in
the pretty printing for interface files.  Probable solution: add something
to the SDoc styles.  But not today.
parent ece274b6
......@@ -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
......
......@@ -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}
......
......@@ -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}
......
......@@ -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
......
......@@ -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}
......
......@@ -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}
......@@ -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}
......
......@@ -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 }
......
......@@ -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 ->
......
......@@ -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 )