From 2ffefc1bfca0c8924825cd15750e7ced457f3c81 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 1 Nov 2000 17:15:30 +0000 Subject: [PATCH] [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. --- ghc/compiler/basicTypes/BasicTypes.lhs | 2 +- ghc/compiler/basicTypes/Name.lhs | 27 ++----- ghc/compiler/basicTypes/RdrName.lhs | 31 +++----- ghc/compiler/main/HscMain.lhs | 5 +- ghc/compiler/main/HscTypes.lhs | 10 +++ ghc/compiler/main/MkIface.lhs | 25 +++---- ghc/compiler/parser/RdrHsSyn.lhs | 18 ++--- ghc/compiler/rename/ParseIface.y | 69 +++++++++--------- ghc/compiler/rename/Rename.lhs | 7 +- ghc/compiler/rename/RnEnv.lhs | 122 ++++++++++++++++---------------- ghc/compiler/rename/RnHiFiles.lhs | 24 +------ ghc/compiler/rename/RnIfaces.lhs | 2 +- ghc/compiler/rename/RnNames.lhs | 32 +++++++-- ghc/compiler/rename/RnSource.lhs | 4 +- 14 files changed, 182 insertions(+), 196 deletions(-) diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 16ab432..820a3b9 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 abe6679..5888124 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 a3572ba..1d45301 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 72a4cf7..bf5857e 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 3b0444f..444a4f6 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 1873599..8540f9f 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 cc6f64c..b76c269 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 8cb756f..c141938 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 f080bd9..a54934d 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 4fc26e1..a3c31d6 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 @@ -593,13 +597,6 @@ 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 -> Maybe AvailInfo -- Resulting 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 26f905b..4af718e 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 70844a0..b1a9d0f 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 dd44505..f62fc86 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 b3c0e8f..efeef3d 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 -> -- 1.7.10.4