satisfying John's pervert and bizarre wishes for better error messages

concerning specified instance types, that by far go beyond the standards
of Clean 1.3.3


git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@392 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d

5 files changed, 84 insertions, 11 deletions

diff --git a/frontend/check.icl b/frontend/check.icl
index 4a035e2..994dd7d 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -2044,16 +2044,27 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func
 			  			No
 			  				-> (cs_error, type_heaps)
 			  			Yes specified_symbol_type
-							# (symbol_types_correspond, type_heaps)
+							# (err_code, type_heaps)
 							  		= symbolTypesCorrespond specified_symbol_type derived_symbol_type
 							  				type_heaps
-							| symbol_types_correspond
+							| err_code==CEC_Ok
 								-> (cs_error, type_heaps)
 							# cs_error
 									= pushErrorAdmin (newPosition fun_symb fun_pos)
 											cs_error
+							  luxurious_explanation
+							  		= case err_code of
+							  			CEC_ResultNotOK -> "result type"
+										CEC_ArgNrNotOk -> "nr or arguments"
+										CEC_ContextNotOK -> "context"
+										CEC_AttrEnvNotOK -> "attribute environment"
+										1 -> "first argument"
+										2 -> "second argument"
+										3 -> "third argument"
+										_ -> toString err_code+++"th argument"
 							  cs_error
-							  		= checkError "the specified member type is incorrect" "" cs_error
+							  		= checkError "the specified member type is incorrect ("
+											(luxurious_explanation+++" not ok)") cs_error
 							-> ( popErrorAdmin cs_error, type_heaps)
 			= (icl_functions, type_heaps, cs_error)
 
