diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 2fdf11e5d524a170699fa109a95c5e496d71909f..205c2c77d13451c95fd602b5d115ca2630bbcdc7 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -586,7 +586,7 @@ availNames (AvailTC n ns) = ns filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available -> AvailInfo -- Resulting available; - -- NotAvailable if wanted stuff isn't there + -- NotAvailable if (any of the) wanted stuff isn't there filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) | sub_names_ok = AvailTC n (filter is_wanted ns) @@ -603,8 +603,7 @@ filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) AvailTC n [n] - -filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms +filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail filterAvail (IEVar _) avail@(Avail n) = avail filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) @@ -615,9 +614,10 @@ filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) -- import A( op ) -- where op is a class operation -filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail -filterAvail ie avail = NotAvailable +#ifdef DEBUG +filterAvail ie avail = pprPanic "filterAvail" (ppr ie $$ pprAvail avail) +#endif -- In interfaces, pprAvail gets given the OccName of the "host" thing diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 3be854e591f6cd82c5bb7422c87e1dde0517f242..9471b3c00821f41d12d7d72149f6372aebea385a 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -192,9 +192,7 @@ importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod i if null avails then -- If there's an error in getInterfaceExports, (e.g. interface - -- file not found) then avail might be NotAvailable, so availName - -- in home_modules fails. Hence the guard here. Also we get lots - -- of spurious errors from 'filterImports' if we don't find the interface file + -- file not found) we get lots of spurious errors from 'filterImports' returnRn (emptyRdrEnv, mkEmptyExportAvails mod) else @@ -207,12 +205,20 @@ importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod i home_modules = [name | avail <- filtered_avails, -- Doesn't take account of hiding, but that doesn't matter + -- Drop NotAvailables. + -- Happens if filterAvail finds something missing + case avail of + NotAvailable -> False + other -> True, + let name = availName avail, - nameModule name /= mod] - -- This predicate is a bit of a hack. + nameModule (availName avail) /= mod + -- This nameModule predicate is a bit of a hack. -- PrelBase imports error from PrelErr.hi-boot; but error is -- wired in, so its provenance doesn't say it's from an hi-boot -- file. Result: disaster when PrelErr.hi doesn't exist. + -- [Jan 99: I now can't see how the predicate achieves the goal!] + ] same_module n1 n2 = nameModule n1 == nameModule n2 load n = loadHomeInterface (doc_str n) n diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 0c673e6132722d030b3717d9d82ed3b4946b33ab..b6c6c627d41b0674225d60a2c24fbfbeb34f0122 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -153,7 +153,7 @@ rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragma returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc), cxt_fvs `plusFV` plusFVs con_fvs_s `plusFV` deriv_fvs) where - data_doc = text "the data typecodeGen/ declaration for" <+> ppr tycon + data_doc = text "the data type declaration for" <+> ppr tycon con_names = map conDeclName condecls rnDecl (TyClD (TySynonym name tyvars ty src_loc)) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index a1be69a71cb624772b69ba29276dcb9a4272e70f..84fc1d92c9946d55a85b8665a154299c1a8887d0 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -464,11 +464,12 @@ tcMonoExpr (RecordCon con_name rbinds) res_ty let bad_fields = badFields rbinds data_con in - mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_` + if not (null bad_fields) then + mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_` + failTc -- Fail now, because tcRecordBinds will crash on a bad field + else -- Typecheck the record bindings - -- (Do this after checkRecordFields in case there's a field that - -- doesn't match the constructor.) tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)