From: partain Date: Thu, 25 Apr 1996 13:03:40 +0000 (+0000) Subject: [project @ 1996-04-25 13:02:32 by partain] X-Git-Tag: Approximately_1000_patches_recorded~922 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=4250d64191132fd493985549eda5ca05b82a663f;p=ghc-hetmet.git [project @ 1996-04-25 13:02:32 by partain] Sansom 1.3 changes to 960425 --- diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile index 4019707..cd0bb3c 100644 --- a/ghc/compiler/Jmakefile +++ b/ghc/compiler/Jmakefile @@ -594,15 +594,15 @@ compile(main/MkIface,lhs,) compile(nativeGen/AbsCStixGen,lhs,) compile(nativeGen/AsmCodeGen,lhs,-I$(COMPINFO_DIR)) compile(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR)) -compile(nativeGen/MachCode,lhs,) -compile(nativeGen/MachMisc,lhs,) -compile(nativeGen/MachRegs,lhs,) -compile(nativeGen/PprMach,lhs,) -compile(nativeGen/RegAllocInfo,lhs,) +compile(nativeGen/MachCode,lhs,-I$(NATIVEGEN_DIR)) +compile(nativeGen/MachMisc,lhs,-I$(NATIVEGEN_DIR)) +compile(nativeGen/MachRegs,lhs,-I$(NATIVEGEN_DIR)) +compile(nativeGen/PprMach,lhs,-I$(NATIVEGEN_DIR)) +compile(nativeGen/RegAllocInfo,lhs,-I$(NATIVEGEN_DIR)) compile(nativeGen/Stix,lhs,) -compile(nativeGen/StixInfo,lhs,-I$(NATIVEGEN_DIR)) +compile(nativeGen/StixInfo,lhs,) compile(nativeGen/StixInteger,lhs,) -compile(nativeGen/StixMacro,lhs,-I$(NATIVEGEN_DIR)) +compile(nativeGen/StixMacro,lhs,) compile(nativeGen/StixPrim,lhs,) #endif diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index b48d5e2..7815d7d 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -1013,7 +1013,11 @@ getIdNamePieces show_uniqs id TupleConId n _ -> [nameOf (origName n)] - RecordSelId lbl -> panic "getIdNamePieces:RecordSelId" + RecordSelId lbl -> + let n = fieldLabelName lbl + in + case (moduleNamePair n) of { (mod, name) -> + if isPreludeDefinedName n then [name] else [mod, name] } ImportedId n -> get_fullname_pieces n PreludeId n -> get_fullname_pieces n diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 3adfab1..3d12059 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -33,6 +33,7 @@ outPatType (ConPat _ ty _) = ty outPatType (ConOpPat _ _ _ ty) = ty outPatType (ListPat ty _) = mkListTy ty outPatType (TuplePat pats) = mkTupleTy (length pats) (map outPatType pats) +outPatType (RecPat _ ty _) = ty outPatType (LitPat lit ty) = ty outPatType (NPat lit ty _) = ty outPatType (DictPat ds ms) = case (length ds + length ms) of diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 93aa0e3..bc64534 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -57,8 +57,11 @@ data HsExpr tyvar uvar id pat (HsExpr tyvar uvar id pat) -- right operand -- We preserve prefix negation and parenthesis for the precedence parser. + -- They are eventually removed by the type checker. | NegApp (HsExpr tyvar uvar id pat) -- negated expr + id -- the negate id + | HsPar (HsExpr tyvar uvar id pat) -- parenthesised expr | SectionL (HsExpr tyvar uvar id pat) -- operand @@ -224,7 +227,7 @@ pprExpr sty (OpApp e1 op e2) pp_infixly v = ppSep [pp_e1, ppCat [pprSym sty v, pp_e2]] -pprExpr sty (NegApp e) +pprExpr sty (NegApp e _) = ppBeside (ppChar '-') (pprParendExpr sty e) pprExpr sty (HsPar e) @@ -401,8 +404,8 @@ pp_rbinds sty thing rbinds = ppHang thing 4 (ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}']) where - pp_rbind sty (v, _, True{-pun-}) = ppr sty v - pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "<-", ppr sty e] + pp_rbind PprForUser (v, _, True) = ppr PprForUser v + pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "=", ppr sty e] \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 0161813..d7efe59 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -88,7 +88,7 @@ data OutPat tyvar uvar id | RecPat Id -- record constructor (GenType tyvar uvar) -- the type of the pattern - [(id, OutPat tyvar uvar id, Bool)] -- True <=> source used punning + [(Id, OutPat tyvar uvar id, Bool)] -- True <=> source used punning | LitPat -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. @@ -103,7 +103,7 @@ data OutPat tyvar uvar id (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- of type t -> Bool; detects match - | DictPat -- Used when destructing Dictionaries with an explicit case + | DictPat -- Used when destructing Dictionaries with an explicit case [id] -- superclass dicts [id] -- methods \end{code} @@ -153,10 +153,10 @@ pprInPat sty (TuplePatIn pats) = ppBesides [ppLparen, interpp'SP sty pats, ppRparen] pprInPat sty (RecPatIn con rpats) - = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}'] + = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}'] where - pp_rpat (v, _, True{-pun-}) = ppr sty v - pp_rpat (v, p, _) = ppCat [ppr sty v, ppStr "<-", ppr sty p] + pp_rpat PprForUser (v, _, True) = ppr PprForUser v + pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p] \end{code} \begin{code} @@ -191,10 +191,10 @@ pprOutPat sty (TuplePat pats) = ppBesides [ppLparen, interpp'SP sty pats, ppRparen] pprOutPat sty (RecPat con ty rpats) - = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}'] + = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}'] where --- pp_rpat (v, _, True{-pun-}) = ppr sty v - pp_rpat (v, p, _) = ppBesides [ppr sty v, ppStr "<-", ppr sty p] + pp_rpat PprForUser (v, _, True) = ppr PprForUser v + pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p] pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more @@ -293,14 +293,15 @@ collected is important; see @HsBinds.lhs@. \begin{code} collectPatBinders :: InPat a -> [a] -collectPatBinders (VarPatIn var) = [var] -collectPatBinders (LazyPatIn pat) = collectPatBinders pat -collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat -collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) +collectPatBinders WildPatIn = [] +collectPatBinders (VarPatIn var) = [var] +collectPatBinders (LazyPatIn pat) = collectPatBinders pat +collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat +collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2 -collectPatBinders (NegPatIn pat) = collectPatBinders pat -collectPatBinders (ParPatIn pat) = collectPatBinders pat -collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats) -collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats) -collectPatBinders any_other_pat = [ {-no binders-} ] +collectPatBinders (NegPatIn pat) = collectPatBinders pat +collectPatBinders (ParPatIn pat) = collectPatBinders pat +collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats) +collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats) +collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields) \end{code} diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 918a24c..b96f1a2 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -109,7 +109,7 @@ doIt (core_cmds, stg_cmds) input_pgm of { (wiredin_fm, key_fm, idinfo_fm) -> renameModule wiredin_fm key_fm rn_uniqs rdr_module `thenMn` - \ (rn_mod, import_names, + \ (rn_mod, rn_env, import_names, version_info, instance_modules, rn_errs_bag, rn_warns_bag) -> @@ -137,10 +137,7 @@ doIt (core_cmds, stg_cmds) input_pgm -- ******* TYPECHECKER show_pass "TypeCheck" `thenMn_` - let - rn_info = trace "Main.rn_info" (\ x -> Nothing, \ x -> Nothing) - in - case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_info rn_mod) of + case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of Succeeded (stuff, warns) -> (emptyBag, warns, stuff) Failed (errs, warns) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 8cd4e60..a8af666 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -341,10 +341,11 @@ generic_pair thing do_fixity :: -> RenamedFixityDecl -> Pretty do_fixity fixity_decl - = case (getExportFlag (get_name fixity_decl)) of - ExportAll -> ppr PprInterface fixity_decl - _ -> ppNil + = case (isLocallyDefined name, getExportFlag name) of + (True, ExportAll) -> ppr PprInterface fixity_decl + _ -> ppNil where + name = get_name fixity_decl get_name (InfixL n _) = n get_name (InfixR n _) = n get_name (InfixN n _) = n diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 710e254..460893a 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -433,6 +433,5 @@ class_op_keys , (SLIT("enumFromTo"), enumFromToClassOpKey) , (SLIT("enumFromThenTo"), enumFromThenToClassOpKey) , (SLIT("=="), eqClassOpKey) --- , (SLIT(">="), geClassOpKey) ]] \end{code} diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 0fbd15b..74cf5d8 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -308,7 +308,7 @@ wlkExpr expr U_negate nexp -> -- prefix negation wlkExpr nexp `thenUgn` \ expr -> - returnUgn (NegApp expr) + returnUgn (NegApp expr (Unqual SLIT("negate")) ) U_llist llist -> -- explicit list wlkList rdExpr llist `thenUgn` \ exprs -> @@ -899,10 +899,9 @@ rdEntity pt -- with specified constrs/methods wlkQid x `thenUgn` \ thing -> wlkList rdQid ns `thenUgn` \ names -> - returnUgn (IEThingAll thing) - -- returnUgn (IEThingWith thing names) + returnUgn (IEThingWith thing names) - U_entmod mod -> -- everything provided by a module + U_entmod mod -> -- everything provided unqualified by a module returnUgn (IEModuleContents mod) \end{code} diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs index 5927136..6701b7a 100644 --- a/ghc/compiler/rename/ParseUtils.lhs +++ b/ghc/compiler/rename/ParseUtils.lhs @@ -57,11 +57,11 @@ data ParsedIface ----------------------------------------------------------------- data RdrIfaceDecl - = TypeSig RdrName SrcLoc RdrNameTyDecl - | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl - | DataSig RdrName [RdrName] SrcLoc RdrNameTyDecl - | ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl - | ValSig RdrName SrcLoc RdrNamePolyType + = TypeSig RdrName SrcLoc RdrNameTyDecl + | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl + | DataSig RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl + | ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl + | ValSig RdrName SrcLoc RdrNamePolyType data RdrIfaceInst = InstSig RdrName RdrName SrcLoc RdrNameInstDecl @@ -151,14 +151,18 @@ mk_data :: RdrNameContext mk_data ctxt (qtycon, tyvars) names_and_constrs = let (qconnames, constrs) = unzip names_and_constrs - tycon = de_qual qtycon - connames = map de_qual qconnames - qtyvars = map Unqual tyvars + qfieldnames = [] -- ToDo ... + tycon = de_qual qtycon + connames = map de_qual qconnames + fieldnames = map de_qual qfieldnames + qtyvars = map Unqual tyvars - decl = DataSig qtycon qconnames mkIfaceSrcLoc ( + decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc ( TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc) in - (unitFM tycon decl, listToFM [(c,decl) | c <- connames]) + (unitFM tycon decl, listToFM [(c,decl) | c <- connames] + `plusFM` + listToFM [(f,decl) | f <- fieldnames]) mk_new :: RdrNameContext -> (RdrName, [FAST_STRING]) diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 8fcc75e..a066cf0 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -31,7 +31,7 @@ import RnMonad import RnNames ( getGlobalNames, GlobalNameInfo(..) ) import RnSource ( rnSource ) import RnIfaces ( findHiFiles, rnIfaces, finalIfaceInfo, VersionInfo(..) ) -import RnUtils ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) +import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) import MainMonad import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) @@ -54,6 +54,7 @@ renameModule :: BuiltinNames -> RdrNameHsModule -> IO (RenamedHsModule, -- output, after renaming + RnEnv, -- final env (for renaming derivings) [Module], -- imported modules; for profiling VersionInfo, -- version info; for usage @@ -64,7 +65,6 @@ renameModule :: BuiltinNames \end{code} ToDo: May want to arrange to return old interface for this module! -ToDo: Return OrigName RnEnv to rename derivings etc with. ToDo: Builtin names which must be read. ToDo: Deal with instances (instance version, this module on instance list ???) @@ -129,7 +129,7 @@ renameModule b_names b_keys us }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) -> if not (isEmptyBag errs_so_far) then - return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far) + return (rn_panic, rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far) else -- No errors renaming source so rename the interfaces ... @@ -139,17 +139,18 @@ renameModule b_names b_keys us -- We also divide by tycon/class and value names (as usual). occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ] - -- all occurrence names, from this module and imported + -- all occurrence names, from this module and imported (defined_here, defined_elsewhere) = partition isLocallyDefined occ_rns - (_, imports_used) = partition isRnWired defined_elsewhere + (_, imports_used) + = partition isRnWired defined_elsewhere (def_tcs, def_vals) = partition isRnTyConOrClass defined_here (occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns - -- the occ stuff includes *all* occurrences, - -- including those for which we have definitions + -- the occ stuff includes *all* occurrences, + -- including those for which we have definitions (orig_def_env, orig_def_dups) = extendGlobalRnEnv emptyRnEnv (map pair_orig def_vals) @@ -160,32 +161,36 @@ renameModule b_names b_keys us pair_orig rn = (origName rn, rn) - must_haves -- everything in the BuiltinKey table; as we *may* need these - -- later, we'd better bring their definitions in - = catMaybes [ mk_key_name str name_fn u | (str, (u, name_fn)) <- fmToList b_keys ] - where - mk_key_name str name_fn u - = -- this is emphatically *not* the Right Way to do this... (WDP 96/04) - if (str == SLIT("main") || str == SLIT("mainPrimIO")) then - Nothing - else - Just (name_fn (mkBuiltinName u pRELUDE str)) + -- we must ensure that the definitions of things in the BuiltinKey + -- table which may be *required* by the typechecker etc are read. + + must_haves + = [ name_fn (mkBuiltinName u pRELUDE str) + | (str, (u, name_fn)) <- fmToList b_keys, + str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ] in ASSERT (isEmptyBag orig_occ_dups) ASSERT (isEmptyBag orig_def_dups) - rnIfaces iface_cache us3 orig_def_env orig_occ_env rn_module (imports_used ++ must_haves) >>= - \ (rn_module_with_imports, (implicit_val_fm, implicit_tc_fm), iface_errs, iface_warns) -> + rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env + rn_module (must_haves ++ imports_used) >>= + \ (rn_module_with_imports, final_env, + (implicit_val_fm, implicit_tc_fm), + (iface_errs, iface_warns)) -> let - all_imports_used = bagToList (unionManyBags [listToBag imports_used, - listToBag (eltsFM implicit_tc_fm), - listToBag (eltsFM implicit_val_fm)]) + all_imports_used = imports_used ++ eltsFM implicit_tc_fm + ++ eltsFM implicit_val_fm in finalIfaceInfo iface_cache all_imports_used imp_mods >>= \ (version_info, instance_mods) -> - return (rn_module_with_imports, imp_mods, version_info, instance_mods, - errs_so_far `unionBags` iface_errs, warns_so_far `unionBags` iface_warns) + return (rn_module_with_imports, + final_env, + imp_mods, + version_info, + instance_mods, + errs_so_far `unionBags` iface_errs, + warns_so_far `unionBags` iface_warns) where rn_panic = panic "renameModule: aborted with errors" @@ -237,13 +242,16 @@ pprRdrIfaceDecl (TypeSig tc _ decl) = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl] pprRdrIfaceDecl (NewTypeSig tc dc _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc, ppStr "; ", ppr PprDebug decl] + = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc, + ppStr "; ", ppr PprDebug decl] -pprRdrIfaceDecl (DataSig tc dcs _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs, ppStr "; ", ppr PprDebug decl] +pprRdrIfaceDecl (DataSig tc dcs dfs _ decl) + = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs, + ppStr "; fields=", ppr PprDebug dfs, ppStr "; ", ppr PprDebug decl] pprRdrIfaceDecl (ClassSig c ops _ decl) - = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops, ppStr "; ", ppr PprDebug decl] + = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops, + ppStr "; ", ppr PprDebug decl] pprRdrIfaceDecl (ValSig f _ ty) = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty] diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 19110b8..cfb377d 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -25,14 +25,14 @@ import RdrHsSyn import RnHsSyn import RnMonad -import ErrUtils ( addErrLoc ) +import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name ( isLocallyDefinedName, pprSym, Name, RdrName ) import Pretty import UniqFM ( lookupUFM ) import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, UniqSet(..) ) -import Util ( Ord3(..), panic ) +import Util ( Ord3(..), removeDups, panic ) \end{code} @@ -58,20 +58,20 @@ rnPat (LazyPatIn pat) returnRn (LazyPatIn pat') rnPat (AsPatIn name pat) - = rnPat pat `thenRn` \ pat' -> + = rnPat pat `thenRn` \ pat' -> lookupValue name `thenRn` \ vname -> returnRn (AsPatIn vname pat') -rnPat (ConPatIn name pats) - = lookupValue name `thenRn` \ name' -> +rnPat (ConPatIn con pats) + = lookupConstr con `thenRn` \ con' -> mapRn rnPat pats `thenRn` \ patslist -> - returnRn (ConPatIn name' patslist) + returnRn (ConPatIn con' patslist) -rnPat (ConOpPatIn pat1 name pat2) - = lookupValue name `thenRn` \ name' -> +rnPat (ConOpPatIn pat1 con pat2) + = lookupConstr con `thenRn` \ con' -> rnPat pat1 `thenRn` \ pat1' -> rnPat pat2 `thenRn` \ pat2' -> - precParsePat (ConOpPatIn pat1' name' pat2') + precParsePat (ConOpPatIn pat1' con' pat2') rnPat neg@(NegPatIn pat) = getSrcLocRn `thenRn` \ src_loc -> @@ -97,8 +97,9 @@ rnPat (TuplePatIn pats) returnRn (TuplePatIn patslist) rnPat (RecPatIn con rpats) - = panic "rnPat:RecPatIn" - + = lookupConstr con `thenRn` \ con' -> + rnRpats rpats `thenRn` \ rpats' -> + returnRn (RecPatIn con' rpats') \end{code} ************************************************************************ @@ -194,15 +195,16 @@ ToDo: what about RnClassOps ??? \end{itemize} \begin{code} +fv_set vname@(RnName n) | isLocallyDefinedName n + = unitUniqSet vname +fv_set _ = emptyUniqSet + + rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars) rnExpr (HsVar v) = lookupValue v `thenRn` \ vname -> returnRn (HsVar vname, fv_set vname) - where - fv_set vname@(RnName n) - | isLocallyDefinedName n = unitUniqSet vname - fv_set _ = emptyUniqSet rnExpr (HsLit lit) = returnRn (HsLit lit, emptyUniqSet) @@ -223,9 +225,10 @@ rnExpr (OpApp e1 op e2) precParseExpr (OpApp e1' op' e2') `thenRn` \ exp -> returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2) -rnExpr (NegApp e) +rnExpr (NegApp e n) = rnExpr e `thenRn` \ (e', fvs_e) -> - returnRn (NegApp e', fvs_e) + lookupValue n `thenRn` \ nname -> + returnRn (NegApp e' nname, fvs_e `unionUniqSets` fv_set nname) rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -278,10 +281,15 @@ rnExpr (ExplicitTuple exps) = rnExprs exps `thenRn` \ (exps', fvExps) -> returnRn (ExplicitTuple exps', fvExps) -rnExpr (RecordCon con rbinds) - = panic "rnExpr:RecordCon" -rnExpr (RecordUpd exp rbinds) - = panic "rnExpr:RecordUpd" +rnExpr (RecordCon (HsVar con) rbinds) + = lookupConstr con `thenRn` \ conname -> + rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) -> + returnRn (RecordCon (HsVar conname) rbinds', fvRbinds) + +rnExpr (RecordUpd expr rbinds) + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) -> + returnRn (RecordUpd expr' rbinds', fvExpr `unionUniqSets` fvRbinds) rnExpr (ExprWithTySig expr pty) = rnExpr expr `thenRn` \ (expr', fvExpr) -> @@ -319,7 +327,43 @@ rnExpr (ArithSeqIn seq) rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> returnRn (FromThenTo expr1' expr2' expr3', unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3]) +\end{code} +%************************************************************************ +%* * +\subsubsection{@Rbinds@s and @Rpats@s: in record expressions} +%* * +%************************************************************************ + +\begin{code} +rnRbinds str rbinds + = mapRn field_dup_err dup_fields `thenRn_` + mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) -> + returnRn (rbinds', unionManyUniqSets fvRbind_s) + where + (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ] + + field_dup_err dups = getSrcLocRn `thenRn` \ src_loc -> + addErrRn (dupFieldErr str src_loc dups) + + rn_rbind (field, expr, pun) + = lookupField field `thenRn` \ fieldname -> + rnExpr expr `thenRn` \ (expr', fvExpr) -> + returnRn ((fieldname, expr', pun), fvExpr) + +rnRpats rpats + = mapRn field_dup_err dup_fields `thenRn_` + mapRn rn_rpat rpats + where + (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ] + + field_dup_err dups = getSrcLocRn `thenRn` \ src_loc -> + addErrRn (dupFieldErr "pattern" src_loc dups) + + rn_rpat (field, pat, pun) + = lookupField field `thenRn` \ fieldname -> + rnPat pat `thenRn` \ pat' -> + returnRn (fieldname, pat', pun) \end{code} %************************************************************************ @@ -428,13 +472,13 @@ rnStmt (LetStmt binds) precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr precParsePat :: RenamedPat -> RnM_Fixes s RenamedPat -precParseExpr exp@(OpApp (NegApp e1) (HsVar op) e2) +precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2) = lookupFixity op `thenRn` \ (op_fix, op_prec) -> if 6 < op_prec then -- negate precedence 6 wired in -- (-x)*y ==> -(x*y) precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app -> - returnRn (NegApp op_app) + returnRn (NegApp op_app n) else returnRn exp @@ -534,9 +578,13 @@ checkPrec op pat right \end{code} \begin{code} +dupFieldErr str src_loc (dup:rest) + = addShortErrLocLine src_loc (\ sty -> + ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str]) + negPatErr pat src_loc - = addErrLoc src_loc "prefix `-' not applied to literal in pattern" ( \sty -> - ppr sty pat) + = addShortErrLocLine src_loc (\ sty -> + ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat]) precParseNegPatErr op src_loc = addErrLoc src_loc "precedence parsing error" (\ sty -> diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 8e4d0d1..4e1f517 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -30,16 +30,17 @@ import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} ) data RnName = WiredInId Id | WiredInTyCon TyCon - | RnName Name -- functions/binders/tyvars - | RnSyn Name -- type synonym - | RnData Name [Name] -- data type (with constrs) - | RnConstr Name Name -- constructor (with data type) - | RnClass Name [Name] -- class (with class ops) - | RnClassOp Name Name -- class op (with class) - | RnImplicit Name -- implicitly imported - | RnImplicitTyCon Name -- implicitly imported - | RnImplicitClass Name -- implicitly imported - | RnUnbound RdrName -- place holder + | RnName Name -- functions/binders/tyvars + | RnSyn Name -- type synonym + | RnData Name [Name] [Name] -- data type (with constrs and fields) + | RnConstr Name Name -- constructor (with data type) + | RnField Name Name -- field (with data type) + | RnClass Name [Name] -- class (with class ops) + | RnClassOp Name Name -- class op (with class) + | RnImplicit Name -- implicitly imported + | RnImplicitTyCon Name -- implicitly imported + | RnImplicitClass Name -- implicitly imported + | RnUnbound RdrName -- place holder mkRnName = RnName mkRnImplicit = RnImplicit @@ -54,10 +55,9 @@ isRnWired _ = False isRnLocal (RnName n) = isLocalName n isRnLocal _ = False - isRnTyCon (WiredInTyCon _) = True isRnTyCon (RnSyn _) = True -isRnTyCon (RnData _ _) = True +isRnTyCon (RnData _ _ _) = True isRnTyCon (RnImplicitTyCon _) = True isRnTyCon _ = False @@ -68,14 +68,19 @@ isRnClass _ = False -- a common need: isRnTyCon || isRnClass: isRnTyConOrClass (WiredInTyCon _) = True isRnTyConOrClass (RnSyn _) = True -isRnTyConOrClass (RnData _ _) = True +isRnTyConOrClass (RnData _ _ _) = True isRnTyConOrClass (RnImplicitTyCon _) = True isRnTyConOrClass (RnClass _ _) = True isRnTyConOrClass (RnImplicitClass _) = True isRnTyConOrClass _ = False +isRnConstr (RnConstr _ _) = True +isRnConstr _ = False + +isRnField (RnField _ _) = True +isRnField _ = False + isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls -isRnClassOp cls (RnImplicit _) = True -- ho hummm ... isRnClassOp cls _ = False isRnImplicit (RnImplicit _) = True @@ -106,8 +111,9 @@ instance NamedThing RnName where getName (WiredInTyCon tc) = getName tc getName (RnName n) = n getName (RnSyn n) = n - getName (RnData n _) = n + getName (RnData n _ _) = n getName (RnConstr n _) = n + getName (RnField n _) = n getName (RnClass n _) = n getName (RnClassOp n _) = n getName (RnImplicit n) = n @@ -122,10 +128,11 @@ instance NamedThing RnName where instance Outputable RnName where #ifdef DEBUG - ppr sty@PprShowAll (RnData n cs) = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppStr "-}"] - ppr sty@PprShowAll (RnConstr n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"] - ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"] - ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"] + ppr sty@PprShowAll (RnData n cs fs) = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppr sty fs, ppStr "-}"] + ppr sty@PprShowAll (RnConstr n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"] + ppr sty@PprShowAll (RnField n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"] + ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"] + ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"] #endif ppr sty (WiredInId id) = ppr sty id ppr sty (WiredInTyCon tycon)= ppr sty tycon diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 063bfbc..3327af9 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -29,16 +29,15 @@ import RnHsSyn import RnMonad import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) -import RnUtils ( RnEnv(..), lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv ) +import RnUtils ( RnEnv(..), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv ) import ParseIface ( parseIface ) import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) ) -import Bag ( emptyBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList ) +import Bag ( emptyBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList ) import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix ) import ErrUtils ( Error(..), Warning(..) ) -import FiniteMap ( emptyFM, lookupFM, addToFM, plusFM, eltsFM, - fmToList, delListFromFM, keysFM{-ToDo:rm-} - ) +import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM, + fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-} ) import Maybes ( maybeToBool ) import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..){-instance NamedThing-} @@ -50,7 +49,8 @@ import Pretty import Maybes ( MaybeErr(..) ) import UniqFM ( emptyUFM ) import UniqSupply ( splitUniqSupply ) -import Util ( startsWith, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} ) +import Util ( sortLt, removeDups, cmpPString, startsWith, + panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} ) \end{code} \begin{code} @@ -206,7 +206,7 @@ cachedDeclByType iface_cache rn RnUnbound _ -> pprPanic "cachedDeclByType:" (ppr PprDebug rn) RnSyn _ -> return_maybe_decl - RnData _ _ -> return_maybe_decl + RnData _ _ _ -> return_maybe_decl RnImplicitTyCon _ -> if is_tycon_decl if_decl then return_maybe_decl else return_failed (badIfaceLookupErr "type constructor" rn if_decl) @@ -216,25 +216,26 @@ cachedDeclByType iface_cache rn then return_maybe_decl else return_failed (badIfaceLookupErr "class" rn if_decl) - RnName _ -> return_maybe_decl - RnConstr _ _ -> return_maybe_decl - RnClassOp _ _ -> return_maybe_decl - RnImplicit _ -> if is_val_decl if_decl - then return_maybe_decl - else return_failed (badIfaceLookupErr "value/method" rn if_decl) + RnName _ -> return_maybe_decl + RnConstr _ _ -> return_maybe_decl + RnField _ _ -> return_maybe_decl + RnClassOp _ _ -> return_maybe_decl + RnImplicit _ -> if is_val_decl if_decl + then return_maybe_decl + else return_failed (badIfaceLookupErr "value" rn if_decl) where is_tycon_decl (TypeSig _ _ _) = True is_tycon_decl (NewTypeSig _ _ _ _) = True - is_tycon_decl (DataSig _ _ _ _) = True + is_tycon_decl (DataSig _ _ _ _ _) = True is_tycon_decl _ = False is_class_decl (ClassSig _ _ _ _) = True is_class_decl _ = False is_val_decl (ValSig _ _ _) = True - is_val_decl (ClassSig _ _ _ _) = True -- if the thing we were after *happens* to - -- be a class op; we will have fished a ClassSig - -- out of the interface for it. + is_val_decl (DataSig _ _ _ _ _) = True -- may be a constr or field + is_val_decl (NewTypeSig _ _ _ _) = True -- may be a constr + is_val_decl (ClassSig _ _ _ _) = True -- may be a method is_val_decl _ = False \end{code} @@ -252,6 +253,7 @@ readIface file mod \begin{code} rnIfaces :: IfaceCache -- iface cache (mutvar) + -> [Module] -- directly imported modules -> UniqSupply -> RnEnv -- defined (in the source) name env -> RnEnv -- mentioned (in the source) name env @@ -261,18 +263,19 @@ rnIfaces :: IfaceCache -- iface cache (mutvar) -- Also, all the things we may look up -- later by key (Unique). -> IO (RenamedHsModule, -- extended module + RnEnv, -- final env (for renaming derivings) ImplicitEnv, -- implicit names used (for usage info) - Bag Error, - Bag Warning) + (Bag Error, Bag Warning)) -rnIfaces iface_cache us +rnIfaces iface_cache imp_mods us def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack) occ_env@((qual, unqual, tc_qual, tc_unqual), stack) rn_module@(HsModule modname iface_version exports imports fixities typedecls typesigs classdecls instdecls instsigs defdecls binds sigs src_loc) todo - = {-pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $ + = {- + pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $ pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM qual]) $ pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ @@ -284,27 +287,16 @@ rnIfaces iface_cache us pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dtc_qual]) $ pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $ -} - let - (us1,us2) = splitUniqSupply us - in - - -- do transitive closure to bring in all needed names/defns: - loop todo -- initial batch of names to process - (def_env, occ_env, us1) -- init stuff down - empty_return -- init acc results - >>= \ (((if_typedecls, if_classdecls, if_sigs), - if_implicits, - (if_errs, if_warns)), - new_occ_env) -> + -- do transitive closure to bring in all needed names/defns and insts: - -- go back and handle instance things: + decls_and_insts todo def_env occ_env empty_return us + >>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs), + if_implicits, + if_errs_warns), + if_final_env) -> - rnIfaceInstStuff iface_cache modname us2 new_occ_env if_implicits - >>= \ (if_instdecls, (ifi_errs, ifi_warns)) -> - - return ( - HsModule modname iface_version exports imports fixities + return (HsModule modname iface_version exports imports fixities (typedecls ++ if_typedecls) typesigs (classdecls ++ if_classdecls) @@ -312,58 +304,104 @@ rnIfaces iface_cache us instsigs defdecls binds (sigs ++ if_sigs) src_loc, - if_implicits, - if_errs `unionBags` ifi_errs, - if_warns `unionBags` ifi_warns - ) + if_final_env, + if_implicits, + if_errs_warns) where - loop :: [RnName] -- Names we're looking for; we keep adding/deleting - -- from this list; we're done when empty (nothing - -- more needs to be looked for) - -> Go_Down -- see defn below - -> To_Return -- accumulated result - -> IO (To_Return, RnEnv{-final occurrence env; to pass on for doing instances-}) + decls_and_insts todo def_env occ_env to_return us + = do_decls todo -- initial batch of names to process + (def_env, occ_env, us1) -- init stuff down + to_return -- acc results + >>= \ (decls_return, + decls_def_env, + decls_occ_env) -> + + cacheInstModules iface_cache imp_mods >>= \ errs -> + + do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM + (add_errs errs decls_return) us2 + where + (us1,us2) = splitUniqSupply us + + do_insts def_env occ_env prev_env done_insts to_return us + | size_tc_env occ_env == size_tc_env prev_env + = return (to_return, occ_env) + + | otherwise + = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return + >>= \ (insts_return, + new_insts, + insts_occ_env, + new_unknowns) -> + + do_decls new_unknowns -- new batch of names to process + (def_env, insts_occ_env, us2) -- init stuff down + insts_return -- acc results + >>= \ (decls_return, + decls_def_env, + decls_occ_env) -> + + do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3 + where + (us1,us') = splitUniqSupply us + (us2,us3) = splitUniqSupply us' + + size_tc_env ((_, _, qual, unqual), _) + = sizeFM qual + sizeFM unqual - loop to_find@[] down to_return = return (to_return, occenv down) - loop to_find@(n:ns) down to_return - = case (lookup_defd down (origName n)) of + do_decls :: [RnName] -- Names we're looking for; we keep adding/deleting + -- from this list; we're done when empty (nothing + -- more needs to be looked for) + -> Go_Down -- see defn below + -> To_Return -- accumulated result + -> IO (To_Return, + RnEnv, -- extended decl env + RnEnv) -- extended occ env + + do_decls to_find@[] down to_return + = return (to_return, defenv down, occenv down) + + do_decls to_find@(n:ns) down to_return + = case (lookup_defd down n) of Just _ -> -- previous processing must've found the stuff for this name; -- continue with the rest: - -- pprTrace "loop:done:" (ppr PprDebug n) $ - loop ns down to_return + -- pprTrace "do_decls:done:" (ppr PprDebug n) $ + do_decls ns down to_return Nothing -> -- OK, see what the cache has for us... cachedDeclByType iface_cache n >>= \ maybe_ans -> case maybe_ans of Failed err -> -- add the error, but keep going: - -- pprTrace "loop:cache error:" (ppr PprDebug n) $ - loop ns down (add_err err to_return) + -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $ + do_decls ns down (add_err err to_return) Succeeded iface_decl -> -- something needing renaming! let (us1, us2) = splitUniqSupply (uniqsupply down) in case (initRn False{-iface-} modname (occenv down) us1 ( - setExtraRn emptyUFM{-ignore fixities-} $ + setExtraRn emptyUFM{-no fixities-} $ rnIfaceDecl iface_decl)) of { ((if_decl, if_defd, if_implicits), if_errs, if_warns) -> let new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits) in --- pprTrace "loop:renamed:" (ppAboves [ppr PprDebug n --- , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns] --- , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ] --- , ppCat [ppStr "defd tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ] --- ]) $ - loop (new_unknowns ++ ns) - (add_occs if_defd if_implicits $ - new_uniqsupply us2 down) - (add_decl if_decl $ - add_implicits if_implicits $ - add_errs if_errs $ - add_warns if_warns to_return) + {- + pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n + , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns] + , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ] + , ppCat [ppStr "defd tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ] + ]) $ + -} + do_decls (new_unknowns ++ ns) + (add_occs if_defd if_implicits $ + new_uniqsupply us2 down) + (add_decl if_decl $ + add_implicits if_implicits $ + add_errs if_errs $ + add_warns if_warns to_return) } ----------- @@ -381,8 +419,12 @@ type Go_Down = (RnEnv, -- stuff we already have defns for; ) lookup_defd (def_env, _, _) n - = (if isRdrLexCon n then lookupTcRnEnv else lookupRnEnv) def_env n + | isRnTyConOrClass n + = lookupTcRnEnv def_env (origName n) + | otherwise + = lookupRnEnv def_env (origName n) +defenv (def_env, _, _) = def_env occenv (_, occ_env, _) = occ_env uniqsupply (_, _, us) = us @@ -398,29 +440,30 @@ add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us) case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) -> -- ASSERT(isEmptyBag occ_dups) --- False because we may get a dup on the name we just shoved in +-- False because we may get a dup on the name we just shoved in (new_def_env, new_occ_env, us) }} ---------------- -type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedSig]), +type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]), ImplicitEnv, -- new names used implicitly (Bag Error, Bag Warning) ) empty_return :: To_Return -empty_return = (([],[],[]), emptyImplicitEnv, (emptyBag,emptyBag)) +empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag)) -add_decl decl ((tydecls, classdecls, sigs), implicit, msgs) +add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs) = case decl of - AddedTy t -> ((t:tydecls, classdecls, sigs), implicit, msgs) - AddedClass c -> ((tydecls, c:classdecls, sigs), implicit, msgs) - AddedSig s -> ((tydecls, classdecls, s:sigs), implicit, msgs) + AddedTy t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs) + AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs) + AddedSig s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs) + +add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs) + = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs) add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs) = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs) - where - pairify rn = (origName rn, rn) add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns)) add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns)) @@ -464,13 +507,14 @@ rnIfaceDecl (NewTypeSig tc dc _ decl) in returnRn (AddedTy rn_decl, defds, implicits) -rnIfaceDecl (DataSig tc dcs _ decl) +rnIfaceDecl (DataSig tc dcs fcs _ decl) = rnTyDecl decl `thenRn` \ rn_decl -> lookupTyCon tc `thenRn` \ rn_tc -> mapRn lookupValue dcs `thenRn` \ rn_dcs -> + mapRn lookupValue fcs `thenRn` \ rn_fcs -> getImplicitUpRn `thenRn` \ mentioned -> let - defds = (dcs `zip` rn_dcs, [(tc, rn_tc)]) + defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)]) implicits = mentioned `sub` defds in returnRn (AddedTy rn_decl, defds, implicits) @@ -508,69 +552,116 @@ sub (val_ment, tc_ment) (val_defds, tc_defds) % ------------------------------ +@cacheInstModules@: cache instance modules specified in imports + +\begin{code} +cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error) +cacheInstModules iface_cache imp_mods + = readVar iface_cache `thenPrimIO` \ (iface_fm, _) -> + let + imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ] + (imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces))) + get_ims (ParsedIface _ _ _ _ _ ims _ _ _ _ _) = ims + in + accumulate (map (cachedIface iface_cache) imp_imods) >>= \ err_or_ifaces -> + + -- Sanity Check: + -- Assert that instance modules given by direct imports contains + -- instance modules extracted from all visited modules + + readVar iface_cache `thenPrimIO` \ (all_iface_fm, _) -> + let + all_ifaces = eltsFM all_iface_fm + (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces)))) + in + ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods) + + return (bag_errs err_or_ifaces) + where + bag_errs [] = emptyBag + bag_errs (Failed err :rest) = err `consBag` bag_errs rest + bag_errs (Succeeded _:rest) = bag_errs rest +\end{code} + + @rnIfaceInstStuff@: Deal with instance declarations from interface files. \begin{code} +type InstanceEnv = FiniteMap (RdrName, RdrName) Int + rnIfaceInstStuff - :: IfaceCache -- all about ifaces we've read + :: IfaceCache -- all about ifaces we've read -> Module -> UniqSupply - -> RnEnv - -> ImplicitEnv -- info about all names we've used - -> IO ([RenamedInstDecl], - (Bag Error, Bag Warning)) - -rnIfaceInstStuff iface_cache modname us occ_env implicit_env - = -- nearly all the instance decls we might even want - -- to consider are in the ParsedIfaces that are in our - -- cache; any *other* instances to consider are in any - -- "instance modules" fields that we've encounted. - -- Get both: + -> RnEnv -- current occ env + -> InstanceEnv -- instances for these tycon/class pairs done + -> To_Return + -> IO (To_Return, + InstanceEnv, -- extended instance env + RnEnv, -- final occ env + [RnName]) -- new unknown names + +rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return + = -- all the instance decls we might even want to consider + -- are in the ParsedIfaces that are in our cache readVar iface_cache `thenPrimIO` \ (iface_fm, _) -> let - ifaces_so_far = eltsFM iface_fm - all_iface_imods = unionManyBags (map get_ims ifaces_so_far) - insts_so_far = unionManyBags (map get_insts ifaces_so_far) - in - -- OK, get all the instance decls out of the "instance module" - -- modules: + all_ifaces = eltsFM iface_fm + all_insts = unionManyBags (map get_insts all_ifaces) + interesting_insts = filter want_inst (bagToList all_insts) - read_iface_imods iface_fm (bagToList all_iface_imods) emptyBag emptyBag{-accumulators-} - >>= \ (more_insts, ims_errs) -> - let - all_insts = insts_so_far `unionBags` more_insts + -- Sanity Check: + -- Assert that there are no more instances for the done instances - -- an instance decl can only be of interest if *both* - -- its class and tycon have made their way into our - -- purview: - interesting_insts = filter (good_inst implicit_env) (bagToList all_insts) + claim_done = filter is_done_inst (bagToList all_insts) + claim_done_env = foldr add_done_inst emptyFM claim_done + has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v } in --- pprTrace "in implicit:\n" (ppCat (map (ppr PprDebug) (keysFM (snd implicit_env)))) $ --- pprTrace "insts_so_far:\n" (ppr_insts (bagToList insts_so_far)) $ --- pprTrace "more_insts:\n" (ppr_insts (bagToList more_insts)) $ --- pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $ - -- Do the renaming for real: - -- - case (initRn False{-iface-} modname occ_env us ( - setExtraRn emptyUFM{-ignore fixities-} $ - mapRn rnIfaceInst interesting_insts)) of { - (if_inst_decls, if_errs, if_warns) -> + {- + pprTrace "all_insts:\n" (ppr_insts (bagToList all_insts)) $ + pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $ + -} + ASSERT(sizeFM done_inst_env == sizeFM claim_done_env) + ASSERT(all (has_val claim_done_env) (fmToList done_inst_env)) - return (if_inst_decls, (ims_errs `unionBags` if_errs, if_warns)) + case (initRn False{-iface-} modname occ_env us ( + setExtraRn emptyUFM{-no fixities-} $ + mapRn rnIfaceInst interesting_insts `thenRn` \ insts -> + getImplicitUpRn `thenRn` \ implicits -> + returnRn (insts, implicits))) of { + ((if_insts, if_implicits), if_errs, if_warns) -> + + return (add_insts if_insts $ + add_implicits if_implicits $ + add_errs if_errs $ + add_warns if_warns to_return, + foldr add_done_inst done_inst_env interesting_insts, + add_imp_occs if_implicits occ_env, + eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)) } where - get_insts (ParsedIface _ _ _ _ _ _ _ _ _ insts _) = insts - get_ims (ParsedIface _ _ _ _ _ ims _ _ _ _ _) = ims - - good_inst (_, tc_imp_env) i@(InstSig clas tycon _ _) - = -- it's a "good instance" (one to hang onto) if we have - -- some chance of referring to *both* the class and tycon - -- later on. - mentionable clas && mentionable tycon + get_insts (ParsedIface _ _ _ _ _ _ _ _ _ insts _) = insts + + add_done_inst (InstSig clas tycon _ _) inst_env + = addToFM_C (+) inst_env (tycon,clas) 1 + + is_done_inst (InstSig clas tycon _ _) + = maybeToBool (lookupFM done_inst_env (tycon,clas)) + + add_imp_occs (val_imps, tc_imps) occ_env + = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of + (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups) + ext_occ_env + + want_inst i@(InstSig clas tycon _ _) + = -- it's a "good instance" (one to hang onto) if we have a + -- chance of referring to *both* the class and tycon later on ... + + mentionable tycon && mentionable clas && not (is_done_inst i) where mentionable nm - = case (lookupFM tc_imp_env nm) of + = case lookupTcRnEnv occ_env nm of Just _ -> True Nothing -> -- maybe it's builtin case nm of @@ -588,26 +679,6 @@ rnIfaceInstStuff iface_cache modname us occ_env implicit_env where ppr_inst (InstSig c t _ inst_decl) = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl] - - read_iface_imods :: ModuleToIfaceContents - -> [Module] - -> Bag RdrIfaceInst -> Bag Error - -> IO (Bag RdrIfaceInst, Bag Error) - - read_iface_imods iface_fm [] iacc eacc = return (iacc, eacc) - read_iface_imods iface_fm (m:ms) iacc eacc - = case (lookupFM iface_fm m) of - Just _ -> -- module's already in our cache; keep going - read_iface_imods iface_fm ms iacc eacc - - Nothing -> -- bring it in - cachedIface iface_cache m >>= \ read_res -> - case read_res of - Failed msg -> -- oh well, keep going anyway (saving the error) - read_iface_imods iface_fm ms iacc (eacc `snocBag` msg) - - Succeeded iface -> - read_iface_imods iface_fm ms (iacc `unionBags` get_insts iface) eacc \end{code} \begin{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 46fdb4f..dd1ec55 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -9,18 +9,18 @@ module RnMonad ( RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R, initRn, thenRn, thenRn_, andRn, returnRn, - mapRn, mapAndUnzipRn, + mapRn, mapAndUnzipRn, mapAndUnzip3Rn, addErrRn, addErrIfRn, addWarnRn, addWarnIfRn, failButContinueRn, warnAndContinueRn, - setExtraRn, getExtraRn, + setExtraRn, getExtraRn, getRnEnv, getModuleRn, pushSrcLocRn, getSrcLocRn, getSourceRn, getOccurrenceUpRn, getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv, rnGetUnique, rnGetUniques, newLocalNames, - lookupValue, lookupValueMaybe, lookupClassOp, + lookupValue, lookupConstr, lookupField, lookupClassOp, lookupTyCon, lookupClass, lookupTyConOrClass, extendSS2, extendSS, @@ -38,12 +38,12 @@ import HsSyn ( FixityDecl ) import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit, mkRnImplicitTyCon, mkRnImplicitClass, isRnLocal, isRnWired, isRnTyCon, isRnClass, - isRnTyConOrClass, isRnClassOp, - RenamedFixityDecl(..) ) + isRnTyConOrClass, isRnConstr, isRnField, + isRnClassOp, RenamedFixityDecl(..) ) import RnUtils ( RnEnv(..), extendLocalRnEnv, - lookupRnEnv, lookupTcRnEnv, + lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv, unknownNameErr, badClassOpErr, qualNameErr, - dupNamesErr, shadowedNameWarn ) + dupNamesErr, shadowedNameWarn, negateNameWarn ) import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import CmdLineOpts ( opt_WarnNameShadowing ) @@ -161,6 +161,12 @@ mapAndUnzipRn f (x:xs) = f x `thenRn` \ (r1, r2) -> mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) -> returnRn (r1:rs1, r2:rs2) + +mapAndUnzip3Rn f [] = returnRn ([],[],[]) +mapAndUnzip3Rn f (x:xs) + = f x `thenRn` \ (r1, r2, r3) -> + mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) -> + returnRn (r1:rs1, r2:rs2, r3:rs3) \end{code} For errors and warnings ... @@ -194,6 +200,10 @@ addWarnIfRn False warn = returnRn () \begin{code} +getRnEnv :: RnMonad x s RnEnv +getRnEnv (RnDown _ _ _ _ env _ _) + = returnSST env + setExtraRn :: x -> RnMonad x s r -> RnMonad y s r setExtraRn x m (RnDown _ mod locn mode env us errs) = m (RnDown x mod locn mode env us errs) @@ -281,11 +291,13 @@ newLocalNames :: String -- Documentation string -> RnMonad x s [RnName] newLocalNames str names_w_loc - = mapRn (addErrRn . qualNameErr str) quals `thenRn_` - mapRn (addErrRn . dupNamesErr str) dups `thenRn_` + = mapRn (addWarnRn . negateNameWarn) negs `thenRn_` + mapRn (addErrRn . qualNameErr str) quals `thenRn_` + mapRn (addErrRn . dupNamesErr str) dups `thenRn_` mkLocalNames these where - quals = filter (isQual.fst) names_w_loc + negs = filter ((== Unqual SLIT("negate")).fst) names_w_loc + quals = filter (isQual.fst) names_w_loc (these, dups) = removeDups cmp_fst names_w_loc cmp_fst (a,_) (b,_) = cmp a b \end{code} @@ -319,17 +331,26 @@ If not found create new implicit name, adding it to the implicit env. \begin{code} lookupValue :: RdrName -> RnMonad x s RnName +lookupConstr :: RdrName -> RnMonad x s RnName +lookupField :: RdrName -> RnMonad x s RnName lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName lookupValue rdr - = lookup_val rdr (\ rn -> True) (unknownNameErr "value") + = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value") + +lookupConstr rdr + = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor") + +lookupField rdr + = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field") lookupClassOp cls rdr - = lookup_val rdr (\ rn -> True){-WAS:(isRnClassOp cls)-} (badClassOpErr cls) + = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls) +-- Note: the lookup checks are only performed when renaming source -lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _) - = case lookupRnEnv env rdr of +lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _) + = case lookup env rdr of Just name | check name -> succ name | otherwise -> fail Nothing -> fail @@ -342,11 +363,10 @@ lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _) returnSST name fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down -lookup_val rdr check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) - = case lookupRnEnv env rdr of - Just name | check name -> returnSST name - | otherwise -> failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down - Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr +lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) + = case lookup env rdr of + Just name -> returnSST name + Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr = case rdr of @@ -374,11 +394,6 @@ lookup_or_create_implicit_val b_key imp_var us_var rdr in writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` returnSST implicit - - -lookupValueMaybe :: RdrName -> RnMonad x s (Maybe RnName) -lookupValueMaybe rdr down@(RnDown _ _ _ (RnSource _) env _ _) - = returnSST (lookupRnEnv env rdr) \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 2d1329b..d4c997a 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -22,14 +22,14 @@ import RnHsSyn import RnMonad import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl ) import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, - lubExportFlag, qualNameErr, dupNamesErr ) + lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn ) import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst ) -import Bag ( emptyBag, unitBag, consBag, unionBags, unionManyBags, - mapBag, listToBag, bagToList ) +import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, + unionManyBags, mapBag, listToBag, bagToList ) import CmdLineOpts ( opt_NoImplicitPrelude ) -import ErrUtils ( Error(..), Warning(..), addShortErrLocLine ) +import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine ) import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM ) import Id ( GenId ) import Maybes ( maybeToBool, catMaybes, MaybeErr(..) ) @@ -45,7 +45,8 @@ import SrcLoc ( SrcLoc, mkIfaceSrcLoc ) import TyCon ( tyConDataCons ) import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM ) import UniqSupply ( splitUniqSupply ) -import Util ( isIn, cmpPString, sortLt, removeDups, equivClasses, panic, assertPanic ) +import Util ( isIn, assoc, cmpPString, sortLt, removeDups, + equivClasses, panic, assertPanic ) \end{code} @@ -90,7 +91,7 @@ getGlobalNames iface_cache info us dup_errs = map dup_err (equivClasses cmp_rdr (bagToList dups)) cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2 - dup_err ((rdr,rn,rn'):rest) = globalDupNamesErr rdr (rn:rn': [rn|(_,_,rn)<-rest]) + dup_err ((_,rn,rn'):rest) = globalDupNamesErr (rn:rn': [rn|(_,_,rn)<-rest]) all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs all_warns = src_warns `unionBags` imp_warns @@ -116,45 +117,66 @@ getSourceNames :: Bag RnName) -- tycons/classes getSourceNames ty_decls cls_decls binds - = mapAndUnzipRn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s) -> - mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) -> - getTopBindsNames binds `thenRn` \ bind_names -> + = mapAndUnzip3Rn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s, fields_s) -> + mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) -> + getTopBindsNames binds `thenRn` \ bind_names -> returnRn (unionManyBags constrs_s `unionBags` + unionManyBags fields_s `unionBags` unionManyBags cls_ops_s `unionBags` bind_names, listToBag tycon_s `unionBags` listToBag cls_s) getTyDeclNames :: RdrNameTyDecl - -> RnM_Info s (RnName, Bag RnName) -- tycon and constrs + -> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc) = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> - mapRn (getConDeclName (Just (nameExportFlag tycon_name))) - condecls `thenRn` \ con_names -> - returnRn (RnData tycon_name con_names, - listToBag (map (\ n -> RnConstr n tycon_name) con_names)) + getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM + condecls `thenRn` \ (con_names, field_names) -> + let + rn_tycon = RnData tycon_name con_names field_names + rn_constrs = [ RnConstr name tycon_name | name <- con_names] + rn_fields = [ RnField name tycon_name | name <- field_names] + in + returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields) -getTyDeclNames (TyNew _ tycon _ condecls _ _ src_loc) +getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc) = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> - mapRn (getConDeclName (Just (nameExportFlag tycon_name))) - condecls `thenRn` \ con_names -> - returnRn (RnData tycon_name con_names, - listToBag (map (\ n -> RnConstr n tycon_name) con_names)) + newGlobalName con_loc (Just (nameExportFlag tycon_name)) con + `thenRn` \ con_name -> + returnRn (RnData tycon_name [con_name] [], + unitBag (RnConstr con_name tycon_name), + emptyBag) getTyDeclNames (TySynonym tycon _ _ src_loc) = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> - returnRn (RnSyn tycon_name, emptyBag) + returnRn (RnSyn tycon_name, emptyBag, emptyBag) + -getConDeclName exp (ConDecl con _ src_loc) - = newGlobalName src_loc exp con -getConDeclName exp (ConOpDecl _ op _ src_loc) - = newGlobalName src_loc exp op -getConDeclName exp (NewConDecl con _ src_loc) - = newGlobalName src_loc exp con -getConDeclName exp (RecConDecl con fields src_loc) - = panic "getConDeclName:RecConDecl" - newGlobalName src_loc exp con +getConFieldNames exp constrs fields have [] + = returnRn (bagToList constrs, bagToList fields) +getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest) + = newGlobalName src_loc exp con `thenRn` \ con_name -> + getConFieldNames exp (constrs `snocBag` con_name) fields have rest + +getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest) + = newGlobalName src_loc exp con `thenRn` \ con_name -> + getConFieldNames exp (constrs `snocBag` con_name) fields have rest + +getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest) + = mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_` + newGlobalName src_loc exp con `thenRn` \ con_name -> + mapRn (newGlobalName src_loc exp) new_fields `thenRn` \ field_names -> + let + all_constrs = constrs `snocBag` con_name + all_fields = fields `unionBags` listToBag field_names + in + getConFieldNames exp all_constrs all_fields new_have rest + where + (uniq_fields, dups) = removeDups cmp (concat (map fst fielddecls)) + new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields + new_have = addListToFM have (zip new_fields (repeat ())) getClassNames :: RdrNameClassDecl -> RnM_Info s (RnName, Bag RnName) -- class and class ops @@ -266,6 +288,7 @@ newGlobalName locn maybe_exp rdr n = mkTopLevName uniq orig locn exp (occ_fn n) in + addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_` addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_` returnRn n \end{code} @@ -309,23 +332,20 @@ doImportDecls iface_cache g_info us src_imps i_info = (g_info, emptyFM, emptyFM, rec_imp_fn) in - doImports iface_cache i_info us (qprel_imp ++ prel_imp ++ src_imps) + doImports iface_cache i_info us all_imps ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) -> - let - imp_mods = [ mod | ImportDecl mod _ _ _ _ <- src_imps ] - imp_warns = listToBag (map dupImportWarn imp_dups) - prel_warns = listToBag (map qualPreludeImportWarn qual_prels) - - (_, imp_dups) = removeDups cmp_mod src_imps - cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2 - qual_prels = [imp | imp@(ImportDecl mod qual _ _ _) <- src_imps, - fromPrelude mod && qual] - in - return (vals, tcs, imp_mods, unquals, fixes, errs, - prel_warns `unionBags` imp_warns `unionBags` warns) + + return (vals, tcs, imp_mods, unquals, fixes, + imp_errs `unionBags` errs, + imp_warns `unionBags` warns) where + (ok_imps, src_qprels) = partition not_qual_prel src_imps + all_imps = qprel_imp ++ prel_imp ++ ok_imps + + not_qual_prel (ImportDecl mod qual _ _ _) = not (fromPrelude mod && qual) + explicit_prelude_import - = null [() | (ImportDecl mod qual _ _ _) <- src_imps, + = null [() | (ImportDecl mod qual _ _ _) <- ok_imps, fromPrelude mod && not qual] qprel_imp = if opt_NoImplicitPrelude @@ -334,10 +354,18 @@ doImportDecls iface_cache g_info us src_imps prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude then - [ {-prelude imported explicitly => no import Prelude-} ] + [{- no "import Prelude" -}] else [ImportDecl pRELUDE False Nothing Nothing mkIfaceSrcLoc] + (uniq_imps, imp_dups) = removeDups cmp_mod all_imps + cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2 + + imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ] + imp_warns = listToBag (map dupImportWarn imp_dups) + imp_errs = listToBag (map qualPreludeImportErr src_qprels) + + doImports iface_cache i_info us [] = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps) @@ -423,10 +451,6 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) pair_as rn = (as_mod, rn) -getBuiltins info mod maybe_spec - | not (fromPrelude mod) - = (emptyBag, emptyBag, maybe_spec) - getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec = case maybe_spec of Nothing -> (all_vals, all_tcs, Nothing) @@ -481,7 +505,7 @@ getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import h (found_ies, errs) = lookupIEs exps ies exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies) -getOrigNames (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) +getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these = (map fst found_ies, found_ies, errs) where (found_ies, errs) = lookupIEs exps ies @@ -557,9 +581,9 @@ checkOrigIE iface_cache (IEThingWith n ns, ExportAll) = with_decl iface_cache n (\ err -> (unitBag (\ mod locn -> err), emptyBag)) (\ decl -> case decl of - NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag) - DataSig _ cons _ _ -> (check_with "constructrs" cons ns, emptyBag) - ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag)) + NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag) + DataSig _ cons fields _ _ -> (check_with "constructrs (and fields)" (cons++fields) ns, emptyBag) + ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag)) where check_with str has rdrs | sortLt (<) (map getLocalName has) == sortLt (<) (map unqual_str rdrs) @@ -618,40 +642,48 @@ getIfaceDeclNames :: RdrNameIE -> RdrIfaceDecl Bag (RnName,ExportFlag)) -- import flags getIfaceDeclNames ie (ValSig val src_loc _) - = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name -> + = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name -> returnRn (unitBag (RnName val_name), emptyBag, unitBag (RnName val_name, ExportAll)) getIfaceDeclNames ie (TypeSig tycon src_loc _) - = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> + = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> returnRn (emptyBag, unitBag (RnSyn tycon_name), unitBag (RnSyn tycon_name, ExportAll)) getIfaceDeclNames ie (NewTypeSig tycon con src_loc _) - = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> - mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name)) - (Just (nameImportFlag tycon_name))) - [con] `thenRn` \ con_names -> + = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> + newImportedName False src_loc (Just (nameExportFlag tycon_name)) + (Just (nameImportFlag tycon_name)) + con `thenRn` \ con_name -> returnRn (if imp_all (imp_flag ie) then - listToBag (map (\ n -> RnConstr n tycon_name) con_names) + unitBag (RnConstr con_name tycon_name) else emptyBag, - unitBag (RnData tycon_name con_names), - unitBag (RnData tycon_name con_names, imp_flag ie)) + unitBag (RnData tycon_name [con_name] []), + unitBag (RnData tycon_name [con_name] [], imp_flag ie)) -getIfaceDeclNames ie (DataSig tycon cons src_loc _) +getIfaceDeclNames ie (DataSig tycon cons fields src_loc _) = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name)) (Just (nameImportFlag tycon_name))) cons `thenRn` \ con_names -> + mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name)) + (Just (nameImportFlag tycon_name))) + fields `thenRn` \ field_names -> + let + rn_tycon = RnData tycon_name con_names field_names + rn_constrs = [ RnConstr name tycon_name | name <- con_names ] + rn_fields = [ RnField name tycon_name | name <- field_names ] + in returnRn (if imp_all (imp_flag ie) then - listToBag (map (\ n -> RnConstr n tycon_name) con_names) + listToBag rn_constrs `unionBags` listToBag rn_fields else emptyBag, - unitBag (RnData tycon_name con_names), - unitBag (RnData tycon_name con_names, imp_flag ie)) + unitBag rn_tycon, + unitBag (rn_tycon, imp_flag ie)) getIfaceDeclNames ie (ClassSig cls ops src_loc _) = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name -> @@ -718,33 +750,68 @@ newImportedName tycon_or_class locn maybe_exp maybe_imp rdr \end{code} \begin{code} -globalDupNamesErr rdr rns sty - = ppHang (ppBesides [pprNonSym sty rdr, ppStr " multiply defined:"]) - 4 (ppAboves (map pp_def rns)) +globalDupNamesErr (rn1:dup_rns) sty + = ppAboves (item1 : map dup_item dup_rns) where - pp_def rn = addShortErrLocLine (getSrcLoc rn) (\ sty -> ppr sty rn) sty - -dupImportWarn dup_imps sty - = ppStr "dupImportWarn" - -qualPreludeImportWarn imp sty - = ppStr "qualPreludeImportWarn" - -unknownImpSpecErr ie imp_mod locn sty - = ppStr "unknownImpSpecErr" - -duplicateImpSpecErr ie imp_mod locn sty - = ppStr "duplicateImpSpecErr" - -allWhenSynImpSpecWarn n imp_mod locn sty - = ppStr "allWhenSynImpSpecWarn" - -allWhenAbsImpSpecErr n imp_mod locn sty - = ppStr "allWhenAbsImpSpecErr" - -withWhenAbsImpSpecErr n imp_mod locn sty - = ppStr "withWhenAbsImpSpecErr" - -withImpSpecErr str n has ns imp_mod locn sty - = ppStr "withImpSpecErr" + item1 = addShortErrLocLine (getSrcLoc rn1) (\ sty -> + ppBesides [ppStr "multiple declarations of `", + pprNonSym sty rn1, ppStr "' ", pp_descrip rn1]) sty + + dup_item rn + = addShortErrLocLine (getSrcLoc rn) (\ sty -> + ppBesides [ppStr "here was another declaration of `", + pprNonSym sty rn, ppStr "' ", pp_descrip rn]) sty + + pp_descrip (RnName _) = ppStr "(as a value)" + pp_descrip (RnSyn _) = ppStr "(as a type synonym)" + pp_descrip (RnData _ _ _) = ppStr "(as a data type)" + pp_descrip (RnConstr _ _) = ppStr "(as a data constructor)" + pp_descrip (RnField _ _) = ppStr "(as a record field)" + pp_descrip (RnClass _ _) = ppStr "(as a class)" + pp_descrip (RnClassOp _ _) = ppStr "(as a class method)" + pp_descrip _ = ppNil + +dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty + = ppAboves (item1 : map dup_item dup_imps) + where + item1 = addShortErrLocLine locn1 (\ sty -> + ppCat [ppStr "multiple imports from module", ppPStr m1]) sty + + dup_item (ImportDecl m _ _ _ locn) + = addShortErrLocLine locn (\ sty -> + ppCat [ppStr "here was another import from module", ppPStr m]) sty + +qualPreludeImportErr (ImportDecl m _ _ _ locn) + = addShortErrLocLine locn (\ sty -> + ppCat [ppStr "qualified import form prelude module", ppPStr m]) + +unknownImpSpecErr ie imp_mod locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"]) + +duplicateImpSpecErr ie imp_mod locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"]) + +allWhenSynImpSpecWarn n imp_mod locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"]) + +allWhenAbsImpSpecErr n imp_mod locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"]) + +withWhenAbsImpSpecErr n imp_mod locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"]) + +withImpSpecErr str n has ns imp_mod locn + = addErrLoc locn "" (\ sty -> + ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"], + ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)], + ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) ns)] ]) + +dupFieldErr con locn (dup:rest) + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"]) \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 739c839..7b85d5d 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -17,10 +17,11 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnBinds ( rnTopBinds, rnMethodBinds ) -import RnUtils ( lubExportFlag ) +import RnUtils ( lookupGlobalRnEnv, lubExportFlag ) import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) import Class ( derivableClassKeys ) +import ErrUtils ( addErrLoc, addShortErrLocLine ) import FiniteMap ( emptyFM, lookupFM, addListToFM_C ) import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) @@ -31,9 +32,9 @@ import PprStyle -- ToDo:rm import Pretty import SrcLoc ( SrcLoc ) import Unique ( Unique ) -import UniqFM ( emptyUFM, addListToUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM ) +import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM ) import UniqSet ( UniqSet(..) ) -import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, panic, assertPanic, pprTrace{-ToDo:rm-} ) +import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, assertPanic, pprTrace{-ToDo:rm-} ) \end{code} rnSource `renames' the source module and export list. @@ -70,12 +71,10 @@ rnSource imp_mods unqual_imps imp_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) - pair_name inf@(InfixN n _) = (n, inf) + pair_name inf = (nameFixDecl inf, inf) - imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes)) - all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes) + all_fixes = src_fixes ++ bagToList imp_fixes + all_fixes_fm = listToUFM (map pair_name all_fixes) in setExtraRn all_fixes_fm $ @@ -91,7 +90,7 @@ rnSource imp_mods unqual_imps imp_fixes returnRn ( HsModule mod version - trashed_exports trashed_imports src_fixes + trashed_exports trashed_imports all_fixes new_ty_decls new_specdata_sigs new_class_decls new_inst_decls new_specinst_sigs new_defaults new_binds [] src_loc, @@ -132,16 +131,16 @@ rnExports mods unqual_imps (Just exps) -- Build finite map of exported names to export flag exp_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst uniq_exp_names) - exp_map1 = foldl add_mod_names exp_map0 uniq_exp_mods + (exp_map1, empty_mods) = foldl add_mod_names (exp_map0, []) uniq_exp_mods mod_fm = addListToFM_C unionBags emptyFM [(mod, unitBag (getName rn, nameImportFlag (getName rn))) | (mod,rn) <- bagToList unqual_imps] - add_mod_names exp_map mod + add_mod_names (exp_map, empty) mod = case lookupFM mod_fm mod of - Nothing -> exp_map - Just mod_names -> addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names)) + Nothing -> (exp_map, mod:empty) + Just mod_names -> (addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names)), empty) pair_fst p@(f,_) = (f,p) lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2) @@ -151,16 +150,16 @@ rnExports mods unqual_imps (Just exps) (_, dup_locals) = removeDups cmp_local exp_locals cmp_local (x,_) (y,_) = x `cmpPString` y - -- Build export flag function exp_fn n = case lookupUFM exp_map1 n of Nothing -> NotExported Just (_,flag) -> flag in getSrcLocRn `thenRn` \ src_loc -> - mapRn (addWarnRn . dupNameExportWarn src_loc) dup_names `thenRn_` - mapRn (addWarnRn . dupModuleExportWarn src_loc) dup_mods `thenRn_` - mapRn (addErrRn . dupLocalsExportErr src_loc) dup_locals `thenRn_` + mapRn (addWarnRn . dupNameExportWarn src_loc) dup_names `thenRn_` + mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_` + mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_` + mapRn (addErrRn . dupLocalsExportErr src_loc) dup_locals `thenRn_` returnRn exp_fn @@ -170,21 +169,19 @@ rnIE mods (IEVar name) returnRn (Nothing, exps) where checkIEVar (RnName n) = returnRn (unitBag (n,ExportAll)) - checkIEVar (RnUnbound _) = returnRn emptyBag checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc -> failButContinueRn emptyBag (classOpExportErr rn src_loc) - checkIEVar rn = panic "checkIEVar" + checkIEVar rn = returnRn emptyBag 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" + checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs)) + checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs)) + checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs)) + checkIEAbs rn = returnRn emptyBag rnIE mods (IEThingAll name) = lookupTyConOrClass name `thenRn` \ rn -> @@ -192,12 +189,12 @@ rnIE mods (IEThingAll name) checkImportAll rn `thenRn_` 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" + checkIEAll (RnData n cons fields) = returnRn (exp_all n `consBag` listToBag (map exp_all cons) + `unionBags` listToBag (map exp_all fields)) + checkIEAll (RnClass n ops) = returnRn (exp_all n `consBag` listToBag (map exp_all ops)) + checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc -> + warnAndContinueRn emptyBag (synAllExportErr rn src_loc) + checkIEAll rn = returnRn emptyBag exp_all n = (n, ExportAll) @@ -208,16 +205,21 @@ rnIE mods (IEThingWith name names) checkImportAll rn `thenRn_` 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@(RnData n cons fields) rns + | same_names (cons++fields) rns + = returnRn (consBag (exp_all n) (listToBag (map exp_all cons))) + | otherwise + = rnWithErr "constructrs (and fields)" rn (cons++fields) 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" + | same_names ops rns + = returnRn (consBag (exp_all n) (listToBag (map exp_all ops))) + | otherwise + = rnWithErr "class ops" rn ops rns + checkIEWith rn@(RnSyn _) rns + = getSrcLocRn `thenRn` \ src_loc -> + failButContinueRn emptyBag (synAllExportErr rn src_loc) + checkIEWith rn rns + = returnRn emptyBag exp_all n = (n, ExportAll) @@ -323,27 +325,34 @@ rnConDecls tv_env con_decls where rn_decl (ConDecl name tys src_loc) = pushSrcLocRn src_loc $ - lookupValue name `thenRn` \ new_name -> + lookupConstr name `thenRn` \ new_name -> mapRn rn_bang_ty tys `thenRn` \ new_tys -> returnRn (ConDecl new_name new_tys src_loc) rn_decl (ConOpDecl ty1 op ty2 src_loc) = pushSrcLocRn src_loc $ - lookupValue op `thenRn` \ new_op -> + lookupConstr op `thenRn` \ new_op -> rn_bang_ty ty1 `thenRn` \ new_ty1 -> rn_bang_ty ty2 `thenRn` \ new_ty2 -> returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc) rn_decl (NewConDecl name ty src_loc) = pushSrcLocRn src_loc $ - lookupValue name `thenRn` \ new_name -> + lookupConstr name `thenRn` \ new_name -> rn_mono_ty ty `thenRn` \ new_ty -> returnRn (NewConDecl new_name new_ty src_loc) - rn_decl (RecConDecl con fields src_loc) - = panic "rnConDecls:RecConDecl" + rn_decl (RecConDecl name fields src_loc) + = pushSrcLocRn src_loc $ + lookupConstr name `thenRn` \ new_name -> + mapRn rn_field fields `thenRn` \ new_fields -> + returnRn (RecConDecl new_name new_fields src_loc) + + rn_field (names, ty) + = mapRn lookupField names `thenRn` \ new_names -> + rn_bang_ty ty `thenRn` \ new_ty -> + returnRn (new_names, new_ty) - ---------- rn_mono_ty = rnMonoType tv_env rn_bang_ty (Banged ty) @@ -530,23 +539,32 @@ rnDefaultDecl defs@(d:ds) rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl] rnFixes fixities - = mapRn rn_fixity fixities `thenRn` \ fixes_maybe -> + = getSrcLocRn `thenRn` \ src_loc -> + let + (_, dup_fixes) = removeDups cmp_fix fixities + cmp_fix fix1 fix2 = nameFixDecl fix1 `cmp` nameFixDecl fix2 + + rn_fixity fix@(InfixL name i) + = rn_fixity_pieces InfixL name i fix + rn_fixity fix@(InfixR name i) + = rn_fixity_pieces InfixR name i fix + rn_fixity fix@(InfixN name i) + = rn_fixity_pieces InfixN name i fix + + rn_fixity_pieces mk_fixity name i fix + = getRnEnv `thenRn` \ env -> + case lookupGlobalRnEnv env name of + Just res | isLocallyDefined res + -> returnRn (Just (mk_fixity res i)) + _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix) + in + mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_` + mapRn rn_fixity fixities `thenRn` \ fixes_maybe -> returnRn (catMaybes fixes_maybe) - where - rn_fixity fix@(InfixL name i) - = rn_fixity_pieces InfixL name i fix - rn_fixity fix@(InfixR name i) - = rn_fixity_pieces InfixR name i fix - rn_fixity fix@(InfixN name i) - = rn_fixity_pieces InfixN name i fix - - rn_fixity_pieces mk_fixity name i fix - = lookupValueMaybe name `thenRn` \ maybe_res -> - case maybe_res of - Just res | isLocallyDefined res - -> returnRn (Just (mk_fixity res i)) - _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix) - + +nameFixDecl (InfixL name i) = name +nameFixDecl (InfixR name i) = name +nameFixDecl (InfixN name i) = name \end{code} %********************************************************* @@ -640,50 +658,62 @@ rnContext tv_env ctxt \begin{code} -dupNameExportWarn locn names@((n,_):_) sty - = ppHang (ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times:"]) - 4 (ppr sty locn) - -dupModuleExportWarn locn mods@(mod:_) sty - = ppHang (ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list:"]) - 4 (ppr sty locn) - -dupLocalsExportErr locn locals@((str,_):_) sty - = ppHang (ppBesides [ppStr "Exported names have same local name `", ppPStr str, ppStr "': ", ppr sty locn]) - 4 (ppInterleave ppSP (map (pprNonSym sty . snd) locals)) - -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)])) - -importAllErr rn locn sty - = ppHang (ppCat [pprNonSym sty rn, ppStr "exported concretely but only imported abstractly"]) - 4 (ppr sty locn) - -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:") - 4 (ppCat [ppr sty clas, ppr sty locn]) - -dupDefaultDeclErr defs sty - = ppHang (ppStr "Duplicate default declarations:") - 4 (ppAboves (map pp_def_loc defs)) +dupNameExportWarn locn names@((n,_):_) + = addShortErrLocLine locn (\ sty -> + ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]) + +dupLocalsExportErr locn locals@((str,_):_) + = addErrLoc locn "exported names have same local name" (\ sty -> + ppInterleave ppSP (map (pprNonSym sty . snd) locals)) + +classOpExportErr op locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"]) + +synAllExportErr syn locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]) + +withExportErr str rn has rns locn + = addErrLoc locn "" (\ sty -> + ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in export list for `", ppr sty rn, ppStr "'"], + ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)], + ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ]) + +importAllErr rn locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]) + +badModExportErr mod locn + = addShortErrLocLine locn (\ sty -> + ppCat [ ppStr "unknown module in export list:", ppPStr mod]) + +dupModExportWarn locn mods@(mod:_) + = addShortErrLocLine locn (\ sty -> + ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]) + +emptyModExportWarn locn mod + = addShortErrLocLine locn (\ sty -> + ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]) + +derivingNonStdClassErr clas locn + = addShortErrLocLine locn (\ sty -> + ppCat [ppStr "non-standard class in deriving:", ppr sty clas]) + +dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty + = ppAboves (item1 : map dup_item dup_things) where - pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc + item1 + = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty + + dup_item (DefaultDecl _ locn) + = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty + +undefinedFixityDeclErr locn decl + = addErrLoc locn "fixity declaration for unknown operator" (\ sty -> + ppr sty decl) -undefinedFixityDeclErr decl sty - = ppHang (ppStr "Fixity declaration for unknown operator:") - 4 (ppr sty decl) +dupFixityDeclErr locn dups + = addErrLoc locn "multiple fixity declarations for same operator" (\ sty -> + ppAboves (map (ppr sty) dups)) \end{code} diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs index 2658fcc..f27614c 100644 --- a/ghc/compiler/rename/RnUtils.lhs +++ b/ghc/compiler/rename/RnUtils.lhs @@ -10,7 +10,7 @@ module RnUtils ( RnEnv(..), QualNames(..), UnqualNames(..), ScopeStack(..), emptyRnEnv, extendGlobalRnEnv, extendLocalRnEnv, - lookupRnEnv, lookupTcRnEnv, + lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv, lubExportFlag, @@ -20,9 +20,7 @@ module RnUtils ( dupNamesErr, shadowedNameWarn, multipleOccWarn, - - -- ToDo: nuke/move? WDP 96/04/05 - GlobalNameMapper(..), GlobalNameMappers(..) + negateNameWarn ) where import Ubiq @@ -37,9 +35,6 @@ import PprStyle ( PprStyle(..) ) import Pretty import RnHsSyn ( RnName ) import Util ( assertPanic ) - -type GlobalNameMapper = RnName -> Maybe Name -type GlobalNameMappers = (GlobalNameMapper, GlobalNameMapper) \end{code} ********************************************************* @@ -63,6 +58,7 @@ extendGlobalRnEnv :: RnEnv -> [(RdrName,RnName)] -> [(RdrName,RnName)] -> (RnEnv, Bag (RdrName, RnName, RnName)) extendLocalRnEnv :: Bool -> RnEnv -> [RnName] -> (RnEnv, [RnName]) lookupRnEnv :: RnEnv -> RdrName -> Maybe RnName +lookupGlobalRnEnv :: RnEnv -> RdrName -> Maybe RnName lookupTcRnEnv :: RnEnv -> RdrName -> Maybe RnName \end{code} @@ -143,6 +139,11 @@ lookupRnEnv ((qual, unqual, _, _), stack) rdr found@(Just name) -> found Nothing -> do_on_fail +lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr + = case rdr of + Unqual str -> lookupFM unqual str + Qual mod str -> lookupFM qual (str,mod) + lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr = case rdr of Unqual str -> lookupFM tc_unqual str @@ -186,13 +187,14 @@ dupNamesErr descriptor ((name1,locn1) : dup_things) sty = ppAboves (item1 : map dup_item dup_things) where item1 - = ppBesides [ ppr PprForUser locn1, - ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ", - pprNonSym sty name1 ] + = addShortErrLocLine locn1 (\ sty -> + ppBesides [ppStr "multiple declarations of a ", ppStr descriptor, ppStr " `", + pprNonSym sty name1, ppStr "'" ]) sty dup_item (name, locn) - = ppBesides [ ppr PprForUser locn, - ppStr ": here was another declaration of `", pprNonSym sty name, ppStr "'" ] + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "here was another declaration of `", + pprNonSym sty name, ppStr "'" ]) sty shadowedNameWarn locn shadow = addShortErrLocLine locn ( \ sty -> @@ -201,5 +203,9 @@ shadowedNameWarn locn shadow multipleOccWarn (name, occs) sty = ppBesides [ppStr "multiple names used to refer to `", ppr sty name, ppStr "': ", ppInterleave ppComma (map (ppr sty) occs)] + +negateNameWarn (name,locn) + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "local binding of `negate' will be used for prefix `-'"]) \end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index d69a577..6e29cc6 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -29,9 +29,9 @@ import TcKind ( TcKind ) import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcSimplify ( tcSimplifyThetas ) ---import RnMonad4 -import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) ---import RnBinds4 ( rnMethodBinds, rnTopBinds ) +import RnMonad +import RnUtils ( RnEnv(..) ) +import RnBinds ( rnMethodBinds, rnTopBinds ) import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag ) import Class ( GenClass, getClassKey ) @@ -50,7 +50,7 @@ import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon, mkSigmaTy, mkDictTy, isPrimType, instantiateTy, getAppTyCon, getAppDataTyCon ) import TyVar ( GenTyVar ) -import UniqFM ( eltsUFM ) +import UniqFM ( emptyUFM ) import Unique -- Keys stuff import Util ( zipWithEqual, zipEqual, sortLt, removeDups, thenCmp, cmpList, panic, pprPanic, pprPanic# ) @@ -155,7 +155,7 @@ type DerivSoln = DerivRhs \begin{code} tcDeriving :: Module -- name of module under scrutiny - -> GlobalNameMappers -- for "renaming" bits of generated code + -> RnEnv -- for "renaming" bits of generated code -> Bag InstInfo -- What we already know about instances -> [RenamedFixityDecl] -- Fixity info; used by Read and Show -> TcM s (Bag InstInfo, -- The generated "instance decls". @@ -163,11 +163,11 @@ tcDeriving :: Module -- name of module under scrutiny PprStyle -> Pretty) -- Printable derived instance decls; -- for debugging via -ddump-derivings. -tcDeriving modname renamer_name_funs inst_decl_infos_in fixities +tcDeriving modname rn_env inst_decl_infos_in fixities = returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil)) {- LATER: -tcDeriving modname renamer_name_funs inst_decl_infos_in fixities +tcDeriving modname rn_env inst_decl_infos_in fixities = -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". makeDerivEqns `thenTc` \ eqns -> @@ -205,9 +205,9 @@ tcDeriving modname renamer_name_funs inst_decl_infos_in fixities assoc_maybe ((k,v) : vs) key = if k `eqProtoName` key then Just v else assoc_maybe vs key in - gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds -> + gen_tag_n_con_binds deriver_rn_env nm_alist_etc `thenTc` \ extra_binds -> - mapTc (gen_inst_info maybe_mod fixities deriver_name_funs) new_inst_infos + mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos `thenTc` \ really_new_inst_infos -> returnTc (listToBag really_new_inst_infos, @@ -512,11 +512,11 @@ the renamer. What a great hack! gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude -> [RenamedFixityDecl] -- all known fixities; -- may be needed for Text - -> GlobalNameMappers -- lookup stuff for names we may use + -> RnEnv -- lookup stuff for names we may use -> InstInfo -- the main stuff to work on -> TcM s InstInfo -- the gen'd (filled-in) "instance decl" -gen_inst_info modname fixities deriver_name_funs +gen_inst_info modname fixities deriver_rn_env info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _) = -- Generate the various instance-related Ids @@ -543,7 +543,8 @@ gen_inst_info modname fixities deriver_name_funs | clas_key == binaryClassKey = gen_Binary_binds tycon | otherwise = panic "gen_inst_info:bad derived class" in - rn4MtoTcM deriver_name_funs ( + rnMtoTcM deriver_rn_env ( + setExtraRn emptyUFM{-no fixities-} $ rnMethodBinds clas_Name proto_mbinds ) `thenNF_Tc` \ (mbinds, errs) -> @@ -581,17 +582,18 @@ tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# maxtag_Foo :: Int -- ditto (NB: not unboxed) \begin{code} -gen_tag_n_con_binds :: GlobalNameMappers +gen_tag_n_con_binds :: RnEnv -> [(RdrName, RnName, TyCon, TagThingWanted)] -> TcM s RenamedHsBinds -gen_tag_n_con_binds deriver_name_funs nm_alist_etc +gen_tag_n_con_binds deriver_rn_env nm_alist_etc = let proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list in - rn4MtoTcM deriver_name_funs ( + rnMtoTcM deriver_rn_env ( + setExtraRn emptyUFM{-no fixities-} $ rnTopBinds (SingleBind (RecBind proto_mbinds)) ) `thenNF_Tc` \ (binds, errs) -> diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 2cabcf1..2813277 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -168,7 +168,7 @@ tcExpr (HsLit lit@(HsString str)) \begin{code} tcExpr (HsPar expr) = tcExpr expr -tcExpr (NegApp expr) = panic "tcExpr:NegApp" +tcExpr (NegApp expr n) = tcExpr (HsApp (HsVar n) expr) tcExpr (HsLam match) = tcMatch match `thenTc` \ (match',lie,ty) -> diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index b51e488..051d6cd 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -285,8 +285,6 @@ zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty) %* * %************************************************************************ -ToDo: panic on things that can't be in @TypecheckedHsExpr@. - \begin{code} zonkExpr :: TcExpr s -> NF_TcM s TypecheckedHsExpr @@ -294,6 +292,8 @@ zonkExpr (HsVar name) = zonkId name `thenNF_Tc` \ new_name -> returnNF_Tc (HsVar new_name) +zonkExpr (HsLit _) = panic "zonkExpr:HsLit" + zonkExpr (HsLitOut lit ty) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> returnNF_Tc (HsLitOut lit new_ty) @@ -313,8 +313,8 @@ zonkExpr (OpApp e1 op e2) zonkExpr e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (OpApp new_e1 new_op new_e2) -zonkExpr (NegApp _) = panic "zonkExpr:NegApp" -zonkExpr (HsPar _) = panic "zonkExpr:HsPar" +zonkExpr (NegApp _ _) = panic "zonkExpr:NegApp" +zonkExpr (HsPar _) = panic "zonkExpr:HsPar" zonkExpr (SectionL expr op) = zonkExpr expr `thenNF_Tc` \ new_expr -> @@ -367,11 +367,17 @@ zonkExpr (ExplicitTuple exprs) returnNF_Tc (ExplicitTuple new_exprs) zonkExpr (RecordCon con rbinds) - = panic "zonkExpr:RecordCon" -zonkExpr (RecordUpd exp rbinds) - = panic "zonkExpr:RecordUpd" -zonkExpr (RecordUpdOut exp ids rbinds) - = panic "zonkExpr:RecordUpdOut" + = zonkExpr con `thenNF_Tc` \ new_con -> + zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> + returnNF_Tc (RecordCon new_con new_rbinds) + +zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd" + +zonkExpr (RecordUpdOut expr ids rbinds) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + mapNF_Tc zonkId ids `thenNF_Tc` \ new_ids -> + zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> + returnNF_Tc (RecordUpdOut new_expr new_ids new_rbinds) zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig" zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" @@ -490,6 +496,17 @@ zonkStmts stmts zonk_stmt (LetStmt binds) = zonkBinds binds `thenNF_Tc` \ new_binds -> returnNF_Tc (LetStmt new_binds) + +------------------------------------------------------------------------- +zonkRbinds :: TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds + +zonkRbinds rbinds + = mapNF_Tc zonk_rbind rbinds + where + zonk_rbind (field, expr, pun) + = zonkId field `thenNF_Tc` \ new_field -> + zonkExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (new_field, new_expr, pun) \end{code} %************************************************************************ @@ -535,9 +552,18 @@ zonkPat (ListPat ty pats) returnNF_Tc (ListPat new_ty new_pats) zonkPat (TuplePat pats) - = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> + = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> returnNF_Tc (TuplePat new_pats) +zonkPat (RecPat n ty rpats) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + mapNF_Tc zonk_rpat rpats `thenNF_Tc` \ new_rpats -> + returnNF_Tc (RecPat n new_ty new_rpats) + where + zonk_rpat (f, pat, pun) + = zonkPat pat `thenNF_Tc` \ new_pat -> + returnNF_Tc (f, new_pat, pun) + zonkPat (LitPat lit ty) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> returnNF_Tc (LitPat lit new_ty) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index ac3c4d0..e910658 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -71,7 +71,7 @@ import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon, ) import PprStyle import Pretty -import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) +import RnUtils ( RnEnv(..) ) import TyCon ( derivedFor ) import Type ( GenType(..), ThetaType(..), mkTyVarTys, splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy, @@ -159,13 +159,13 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. tcInstDecls1 :: Bag RenamedInstDecl -> [RenamedSpecInstSig] -> Module -- module name for deriving - -> GlobalNameMappers -- renamer fns for deriving + -> RnEnv -- for renaming derivings -> [RenamedFixityDecl] -- fixities for deriving -> TcM s (Bag InstInfo, RenamedHsBinds, PprStyle -> Pretty) -tcInstDecls1 inst_decls specinst_sigs mod_name renamer_name_funs fixities +tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities = -- Do the ordinary instance declarations mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls `thenNF_Tc` \ inst_info_bags -> @@ -176,7 +176,7 @@ tcInstDecls1 inst_decls specinst_sigs mod_name renamer_name_funs fixities -- for things in this module; we ignore deriving decls from -- interfaces! We pass fixities, because they may be used -- in deriving Read and Show. - tcDeriving mod_name renamer_name_funs decl_inst_info fixities + tcDeriving mod_name rn_env decl_inst_info fixities `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) -> let diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 1f2b513..9f2df4d 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -42,7 +42,7 @@ import Maybes ( catMaybes ) import Name ( isExported, isLocallyDefined ) import PrelInfo ( unitTy, mkPrimIoTy ) import Pretty -import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) +import RnUtils ( RnEnv(..) ) import TyCon ( TyCon ) import Type ( mkSynTy ) import Unify ( unifyTauTy ) @@ -59,7 +59,7 @@ tycon_specs = emptyFM \end{code} \begin{code} -tcModule :: GlobalNameMappers -- final renamer info for derivings +tcModule :: RnEnv -- for renaming derivings -> RenamedHsModule -- input -> TcM s ((TypecheckedHsBinds, -- record selector binds TypecheckedHsBinds, -- binds from class decls; does NOT @@ -81,7 +81,7 @@ tcModule :: GlobalNameMappers -- final renamer info for derivings PprStyle -> Pretty) -- -ddump-deriving info -tcModule renamer_name_funs +tcModule rn_env (HsModule mod_name verion exports imports fixities ty_decls specdata_sigs cls_decls inst_decls specinst_sigs default_decls val_decls sigs src_loc) @@ -111,7 +111,7 @@ tcModule renamer_name_funs tcSetEnv env ( --trace "tcInstDecls:" $ tcInstDecls1 inst_decls_bag specinst_sigs - mod_name renamer_name_funs fixities + mod_name rn_env fixities ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) -> buildInstanceEnvs inst_info `thenTc` \ inst_mapper -> diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index b23cf37..9be9dde 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -24,7 +24,7 @@ module TcMonad( tcNewMutVar, tcReadMutVar, tcWriteMutVar, - rn4MtoTcM, + rnMtoTcM, TcError(..), TcWarning(..), mkTcErr, arityErr, @@ -44,8 +44,8 @@ import ErrUtils ( Error(..), Message(..), ErrCtxt(..), Warning(..) ) import SST ---import RnMonad4 ---LATER:import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) +import RnMonad ( RnM(..), RnDown, initRn, setExtraRn ) +import RnUtils ( RnEnv(..) ) import Bag ( Bag, emptyBag, isEmptyBag, foldBag, unitBag, unionBags, snocBag ) @@ -446,24 +446,21 @@ getErrCtxt (TcDown def us loc ctxt errs) = ctxt %~~~~~~~~~~~~~~~~~~ \begin{code} -rn4MtoTcM = panic "TcMonad.rn4MtoTcM (ToDo LATER)" -{- LATER: -rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error) +rnMtoTcM :: RnEnv -> RnM _RealWorld a -> NF_TcM s (a, Bag Error) -rn4MtoTcM name_funs rn_action down env +rnMtoTcM rn_env rn_action down env = readMutVarSST u_var `thenSST` \ uniq_supply -> let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply in writeMutVarSST u_var new_uniq_supply `thenSST_` let - (rn_result, rn_errs) - = rn_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc + (rn_result, rn_errs, rn_warns) + = initRn True (panic "rnMtoTcM:module") rn_env uniq_s rn_action in returnSST (rn_result, rn_errs) where u_var = getUniqSupplyVar down --} \end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 9c8d253..3daadf6 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -76,6 +76,13 @@ tcPat WildPatIn = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty -> returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty) +tcPat (NegPatIn pat) + = tcPat (negate_lit pat) + where + negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i)) + negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f)) + negate_lit _ = panic "TcPat:negate_pat" + tcPat (ParPatIn parend_pat) = tcPat parend_pat \end{code} @@ -164,7 +171,7 @@ tcPat pat_in@(ConPatIn name pats) lie, data_ty) -tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form... +tcPat pat_in@(ConOpPatIn pat1 op pat2) -- in binary-op form... = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) -> tcPat pat2 `thenTc` \ (pat2', lie2, ty2) -> @@ -193,13 +200,13 @@ tcPat pat_in@(RecPatIn name rpats) (_, record_ty) = splitFunTy con_tau in -- Con is syntactically constrained to be a data constructor - ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) ) + ASSERT( maybeToBool (maybeAppDataTyCon record_ty) ) mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) -> - returnTc (panic "tcPat:RecPatIn:avoid type errors"{-RecPat con_id record_ty rpats', + returnTc (RecPat con_id record_ty rpats', plusLIEs lies, - record_ty-}) + record_ty) where do_bind expected_record_ty (field_label, rhs_pat, pun_flag) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 73916b6..f167f89 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -169,7 +169,7 @@ mkDataBinds tycon returnTc (con_ids ++ sel_ids, SingleBind $ NonRecBind $ foldr AndMonoBinds - (foldr AndMonoBinds EmptyMonoBinds con_binds) + (foldr AndMonoBinds EmptyMonoBinds sel_binds) con_binds ) where @@ -323,7 +323,7 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon) mk_match (con_id, field_label) - = PatMatch (RecPat con_id data_ty' [(RealId selector_id, VarPat field_id, False)]) $ + = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $ SimpleMatch $ HsVar field_id in diff --git a/ghc/compiler/typecheck/Typecheck.lhs b/ghc/compiler/typecheck/Typecheck.lhs index 5c260a2..f9e79c8 100644 --- a/ghc/compiler/typecheck/Typecheck.lhs +++ b/ghc/compiler/typecheck/Typecheck.lhs @@ -21,7 +21,7 @@ import TcHsSyn import ErrUtils ( Warning(..), Error(..) ) import Pretty -import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) +import RnUtils ( RnEnv(..) ) import Maybes ( MaybeErr(..) ) \end{code} @@ -35,7 +35,7 @@ ToDo: Interfaces for interpreter ... \begin{code} typecheckModule :: UniqSupply -- name supply in - -> GlobalNameMappers -- renamer info (for doing derivings) + -> RnEnv -- renamer env (for doing derivings) -> RenamedHsModule -- input module -> -- OUTPUTS ... @@ -68,6 +68,6 @@ typecheckModule (Bag Error, -- pretty-print this to get errors Bag Warning) -- pretty-print this to get warnings -typecheckModule us renamer_name_funs mod - = initTc us (tcModule renamer_name_funs mod) +typecheckModule us rn_env mod + = initTc us (tcModule rn_env mod) \end{code} diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index f7f9594..6710032 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -38,22 +38,24 @@ module FiniteMap ( emptyFM, unitFM, listToFM, - addToFM, addListToFM, - IF_NOT_GHC(addToFM_C COMMA) + addToFM, + addToFM_C, + addListToFM, addListToFM_C, IF_NOT_GHC(delFromFM COMMA) delListFromFM, - plusFM, plusFM_C, - IF_NOT_GHC(intersectFM COMMA intersectFM_C COMMA) - minusFM, -- exported for GHCI only + plusFM, + plusFM_C, + minusFM, -- exported for GHCI only + IF_NOT_GHC(intersectFM COMMA) + IF_NOT_GHC(intersectFM_C COMMA) IF_NOT_GHC(mapFM COMMA foldFM COMMA filterFM COMMA) - IF_NOT_GHC(sizeFM COMMA) - isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM, + sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM, - fmToList, keysFM, eltsFM{-used in GHCI-} + fmToList, keysFM, eltsFM #ifdef COMPILING_GHC , bagToFM