From f0e42a460a3bb4857f3c4bfa92dd134fcf409849 Mon Sep 17 00:00:00 2001 From: partain Date: Wed, 10 Apr 1996 16:56:10 +0000 Subject: [PATCH] [project @ 1996-04-10 16:55:54 by partain] Sansom 1.3 changes through 960410 --- ghc/compiler/parser/hsparser.y | 44 ++++------- ghc/compiler/rename/Rename.lhs | 11 ++- ghc/compiler/rename/RnBinds.lhs | 20 ++--- ghc/compiler/rename/RnExpr.lhs | 22 +++--- ghc/compiler/rename/RnIfaces.lhs | 23 +++++- ghc/compiler/rename/RnMonad.lhs | 7 +- ghc/compiler/rename/RnNames.lhs | 24 +++--- ghc/compiler/rename/RnSource.lhs | 151 ++++++++++++++++++++++++++++++++++---- ghc/compiler/rename/RnUtils.lhs | 2 +- 9 files changed, 216 insertions(+), 88 deletions(-) diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 5e9018b..e2e9915 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -237,9 +237,7 @@ BOOLEAN inpat; gdrhs gdpat valrhs lampats cexps -%type maybeexports impas maybeimpspec deriving - -%type impspec +%type maybeexports impspec deriving %type lit_constant @@ -254,7 +252,7 @@ BOOLEAN inpat; VARID CONID VARSYM CONSYM var con varop conop op vark varid varsym varsym_nominus - tycon modid impmod ccallid + tycon modid ccallid %type QVARID QCONID QVARSYM QCONSYM qvarid qconid qvarsym qconsym @@ -284,7 +282,7 @@ BOOLEAN inpat; %type export import -%type commas impqual +%type commas /********************************************************************** * * @@ -380,32 +378,20 @@ impdecls: impdecl { $$ = $1; } ; -impdecl : importkey impqual impmod impas maybeimpspec - { - $$ = lsing(mkimport($3,$2,$4,$5,startlineno)); - } - ; - -impmod : modid { $$ = $1; } - ; - -impqual : /* noqual */ { $$ = 0; } - | QUALIFIED { $$ = 1; } - ; - -impas : /* noas */ { $$ = mknothing(); } - | AS modid { $$ = mkjust($2); } - ; - -maybeimpspec : /* empty */ { $$ = mknothing(); } - | impspec { $$ = mkjust($1); } +impdecl : importkey modid impspec + { $$ = lsing(mkimport($2,0,mknothing(),$3,startlineno)); } + | importkey QUALIFIED modid impspec + { $$ = lsing(mkimport($3,1,mknothing(),$4,startlineno)); } + | importkey QUALIFIED modid AS modid impspec + { $$ = lsing(mkimport($3,1,mkjust($5),$6,startlineno)); } ; -impspec : OPAREN CPAREN { $$ = mkleft(Lnil); } - | OPAREN import_list CPAREN { $$ = mkleft($2); } - | OPAREN import_list COMMA CPAREN { $$ = mkleft($2); } - | HIDING OPAREN import_list CPAREN { $$ = mkright($3); } - | HIDING OPAREN import_list COMMA CPAREN { $$ = mkright($3); } +impspec : /* empty */ { $$ = mknothing(); } + | OPAREN CPAREN { $$ = mkjust(mkleft(Lnil)); } + | OPAREN import_list CPAREN { $$ = mkjust(mkleft($2)); } + | OPAREN import_list COMMA CPAREN { $$ = mkjust(mkleft($2)); } + | HIDING OPAREN import_list CPAREN { $$ = mkjust(mkright($3)); } + | HIDING OPAREN import_list COMMA CPAREN { $$ = mkjust(mkright($3)); } ; import_list: diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index e116f7e..ed86172 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -19,7 +19,7 @@ import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyCon, isRnClass ) import RnMonad import RnNames ( getGlobalNames, GlobalNameInfo(..) ) import RnSource ( rnSource ) -import RnIfaces ( rnInterfaces, finalIfaceInfo, VersionInfo(..), ParsedIface ) +import RnIfaces ( findHiFiles, rnInterfaces, finalIfaceInfo, VersionInfo(..), ParsedIface ) import RnUtils ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) import MainMonad @@ -32,8 +32,7 @@ import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM ) import UniqSupply ( splitUniqSupply ) import Util ( panic, assertPanic ) -findHiFiles :: PrimIO (FiniteMap Module FAST_STRING) -findHiFiles = returnPrimIO emptyFM +opt_HiDirList = panic "opt_HiDirList" \end{code} \begin{code} @@ -63,7 +62,7 @@ ToDo: Deal with instances (instance version, this module on instance list ???) \begin{code} renameModule b_names b_keys us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) - = findHiFiles `thenPrimIO` \ hi_files -> + = findHiFiles opt_HiDirList `thenPrimIO` \ hi_files -> newVar (emptyFM, hi_files) `thenPrimIO` \ iface_var -> fixPrimIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> @@ -76,7 +75,7 @@ renameModule b_names b_keys us global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn) in getGlobalNames iface_var global_name_info us1 input - `thenPrimIO` \ (occ_env, imp_mods, imp_fixes, top_errs, top_warns) -> + `thenPrimIO` \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) -> if not (isEmptyBag top_errs) then returnPrimIO (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic) @@ -84,7 +83,7 @@ renameModule b_names b_keys us -- No top-level name errors so rename source ... case initRn True mod occ_env us2 - (rnSource imp_mods imp_fixes input) of { + (rnSource imp_mods unqual_imps imp_fixes input) of { ((rn_module, export_fn, src_occs), src_errs, src_warns) -> let diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index cab11e5..8e5cf9a 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -20,14 +20,14 @@ module RnBinds ( ) where import Ubiq -import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops +import RnLoop -- break the RnPass/RnExpr/RnBinds loops import HsSyn import HsPragmas ( isNoGenPragmas, noGenPragmas ) import RdrHsSyn import RnHsSyn import RnMonad -import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecInfixBind ) +import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch ) import CmdLineOpts ( opt_SigsRequired ) import Digraph ( stronglyConnComp ) @@ -172,10 +172,10 @@ rnMethodBinds class_name (AndMonoBinds mb1 mb2) (rnMethodBinds class_name mb2) rnMethodBinds class_name (FunMonoBind occname inf matches locn) - = pushSrcLocRn locn $ - lookupClassOp class_name occname `thenRn` \ op_name -> - mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) -> --- checkPrecInfixBind inf op_name new_matches `thenRn_` + = pushSrcLocRn locn $ + lookupClassOp class_name occname `thenRn` \ op_name -> + mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) -> + mapRn (checkPrecMatch inf op_name) new_matches `thenRn_` returnRn (FunMonoBind op_name inf new_matches locn) rnMethodBinds class_name (PatMonoBind (VarPatIn occname) grhss_and_binds locn) @@ -348,10 +348,10 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) ) flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn) - = pushSrcLocRn locn $ - lookupValue name `thenRn` \ name' -> - mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) -> --- checkPrecInfixBind inf name' new_matches `thenRn_` + = pushSrcLocRn locn $ + lookupValue name `thenRn` \ name' -> + mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) -> + mapRn (checkPrecMatch inf name') new_matches `thenRn_` let fvs = unionManyUniqSets fv_lists diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 0b024e9..9c7a1f5 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -14,11 +14,11 @@ free variables. module RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, - checkPrecInfixBind + checkPrecMatch ) where import Ubiq -import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops +import RnLoop -- break the RnPass/RnExpr/RnBinds loops import HsSyn import RdrHsSyn @@ -498,13 +498,15 @@ lookupFixity op \end{code} \begin{code} -checkPrecInfixBind :: Bool -> RnName -> [RenamedPat] -> RnM_Fixes s () +checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s () -checkPrecInfixBind False fn pats +checkPrecMatch False fn match = returnRn () -checkPrecInfixBind True op [p1,p2] +checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _))) = checkPrec op p1 False `thenRn_` checkPrec op p2 True +checkPrecMatch True op _ + = panic "checkPrecMatch" checkPrec op (ConOpPatIn _ op1 _) right = lookupFixity op `thenRn` \ (op_fix, op_prec) -> @@ -512,17 +514,15 @@ checkPrec op (ConOpPatIn _ op1 _) right getSrcLocRn `thenRn` \ src_loc -> let inf_ok = op1_prec > op_prec || - op1_prec == op_prec && - (op1_fix == INFIXR && op_fix == INFIXR && right || - op1_fix == INFIXL && op_fix == INFIXL && not right) + (op1_prec == op_prec && + (op1_fix == INFIXR && op_fix == INFIXR && right || + op1_fix == INFIXL && op_fix == INFIXL && not right)) info = (op,op_fix,op_prec) info1 = (op1,op1_fix,op1_prec) (infol, infor) = if right then (info, info1) else (info1, info) - - inf_err = precParseErr infol infor src_loc in - addErrIfRn (not inf_ok) inf_err + addErrIfRn (not inf_ok) (precParseErr infol infor src_loc) checkPrec op (NegPatIn _) right = lookupFixity op `thenRn` \ (op_fix, op_prec) -> diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 797f8aa..9745409 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -7,6 +7,7 @@ #include "HsVersions.h" module RnIfaces ( + findHiFiles, cacheInterface, readInterface, rnInterfaces, @@ -40,11 +41,29 @@ import Util ( panic ) \begin{code} type IfaceCache = MutableVar _RealWorld (FiniteMap Module ParsedIface, - FiniteMap Module FAST_STRING) + FiniteMap Module String) data ParsedIface = ParsedIface +\end{code} + +********************************************************* +* * +\subsection{Looking for interface files} +* * +********************************************************* + +\begin{code} +findHiFiles :: [String] -> PrimIO (FiniteMap Module String) +findHiFiles dirs = returnPrimIO emptyFM +\end{code} +********************************************************* +* * +\subsection{Reading interface files} +* * +********************************************************* +\begin{code} cacheInterface :: IfaceCache -> Module -> PrimIO (MaybeErr ParsedIface Error) @@ -67,7 +86,7 @@ cacheInterface iface_var mod returnPrimIO (Succeeded iface) -readInterface :: FAST_STRING -> Module +readInterface :: String -> Module -> PrimIO (MaybeErr ParsedIface Error) readInterface file mod = panic "readInterface" diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 076f7d1..c7955ae 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -20,8 +20,8 @@ module RnMonad ( rnGetUnique, rnGetUniques, newLocalNames, - lookupValue, lookupValueMaybe, - lookupTyCon, lookupClass, lookupClassOp, + lookupValue, lookupValueMaybe, lookupClassOp, + lookupTyCon, lookupClass, lookupTyConOrClass, extendSS2, extendSS, TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv, @@ -371,6 +371,9 @@ lookupTyCon rdr lookupClass rdr = lookup_tc rdr isRnClass mkRnImplicitClass "class" +lookupTyConOrClass rdr + = lookup_tc rdr (\ rn -> isRnTyCon rn || isRnClass rn) + (panic "lookupTC:mk_implicit") "class or type constructor" lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _) = case lookupTcRnEnv env rdr of diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index dcbf831..1559910 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -53,8 +53,9 @@ getGlobalNames :: -> UniqSupply -> RdrNameHsModule -> PrimIO (RnEnv, - [Module], - Bag RenamedFixityDecl, + [Module], -- directly imported modules + Bag (Module,(RnName,ExportFlag)), -- unqualified imports from module + Bag RenamedFixityDecl, -- imported fixity decls Bag Error, Bag Warning) @@ -66,7 +67,7 @@ getGlobalNames iface_var info us of { ((src_vals, src_tcs), src_errs, src_warns) -> getImportedNames iface_var info us2 imports `thenPrimIO` - \ (imp_vals, imp_tcs, imp_mods, imp_fixes, imp_errs, imp_warns) -> + \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) -> let unqual_vals = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_vals @@ -84,7 +85,7 @@ getGlobalNames iface_var info us all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs all_warns = src_warns `unionBags` imp_warns in - returnPrimIO (all_env, bagToList imp_mods, imp_fixes, all_errs, all_warns) + returnPrimIO (all_env, bagToList imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) } where (us1, us2) = splitUniqSupply us @@ -266,18 +267,19 @@ newGlobalName locn maybe_exp rdr \begin{code} getImportedNames :: IfaceCache - -> GlobalNameInfo -- builtin and knot name info + -> GlobalNameInfo -- builtin and knot name info -> UniqSupply - -> [RdrNameImportDecl] -- import declarations - -> PrimIO (Bag (RdrName,RnName), -- imported values in scope - Bag (RdrName,RnName), -- imported tycons/classes in scope - Bag Module, -- directly imported modules - Bag RenamedFixityDecl, -- fixity info for imported names + -> [RdrNameImportDecl] -- import declarations + -> PrimIO (Bag (RdrName,RnName), -- imported values in scope + Bag (RdrName,RnName), -- imported tycons/classes in scope + Bag Module, -- directly imported modules + Bag (Module,(RnName,ExportFlag)), -- unqualified imports from module + Bag RenamedFixityDecl, -- fixity info for imported names Bag Error, Bag Warning) getImportedNames iface_var info us imports - = returnPrimIO (builtin_vals, builtin_tcs, emptyBag, emptyBag, emptyBag, emptyBag) + = returnPrimIO (builtin_vals, builtin_tcs, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) where -- For now jsut add the builtin names ... (b_names,_,_,_) = info diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index edcb5fe..73cf832 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -9,7 +9,7 @@ module RnSource ( rnSource, rnPolyType ) where import Ubiq -import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking +import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking import HsSyn import HsPragmas @@ -18,20 +18,18 @@ import RnHsSyn import RnMonad import RnBinds ( rnTopBinds, rnMethodBinds ) -import Bag ( bagToList ) +import Bag ( emptyBag, unitBag, consBag, unionManyBags, listToBag, bagToList ) import Class ( derivableClassKeys ) import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) -import Name ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName ) +import Name ( Name, isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName ) import Pretty import SrcLoc ( SrcLoc ) import Unique ( Unique ) import UniqFM ( addListToUFM, listToUFM ) import UniqSet ( UniqSet(..) ) -import Util ( isn'tIn, panic, assertPanic ) +import Util ( isIn, isn'tIn, sortLt, panic, assertPanic ) -rnExports mods Nothing = returnRn (\n -> ExportAll) -rnExports mods (Just exps) = returnRn (\n -> ExportAll) \end{code} rnSource `renames' the source module and export list. @@ -49,22 +47,24 @@ Checks the (..) etc constraints in the export list. \begin{code} -rnSource :: [Module] -- imported modules +rnSource :: [Module] + -> Bag (Module,(RnName,ExportFlag)) -- unqualified imports from module -> Bag RenamedFixityDecl -- fixity info for imported names -> RdrNameHsModule -> RnM s (RenamedHsModule, Name -> ExportFlag, -- export info Bag (RnName, RdrName)) -- occurrence info -rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes - ty_decls specdata_sigs class_decls - inst_decls specinst_sigs defaults - binds _ src_loc) +rnSource imp_mods unqual_imps imp_fixes + (HsModule mod version exports _ fixes + ty_decls specdata_sigs class_decls + inst_decls specinst_sigs defaults + binds _ src_loc) = pushSrcLocRn src_loc $ - rnExports (mod:imp_mods) exports `thenRn` \ exported_fn -> - rnFixes fixes `thenRn` \ src_fixes -> + rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn -> + rnFixes fixes `thenRn` \ src_fixes -> let pair_name inf@(InfixL n _) = (n, inf) pair_name inf@(InfixR n _) = (n, inf) @@ -99,6 +99,108 @@ rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes trashed_imports = trace "rnSource:trashed_imports" [] \end{code} + +%********************************************************* +%* * +\subsection{Export list} +%* * +%********************************************************* + +\begin{code} +rnExports :: [Module] + -> Bag (Module,(RnName,ExportFlag)) + -> Maybe [RdrNameIE] + -> RnM s (Name -> ExportFlag) + +rnExports mods unqual_imps Nothing + = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported) + +rnExports mods unqual_imps (Just exps) + = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) -> + let + exp_mods = catMaybes mod_maybes + exp_names = unionManyBags exp_bags + + -- check for duplicate names + -- check for duplicate modules + + -- check for duplicate local names + -- add in module contents checking for duplicate local names + + -- build export flag lookup function + exp_fn n = if isLocallyDefined n then ExportAll else NotExported + in + returnRn exp_fn + +rnIE mods (IEVar name) + = lookupValue name `thenRn` \ rn -> + checkIEVar rn `thenRn` \ exps -> + returnRn (Nothing, exps) + where + checkIEVar (RnName n) = returnRn (unitBag (n,ExportAbs)) + checkIEVar (RnUnbound _) = returnRn emptyBag + checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc -> + failButContinueRn emptyBag (classOpExportErr rn src_loc) + checkIEVar rn = panic "checkIEVar" + +rnIE mods (IEThingAbs name) + = lookupTyConOrClass name `thenRn` \ rn -> + checkIEAbs rn `thenRn` \ exps -> + returnRn (Nothing, exps) + where + checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs)) + checkIEAbs (RnData n _) = returnRn (unitBag (n,ExportAbs)) + checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs)) + checkIEAbs (RnUnbound _) = returnRn emptyBag + checkIEAbs rn = panic "checkIEAbs" + +rnIE mods (IEThingAll name) + = lookupTyConOrClass name `thenRn` \ rn -> + checkIEAll rn `thenRn` \ exps -> + returnRn (Nothing, exps) + where + checkIEAll (RnData n cons) = returnRn (consBag (exp_all n) (listToBag (map exp_all cons))) + checkIEAll (RnClass n ops) = returnRn (consBag (exp_all n) (listToBag (map exp_all ops))) + checkIEAll (RnUnbound _) = returnRn emptyBag + checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc -> + warnAndContinueRn emptyBag (synAllExportErr rn src_loc) + checkIEAll rn = panic "checkIEAll" + + exp_all n = (n, ExportAll) + +rnIE mods (IEThingWith name names) + = lookupTyConOrClass name `thenRn` \ rn -> + mapRn lookupValue names `thenRn` \ rns -> + checkIEWith rn rns `thenRn` \ exps -> + returnRn (Nothing, exps) + where + checkIEWith rn@(RnData n cons) rns + | same_names cons rns = returnRn (consBag (exp_all n) (listToBag (map exp_all cons))) + | otherwise = rnWithErr "constructrs" rn cons rns + checkIEWith rn@(RnClass n ops) rns + | same_names ops rns = returnRn (consBag (exp_all n) (listToBag (map exp_all ops))) + | otherwise = rnWithErr "class ops" rn ops rns + checkIEWith (RnUnbound _) rns = returnRn emptyBag + checkIEWith rn@(RnSyn _) rns = getSrcLocRn `thenRn` \ src_loc -> + failButContinueRn emptyBag (synAllExportErr rn src_loc) + checkIEWith rn rns = panic "checkIEWith" + + exp_all n = (n, ExportAll) + + same_names has rns + = all (not.isRnUnbound) rns && + sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns) + + rnWithErr str rn has rns + = getSrcLocRn `thenRn` \ src_loc -> + failButContinueRn emptyBag (withExportErr str rn has rns src_loc) + +rnIE mods (IEModuleContents mod) + | isIn "IEModule" mod mods = returnRn (Just mod, emptyBag) + | otherwise = getSrcLocRn `thenRn` \ src_loc -> + failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc) +\end{code} + %********************************************************* %* * \subsection{Type declarations} @@ -492,17 +594,34 @@ rnContext tv_env ctxt \begin{code} +classOpExportErr op locn sty + = ppHang (ppStr "Class operation can only be exported with class:") + 4 (ppCat [ppr sty op, ppr sty locn]) + +synAllExportErr syn locn sty + = ppHang (ppStr "Type synonym should be exported abstractly:") + 4 (ppCat [ppr sty syn, ppr sty locn]) + +withExportErr str rn has rns locn sty + = ppHang (ppBesides [ppStr "Inconsistent list of ", ppStr str, ppStr ": ", ppr sty locn]) + 4 (ppAbove (ppCat [ppStr "expected:", ppInterleave ppComma (map (ppr sty) has)]) + (ppCat [ppStr "found: ", ppInterleave ppComma (map (ppr sty) rns)])) + +badModExportErr mod locn sty + = ppHang (ppStr "Unknown module in export list:") + 4 (ppCat [ppStr "module", ppPStr mod, ppr sty locn]) + derivingNonStdClassErr clas locn sty - = ppHang (ppStr "Non-standard class in deriving") + = ppHang (ppStr "Non-standard class in deriving:") 4 (ppCat [ppr sty clas, ppr sty locn]) dupDefaultDeclErr defs sty - = ppHang (ppStr "Duplicate default declarations") + = ppHang (ppStr "Duplicate default declarations:") 4 (ppAboves (map pp_def_loc defs)) where pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc undefinedFixityDeclErr decl sty - = ppHang (ppStr "Fixity declaration for unknown operator") + = ppHang (ppStr "Fixity declaration for unknown operator:") 4 (ppr sty decl) \end{code} diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs index 721fa8e..f2d3f05 100644 --- a/ghc/compiler/rename/RnUtils.lhs +++ b/ghc/compiler/rename/RnUtils.lhs @@ -86,7 +86,7 @@ emptyRnEnv extendGlobalRnEnv ((qual, unqual, tc_qual, tc_unqual), stack) val_list tc_list = ASSERT(isEmptyFM stack) - (((qual', unqual', tc_qual, tc_unqual), stack), tc_dups `unionBags` dups) + (((qual', unqual', tc_qual', tc_unqual'), stack), tc_dups `unionBags` dups) where (qual', unqual', dups) = extend_global qual unqual val_list (tc_qual', tc_unqual', tc_dups) = extend_global tc_qual tc_unqual tc_list -- 1.7.10.4