Commit 42c69944 authored by Martin Wierich's avatar Martin Wierich
Browse files

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
parent 0cbab374
......@@ -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)
......
......@@ -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
......@@ -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
......
......@@ -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)
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment