[project @ 1999-01-05 12:22:08 by simonpj]

Fix renamer crash on bootstrap build

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

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

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))

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)