X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=6bf8c3202334066abdbcc5cc1331e426a73157e4;hb=b2d205e39c0e2cdb054c53c6a3f14c9489f6b9b5;hp=f6f822b40fc964c90544d56a8165ee6ae3019a0d;hpb=53f7c67bbab823da1b39925b067a30a1430f868e;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index f6f822b..6bf8c32 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -53,9 +53,7 @@ import TcType		( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
 			)
 import FieldLabel	( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
 import Id		( Id, idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe )
-import DataCon		( dataConFieldLabels, dataConSig, 
-			  dataConStrictMarks
-			)
+import DataCon		( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks )
 import Name		( Name, isExternalName )
 import TyCon		( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
 import Subst		( mkTopTyVarSubst, substTheta, substTy )
@@ -405,16 +403,8 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
 	-- Typecheck the record bindings
     tcRecordBinds tycon ty_args rbinds		`thenM` \ rbinds' ->
     
-    let
-      (missing_s_fields, missing_fields) = missingFields rbinds data_con
-    in
-    checkM (null missing_s_fields)
-	(mappM_ (addErrTc . missingStrictFieldCon con_name) missing_s_fields)
-	 				`thenM_`
-    doptM Opt_WarnMissingFields		`thenM` \ warn ->
-    checkM (not (warn && notNull missing_fields))
-	(mappM_ ((warnTc True) . missingFieldCon con_name) missing_fields)
-	 				`thenM_`
+ 	-- Check for missing fields
+    checkMissingFields data_con rbinds		`thenM_` 
 
     returnM (RecordConOut data_con con_expr rbinds')
 
@@ -981,18 +971,31 @@ badFields rbinds data_con
   where
     field_names = map fieldLabelName (dataConFieldLabels data_con)
 
-missingFields rbinds data_con
-  | null field_labels = ([], [])	-- Not declared as a record;
-					-- But C{} is still valid
-  | otherwise	
-  = (missing_strict_fields, other_missing_fields)
+checkMissingFields :: DataCon -> RenamedRecordBinds -> TcM ()
+checkMissingFields data_con rbinds
+  | null field_labels 	-- Not declared as a record;
+			-- But C{} is still valid if no strict fields
+  = if any isMarkedStrict field_strs then
+	-- Illegal if any arg is strict
+	addErrTc (missingStrictFields data_con [])
+    else
+	returnM ()
+			
+  | otherwise		-- A record
+  = checkM (null missing_s_fields)
+	   (addErrTc (missingStrictFields data_con missing_s_fields))	`thenM_`
+
+    doptM Opt_WarnMissingFields		`thenM` \ warn ->
+    checkM (not (warn && notNull missing_ns_fields))
+	   (warnTc True (missingFields data_con missing_ns_fields))
+
   where
-    missing_strict_fields
+    missing_s_fields
 	= [ fl | (fl, str) <- field_info,
 	  	 isMarkedStrict str,
 	  	 not (fieldLabelName fl `elem` field_names_used)
 	  ]
-    other_missing_fields
+    missing_ns_fields
 	= [ fl | (fl, str) <- field_info,
 	  	 not (isMarkedStrict str),
 	  	 not (fieldLabelName fl `elem` field_names_used)
@@ -1003,7 +1006,9 @@ missingFields rbinds data_con
 
     field_info = zipEqual "missingFields"
 			  field_labels
-	  		  (dropList ex_theta (dataConStrictMarks data_con))
+	  		  field_strs
+
+    field_strs = dropList ex_theta (dataConStrictMarks data_con)
 	-- The 'drop' is because dataConStrictMarks
 	-- includes the existential dictionaries
     (_, _, _, ex_theta, _, _) = dataConSig data_con
@@ -1122,15 +1127,22 @@ recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
 notSelector field
   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
 
-missingStrictFieldCon :: Name -> FieldLabel -> SDoc
-missingStrictFieldCon con field
-  = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
-	  ptext SLIT("does not have the required strict field"), quotes (ppr field)]
-
-missingFieldCon :: Name -> FieldLabel -> SDoc
-missingFieldCon con field
-  = hsep [ptext SLIT("Field") <+> quotes (ppr field),
-	  ptext SLIT("is not initialised")]
+missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
+missingStrictFields con fields
+  = header <> rest
+  where
+    rest | null fields = empty	-- Happens for non-record constructors 
+				-- with strict fields
+	 | otherwise   = colon <+> pprWithCommas ppr fields
+
+    header = ptext SLIT("Constructor") <+> quotes (ppr con) <+> 
+	     ptext SLIT("does not have the required strict fields") 
+	  
+
+missingFields :: DataCon -> [FieldLabel] -> SDoc
+missingFields con fields
+  = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:") 
+	<+> pprWithCommas ppr fields
 
 polySpliceErr :: Id -> SDoc
 polySpliceErr id