diff --git a/frontend/comparedefimp.dcl b/frontend/comparedefimp.dcl
index 2c099d2..be5210b 100644
--- a/frontend/comparedefimp.dcl
+++ b/frontend/comparedefimp.dcl
@@ -7,4 +7,12 @@ import syntax, checksupport
 compareDefImp :: !{#Int} !{!FunctionBody} !Int !{#CheckedTypeDef} !DclModule !*IclModule !*Heaps !*ErrorAdmin 
 				-> (!.IclModule,!.Heaps,!.ErrorAdmin)
 
-symbolTypesCorrespond :: !SymbolType !SymbolType !*TypeHeaps -> (!Bool, !.TypeHeaps)
+symbolTypesCorrespond :: !SymbolType !SymbolType !*TypeHeaps -> (!ComparisionErrorCode, !.TypeHeaps)
+
+:: ComparisionErrorCode :== Int
+// arg n not ok: n
+CEC_ResultNotOK :== 0
+CEC_Ok :== -1
+CEC_ArgNrNotOk :== -2
+CEC_ContextNotOK :== -3
+CEC_AttrEnvNotOK :== -4
diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl
index fb6d1f4..5a9364e 100644
--- a/frontend/comparedefimp.icl
+++ b/frontend/comparedefimp.icl
@@ -51,6 +51,14 @@ import syntax, checksupport, compare_constructor, utilities, StdCompare
 
 :: OptionalCorrespondenceNumber = CorrespondenceNumber !Int | Unbound
 	
+:: ComparisionErrorCode :== Int
+// arg n not ok: n
+CEC_ResultNotOK :== 0
+CEC_Ok :== -1
+CEC_ArgNrNotOk :== -2
+CEC_ContextNotOK :== -3
+CEC_AttrEnvNotOK :== -4
+
 class t_corresponds a :: !a !a -> *TypesCorrespondMonad
 	// whether two types correspond
 class e_corresponds a :: !a !a -> ExpressionsCorrespondMonad
@@ -171,28 +179,52 @@ compareTwoFunctionTypes conversions	dcl_fun_types dclIndex (icl_functions, tc_st
 		No	-> generate_error "type of exported function is missing" fun_def icl_functions tc_state error_admin
 		Yes icl_symbol_type
 			# {ft_type=dcl_symbol_type, ft_priority} = dcl_fun_types.[dclIndex]
+			  tc_state
+			  		= init_symbol_type_vars dcl_symbol_type icl_symbol_type tc_state
 			  (corresponds, tc_state)
-					= symbol_types_correspond dcl_symbol_type icl_symbol_type tc_state // --->("comparing:", dcl_symbol_type ,icl_symbol_type)
+					= t_corresponds dcl_symbol_type icl_symbol_type tc_state // --->("comparing:", dcl_symbol_type ,icl_symbol_type)
 			| corresponds && fun_priority==ft_priority
 				-> (icl_functions, tc_state, error_admin)
 			-> generate_error error_message fun_def icl_functions tc_state error_admin
 
-symbolTypesCorrespond :: !SymbolType !SymbolType !*TypeHeaps -> (!Bool, !.TypeHeaps)
+symbolTypesCorrespond :: !SymbolType !SymbolType !*TypeHeaps -> (!ComparisionErrorCode, !.TypeHeaps)
 symbolTypesCorrespond symbol_type_1 symbol_type_2 type_heaps=:{th_vars, th_attrs}
+	| length symbol_type_1.st_args<>length symbol_type_2.st_args
+		= (CEC_ArgNrNotOk, type_heaps)
 	# tc_state
 			= { tc_type_vars = initial_hwn th_vars
 			  , tc_attr_vars = initial_hwn th_attrs
 			  , tc_ignore_strictness = True
 			  }
-	  (correspond, {tc_type_vars, tc_attr_vars})
-	  		= symbol_types_correspond symbol_type_1 symbol_type_2 tc_state
-	= (correspond, { type_heaps & th_vars = tc_type_vars.hwn_heap, th_attrs = tc_attr_vars.hwn_heap})
+	  tc_state
+	  		= init_symbol_type_vars symbol_type_1 symbol_type_2 tc_state
+	  (correspond_list, tc_state)
+	  		= map2St t_corresponds
+	  				[symbol_type_1.st_result:symbol_type_1.st_args]
+	  				[symbol_type_2.st_result:symbol_type_2.st_args]
+	  		        tc_state
+	  err_code
+	  		= firstIndex not correspond_list
+	| err_code<>CEC_Ok
+		= (err_code, tc_state_to_type_heaps tc_state)
+	# (context_corresponds, tc_state)
+			= t_corresponds symbol_type_1.st_context symbol_type_2.st_context tc_state
+	| not context_corresponds
+		= (CEC_ContextNotOK, tc_state_to_type_heaps tc_state)
+	# (attr_env_corresponds, tc_state)
+			= t_corresponds symbol_type_1.st_attr_env symbol_type_2.st_attr_env tc_state
+	| not attr_env_corresponds
+		= (CEC_AttrEnvNotOK, tc_state_to_type_heaps tc_state)
+	= (CEC_Ok, tc_state_to_type_heaps tc_state)
+  where
+	tc_state_to_type_heaps {tc_type_vars, tc_attr_vars}
+		= { th_vars = tc_type_vars.hwn_heap, th_attrs = tc_attr_vars.hwn_heap}
 
-symbol_types_correspond symbol_type_1 symbol_type_2 tc_state
+init_symbol_type_vars symbol_type_1 symbol_type_2 tc_state
 	# tc_state = init_attr_vars (symbol_type_1.st_attr_vars++symbol_type_2.st_attr_vars)
 								tc_state
 	  tc_state = init_type_vars (symbol_type_1.st_vars++symbol_type_2.st_vars) tc_state
-	= t_corresponds symbol_type_1 symbol_type_2 tc_state // --->("comparing:", dcl_symbol_type ,icl_symbol_type)
+	= tc_state
 
 init_type_vars type_vars tc_state=:{tc_type_vars}
 	# tc_type_vars = init_type_vars` type_vars tc_type_vars
diff --git a/frontend/utilities.dcl b/frontend/utilities.dcl
index 232330c..965f872 100644
--- a/frontend/utilities.dcl
+++ b/frontend/utilities.dcl
@@ -46,6 +46,17 @@ second_of_2_tuple t :== e2
 	where
 		(_,e2) = t
 
+map2St f l1 l2 st :== map2_st l1 l2 st
+  where
+	map2_st [h1:t1] [h2:t2] st
+		# (h, st) = f h1 h2 st
+		  (t, st) = map2_st t1 t2 st
+		#! st = st
+		= ([h:t], st)
+	map2_st _ _ st
+		#! st = st
+		= ([], st)
+
 app2St :: !(!.(.a -> .(.st -> (.c,.st))),!.(.e -> .(.st -> (.f,.st)))) !(.a,.e) !.st -> (!(.c,.f),!.st)
 
 mapAppendSt :: !(.a -> .(.b -> (.c,.b))) ![.a] !u:[.c] !.b -> !(!u:[.c],!.b)
diff --git a/frontend/utilities.icl b/frontend/utilities.icl
index 3ceb48b..50dd8d2 100644
--- a/frontend/utilities.icl
+++ b/frontend/utilities.icl
@@ -139,6 +139,17 @@ second_of_2_tuple t :== e2
 	where
 		(_,e2) = t
 
+map2St f l1 l2 st :== map2_st l1 l2 st
+  where
+	map2_st [h1:t1] [h2:t2] st
+		# (h, st) = f h1 h2 st
+		  (t, st) = map2_st t1 t2 st
+		#! st = st
+		= ([h:t], st)
+	map2_st _ _ st
+		#! st = st
+		= ([], st)
+
 app2St :: !(!.(.a -> .(.st -> (.c,.st))),!.(.e -> .(.st -> (.f,.st)))) !(.a,.e) !.st -> (!(.c,.f),!.st)
 app2St (f,g) (x,y) s
  	# (x, s) = f x s