ConsVariables were not handled correctly within improved type error messages

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

4 files changed, 233 insertions, 20 deletions

diff --git a/frontend/StdCompare.dcl b/frontend/StdCompare.dcl
index 72491e3..4dc74d5 100644
--- a/frontend/StdCompare.dcl
+++ b/frontend/StdCompare.dcl
@@ -14,7 +14,7 @@ instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, (Global
 instance =< Type, SymbIdent
 
 instance == BasicType, TypeVar, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue,
-			FunKind, (Global a) | == a, Priority, Assoc, Type
+			FunKind, (Global a) | == a, Priority, Assoc, Type, ConsVariable
 
 instance < MemberDef
 
diff --git a/frontend/StdCompare.icl b/frontend/StdCompare.icl
index 4dc82c4..adb6e99 100644
--- a/frontend/StdCompare.icl
+++ b/frontend/StdCompare.icl
@@ -31,8 +31,8 @@ instance == ConsVariable
 where
 	(==) (CV tv1) (CV tv2)			= tv1 == tv2
 	(==) (TempCV tv1) (TempCV tv2)	= tv1 == tv2
-	(==) cv1 cv2					= False
-
+	(==) (TempQCV tv1) (TempQCV tv2)	= tv1 == tv2 // MW4++
+// MW4 removed:	(==) cv1 cv2					= False
 
 instance == TypeContext
 where
diff --git a/frontend/trans.icl b/frontend/trans.icl
index 3ba0218..390906d 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -1542,6 +1542,194 @@ accTypeVarHeap f type_heaps :== let (r, th_vars) = f type_heaps.th_vars in (r, {
 
 createBindingsForUnifiedTypes :: !AType !AType ![TypeVar] !{#CommonDefs} !*TypeHeaps -> (![TypeVar], !.TypeHeaps)
 createBindingsForUnifiedTypes type_1 type_2 all_type_vars common_defs type_heaps=:{th_vars}
+	= undef
+
+createBindingsForUnifiedTypes2 :: !AType !AType ![TypeVar] !{#CommonDefs} !*TypeHeaps -> (![TypeVar], !.TypeHeaps)
+createBindingsForUnifiedTypes2 sub_type type all_type_vars common_defs type_heaps=:{th_vars}
+/* unify the two type arguments and generate new bindings. The resulting list of type variables should only
+   contain variables that occur in the second type argument (the "demanded" type).
+*/
+	# th_vars = foldSt (\tv th_vars -> th_vars <:= (tv.tv_info_ptr, TVI_Empty)) all_type_vars th_vars
+	  (type_heaps=:{th_vars}) = bind_and_unify_atypes sub_type type False [] common_defs { type_heaps & th_vars = th_vars }
+//	  th_vars = th_vars -!-> ""
+//	  th_vars = foldSt trace_type_var all_type_vars th_vars
+	  th_vars = foldSt (\ a b -> snd (bind_to_root a b)) all_type_vars th_vars
+//	  th_vars = th_vars -!-> ""
+//	  th_vars = foldSt trace_type_var all_type_vars th_vars
+	  (unbound_type_vars, th_vars) = foldSt get_unbound_var all_type_vars ([], th_vars)
+//	  th_vars = th_vars -!-> ""
+//	  th_vars = foldSt trace_type_var all_type_vars th_vars
+	= (unbound_type_vars, { type_heaps & th_vars = th_vars })
+  where
+	bind_and_unify_types (TV tv_1) (TV tv_2) common_defs type_heaps=:{th_vars}
+		# (root_1, th_vars) = get_root tv_1 th_vars
+		  (root_2, th_vars) = get_root tv_2 th_vars
+		  maybe_root_tv_1 = only_tv root_1
+		  maybe_root_tv_2 = only_tv root_2
+		  type_heaps = { type_heaps & th_vars = th_vars }
+		= case (maybe_root_tv_1, maybe_root_tv_2) of
+						(Yes root_tv_1, No)
+							-> appTypeVarHeap (bind_root_variable_to_type root_tv_1 root_2) type_heaps
+						(No, Yes root_tv_2)
+							-> appTypeVarHeap (bind_root_variable_to_type root_tv_2 root_1) type_heaps
+						(Yes root_tv_1, Yes root_tv_2)
+							| root_tv_1.tv_info_ptr==root_tv_2.tv_info_ptr
+								-> type_heaps
+							-> appTypeVarHeap (bind_roots_together root_tv_1 root_2) type_heaps
+						(No, No)
+							-> bind_and_unify_types root_1 root_2 common_defs type_heaps
+	bind_and_unify_types (TV tv_1) type common_defs type_heaps=:{th_vars}
+		| not (is_non_variable_type type)
+			= abort ("compiler error in trans.icl: assertion failed (1) XXX"--->type)
+		# th_vars = bind_variable_to_type tv_1 type th_vars
+		= { type_heaps & th_vars = th_vars }
+	bind_and_unify_types type (TV tv_1) common_defs type_heaps=:{th_vars}
+		| not (is_non_variable_type type)
+			= abort ("compiler error in trans.icl: assertion failed (2) XXX"--->type)
+		# th_vars = bind_variable_to_type tv_1 type th_vars
+		= { type_heaps & th_vars = th_vars }
+	bind_and_unify_types (TA _ arg_types1) (TA _ arg_types2) common_defs type_heaps
+		= bind_and_unify_atype_lists arg_types1 arg_types2 common_defs type_heaps
+	bind_and_unify_types (l1 --> r1) (l2 --> r2) common_defs type_heaps
+		= bind_and_unify_atypes r1 r2 common_defs (bind_and_unify_atypes l1 l2 common_defs type_heaps)
+	bind_and_unify_types (TB _) (TB _) common_defs type_heaps
+		= type_heaps
+	bind_and_unify_types ((CV l1) :@: r1) ((CV l2) :@: r2) common_defs type_heaps
+		= bind_and_unify_atype_lists r1 r2 common_defs (bind_and_unify_types (TV l1) (TV l2) common_defs type_heaps)
+	bind_and_unify_types (TA type_symb r1) ((CV l2) :@: r2) common_defs type_heaps
+		= bind_and_unify_atype_lists r1 r2 common_defs (bind_and_unify_types (TA type_symb []) (TV l2) common_defs type_heaps)
+	bind_and_unify_types ((CV l1) :@: r1) (TA type_symb r2) common_defs type_heaps
+		= bind_and_unify_atype_lists r1 r2 common_defs (bind_and_unify_types (TV l1) (TA type_symb []) common_defs type_heaps)
+	bind_and_unify_types TE y common_defs type_heaps
+		= type_heaps
+	bind_and_unify_types x TE common_defs type_heaps
+		= type_heaps
+	bind_and_unify_types x y _ _
+		= abort ("bind_and_unify_types"--->(x,y))
+
+	bind_and_unify_atype_lists [] [] common_defs type_heaps
+		= type_heaps
+	bind_and_unify_atype_lists [x:xs] [y:ys] common_defs type_heaps
+		= bind_and_unify_atype_lists xs ys common_defs (bind_and_unify_atypes x y common_defs type_heaps)
+	
+	bind_and_unify_atypes	{at_type=TA type_symb_1 type_args_1, at_attribute = sub_attr}
+							{at_type=TA type_symb_2 type_args_2} at_attribute =     attr}
+							is_plusmin_sign inequalities_accu common_defs type_heaps
+		| type_symb_1==type_symb_2
+			= bind_and_unify_atype_lists type_args_1 type_args_2 is_plusmin_sign 
+										(add_inequality is_plusmin_sign sub_attr attr inequalities_accu)
+										common_defs type_heaps
+		// otherwise further with next alternative ("functional GOTO")
+/* XXX
+	bind_and_unify_atypes atype_1 atype_2 common_defs type_heaps
+		# (mb_expanded_1, type_heaps) = try_to_expand atype_1 common_defs type_heaps
+		  (mb_expanded_2, type_heaps) = try_to_expand atype_2 common_defs type_heaps
+		= bind_and_unify_types mb_expanded_1 mb_expanded_2 common_defs type_heaps
+	  where
+		try_to_expand {at_type=actual_type=:TA {type_index={glob_object,glob_module}} actual_args, at_attribute=actual_type_attr}
+						common_defs type_heaps
+			#! type_def = common_defs.[glob_module].com_type_defs.[glob_object]
+			= case type_def.td_rhs of
+				SynType {at_type=rhs_type}
+					-> expandTypeApplication type_def.td_args type_def.td_attribute rhs_type actual_args actual_type_attr type_heaps
+				_
+					-> (actual_type, type_heaps)
+		try_to_expand {at_type} _ type_heaps
+			= (at_type, type_heaps)
+*/
+::	TypeSymbIdent =
+	{	type_name		:: !Ident
+	,	type_arity		:: !Int
+	,	type_index		:: !Global Index
+	,	type_prop		:: !TypeSymbProperties
+	}
+
+::	TypeSymbProperties =
+	{	tsp_sign		:: !SignClassification
+	,	tsp_propagation	:: !PropClassification
+	,	tsp_coercible	:: !Bool
+	}
+
+
+	bind_to_root :: !TypeVar !*TypeVarHeap -> (!TypeVarInfo,!.TypeVarHeap);
+	bind_to_root this_tv th_vars
+		# (tv_info, th_vars) = readPtr this_tv.tv_info_ptr th_vars
+		= case tv_info of
+			TVI_Empty
+				-> (tv_info, th_vars)
+			(TVI_Type type)
+				| is_non_variable_type type
+					 -> (tv_info, th_vars)
+				-> case type of
+					(TV next_tv)
+						# (root_tvi, th_vars) = bind_to_root next_tv th_vars
+						  th_vars = th_vars <:= (this_tv.tv_info_ptr, root_tvi)
+						-> (root_tvi, th_vars)
+	
+	get_unbound_var tv=:{tv_info_ptr} (unbound_type_vars_accu, th_vars)
+		# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
+		= case tv_info of
+			TVI_Empty
+				-> ([tv:unbound_type_vars_accu], th_vars)
+			(TVI_Type type)
+				-> (unbound_type_vars_accu, th_vars)
+
+	only_tv :: Type -> Optional TypeVar
+	only_tv (TV tv) = Yes tv
+	only_tv _ = No
+	
+	is_non_variable_type (TA _ _)	= True
+	is_non_variable_type (_ --> _)	= True
+	is_non_variable_type (_ :@: _)	= True
+	is_non_variable_type (TB _)		= True
+	is_non_variable_type _			= False
+	
+	bind_variable_to_type tv type th_vars
+		# (root, th_vars) = get_root tv th_vars
+		= case (only_tv root) of
+			(Yes tv)	-> bind_root_variable_to_type tv type th_vars
+			No 			-> th_vars
+	
+	bind_root_variable_to_type {tv_info_ptr} type th_vars
+		= th_vars <:= (tv_info_ptr, TVI_Type type)
+	
+	bind_roots_together :: TypeVar Type *(Heap TypeVarInfo) -> .Heap TypeVarInfo;
+	bind_roots_together root_tv_1 root_type_2 th_vars
+		= th_vars <:= (root_tv_1.tv_info_ptr, TVI_Type root_type_2)
+	
+	get_root :: TypeVar *(Heap TypeVarInfo) -> (Type,.Heap TypeVarInfo);
+	get_root this_tv th_vars
+		# (tv_info, th_vars) = readPtr this_tv.tv_info_ptr th_vars
+		= case tv_info of
+			TVI_Empty
+				-> (TV this_tv, th_vars)
+			(TVI_Type type)
+				| is_non_variable_type type
+					 -> (type, th_vars)
+				-> case type of
+					(TV next_tv) -> get_root next_tv th_vars
+	// XXX for tracing
+	trace_type_var tv th_vars
+		= trace_type_vars tv (th_vars -!-> "TYPE VARIABLE")
+	
+	trace_type_vars this_tv th_vars
+		# th_vars = th_vars -!-> this_tv
+		# (tv_info, th_vars) = readPtr this_tv.tv_info_ptr th_vars
+		= case tv_info of
+			TVI_Empty
+				-> th_vars
+			(TVI_Type type)
+				| is_non_variable_type type
+					-> (th_vars -!-> ("TVI_Type", type))
+				-> case type of
+					(TV next_tv) -> trace_type_vars next_tv th_vars
+//			(TVI_FreshTypeVar root_type_var)
+//				-> th_vars -!-> ("TVI_FreshTypeVar",root_type_var)
+
+	
+/*
+createBindingsForUnifiedTypes :: !AType !AType ![TypeVar] !{#CommonDefs} !*TypeHeaps -> (![TypeVar], !.TypeHeaps)
+createBindingsForUnifiedTypes type_1 type_2 all_type_vars common_defs type_heaps=:{th_vars}
 /* unify the two type arguments and generate new bindings. The resulting list of type variables should only
    contain variables that occur in the second type argument (the "demanded" type).
 */
@@ -1702,7 +1890,7 @@ createBindingsForUnifiedTypes type_1 type_2 all_type_vars common_defs type_heaps
 					(TV next_tv) -> trace_type_vars next_tv th_vars
 //			(TVI_FreshTypeVar root_type_var)
 //				-> th_vars -!-> ("TVI_FreshTypeVar",root_type_var)
-
+*/
 	
 transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_bits} app=:{app_symb,app_args} extra_args ro ti
 	# (app_symb, app_args, extra_args) = complete_application app_symb fun_def.fun_arity app_args extra_args
diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl
index fc84b32..8898a83 100644
--- a/frontend/typesupport.icl
+++ b/frontend/typesupport.icl
@@ -962,9 +962,15 @@ where
 	writeType file opt_beautifulizer (form, type :@: types)
 		| checkProperty form cBrackets
 			# (file, opt_beautifulizer)
-					= writeType (file <<< '(' <<< type <<< ' ') opt_beautifulizer (form, types)
+					= writeType (file <<< '(') opt_beautifulizer (form, type)
+			  (file, opt_beautifulizer)
+					= writeType (file <<< ' ') opt_beautifulizer (form, types)
 			= (file <<< ')', opt_beautifulizer)
-			= writeType (file <<< type <<< ' ') opt_beautifulizer (setProperty form cBrackets, types) 
+			# (file, opt_beautifulizer)
+					= writeType file opt_beautifulizer (form, type)
+			  (file, opt_beautifulizer)
+					= writeType (file <<< ' ') opt_beautifulizer (setProperty form cBrackets, types)
+			= (file, opt_beautifulizer)
 	writeType file opt_beautifulizer (form, TB tb)
 		= (file <<< tb, opt_beautifulizer)
 	writeType file No (form, TQV varid)
@@ -983,22 +989,18 @@ writeWithinBrackets br_open br_close file opt_beautifulizer (form, types)
 			= writeType (file <<< br_open) opt_beautifulizer (form, types)
 	= (file <<< br_close, opt_beautifulizer)
 
-writeBeautifulTypeVar file beautifulizer=:{tvb_visited, tvb_fresh_vars} type_variable
+writeBeautifulTypeVar file beautifulizer=:{tvb_visited_typevars, tvb_fresh_vars} type_variable
 	| sanity_check_failed type_variable
 		= abort "bug nr 12345 in module typesupport"
-	= case lookup type_variable tvb_visited of
+	= case assoc_list_lookup type_variable tvb_visited_typevars of
 		No
-			-> (file <<< hd tvb_fresh_vars, Yes { tvb_visited = [(type_variable, hd tvb_fresh_vars):tvb_visited],
-													tvb_fresh_vars = tl tvb_fresh_vars })
+			-> (file <<< hd tvb_fresh_vars, 
+				Yes { beautifulizer &
+						tvb_visited_typevars = [(type_variable, hd tvb_fresh_vars):tvb_visited_typevars],
+						tvb_fresh_vars = tl tvb_fresh_vars })
 		Yes (_, beautiful_var_name)
 			-> (file <<< beautiful_var_name, Yes beautifulizer)
   where
-	lookup _ [] = No
-	lookup t1 [hd=:(t2, _):tl]
-		| t1==t2
-			= Yes hd
-		= lookup t1 tl
-
 	sanity_check_failed (GTV _)		= False
 	sanity_check_failed (TV _)		= False
 	sanity_check_failed (TempV _)	= False
@@ -1007,6 +1009,27 @@ writeBeautifulTypeVar file beautifulizer=:{tvb_visited, tvb_fresh_vars} type_var
 	sanity_check_failed (TLifted _)	= False
 	sanity_check_failed _			= True
 	
+instance writeType ConsVariable where
+	writeType file No (_, cons_variable)
+		= (file <<< cons_variable, No)
+	writeType file yes_beautifulizer=:(Yes beautifulizer=:{tvb_visited_consvars, tvb_fresh_vars}) 
+			(_, cons_variable)
+		= case assoc_list_lookup cons_variable tvb_visited_consvars of
+			No
+				-> (file <<< hd tvb_fresh_vars, 
+					Yes { beautifulizer &
+							tvb_visited_consvars = [(cons_variable, hd tvb_fresh_vars):tvb_visited_consvars],
+							tvb_fresh_vars = tl tvb_fresh_vars })
+			Yes (_, beautiful_var_name)
+				-> (file <<< beautiful_var_name, yes_beautifulizer)
+
+assoc_list_lookup _ [] = No
+assoc_list_lookup t1 [hd=:(t2, _):tl]
+	| t1==t2
+		= Yes hd
+	= assoc_list_lookup t1 tl
+
+
 cNoPosition :== -1
 	 
 instance writeType [a] | writeType a
@@ -1066,15 +1089,17 @@ where
 
 // MW4..
 :: TypeVarBeautifulizer =
-	{	tvb_visited 	:: ![(Type, String)]
-			// associates type variables with strings, the type should be only GTV, TV, TempV, TQV, TempQV, TLifted.
+	{	tvb_visited_typevars 	:: ![(Type, String)]
+	,	tvb_visited_consvars	:: ![(ConsVariable, String)]
+			// tvb_visited_typevars and tvb_visited_consvars associate type (constructor) variables with
+			// strings, the type in tvb_visited_typevars should be only GTV, TV, TempV, TQV, TempQV, TLifted.
 			// (associations lists are slow but cool)
-	,	tvb_fresh_vars	::	![String]
+	,	tvb_fresh_vars			::	![String]
 	}
 
 initialTypeVarBeautifulizer :: TypeVarBeautifulizer
 initialTypeVarBeautifulizer 
-	= {	tvb_visited = [], tvb_fresh_vars = fresh_vars 'a' (-1) }
+	= {	tvb_visited_typevars = [], tvb_visited_consvars = [], tvb_fresh_vars = fresh_vars 'a' (-1) }
   where
 	fresh_vars 'i' i
 		= fresh_vars 'a' (i+1)