This commit is contained in:
Mylloon 2023-12-06 18:06:52 +01:00
parent 8b3a34ba2d
commit 1f1e58f84f
Signed by: Anri
GPG key ID: A82D63DFF8D1317F

View file

@ -214,7 +214,6 @@ and pattern_tagval
-> HopixTypes.aty * HopixTypes.typing_environment
=
fun tenv cons tlist plist ->
let cons_scheme =
try HopixTypes.lookup_type_scheme_of_constructor cons.position cons.value tenv with
| HopixTypes.Unbound (pos, Constructor (KId c)) ->
@ -233,31 +232,30 @@ and pattern_tagval
invalid_instantiation cons.position expected given
in
let p_args, tenv = synth_list_pattern tenv plist in
(
let expected_args, result =
HopixTypes.destruct_function_type_maximally cons.position tcons
in
(try
List.iter2
(fun expected given -> check_equal_types cons.position ~expected ~given)
expected_args
p_args
with
| Invalid_argument _ ->
(* 35-bad *)
check_equal_types
cons.position
~expected:result
~given:(HopixTypes.ATyArrow (result, result)));
result
),tenv
( (let expected_args, result =
HopixTypes.destruct_function_type_maximally cons.position tcons
in
(try
List.iter2
(fun expected given -> check_equal_types cons.position ~expected ~given)
expected_args
p_args
with
| Invalid_argument _ ->
(* 35-bad *)
check_equal_types
cons.position
~expected:result
~given:(HopixTypes.ATyArrow (result, result)));
result)
, tenv )
and synth_list_pattern tenv = function
| [] -> [], tenv
| p :: plist ->
let ty, tenv = synth_pattern tenv p in
let tys, tenv = synth_list_pattern tenv plist in
ty::tys, tenv
| [] -> [], tenv
| p :: plist ->
let ty, tenv = synth_pattern tenv p in
let tys, tenv = synth_list_pattern tenv plist in
ty :: tys, tenv
and pattern_record
: HopixTypes.typing_environment
@ -266,12 +264,14 @@ and pattern_record
-> HopixTypes.aty * HopixTypes.typing_environment
=
fun tenv plist tlist ->
let label = fst(List.hd plist) in
let type_cons,_,labels =
let LId label_name = label.value in
let label = fst (List.hd plist) in
let type_cons, _, labels =
let (LId label_name) = label.value in
try HopixTypes.lookup_type_constructor_of_label label.position label.value tenv with
| HopixTypes.Unbound (pos, Label (LId i)) ->
HopixTypes.type_error pos (Printf.sprintf "There is no type definition for label `%s'." label_name )
HopixTypes.type_error
pos
(Printf.sprintf "There is no type definition for label `%s'." label_name)
in
let tlist' =
match tlist with
@ -279,26 +279,28 @@ and pattern_record
| None -> HopixTypes.type_error label.position "No types found."
in
let tenv =
List.fold_left (
fun tenv (Position.{ position = label_pos; value = label_val }, pat) ->
let label_scheme =
try HopixTypes.lookup_type_scheme_of_label label_pos label_val tenv with
| HopixTypes.Unbound (pos, Label (LId i)) ->
HopixTypes.type_error pos (Printf.sprintf "Unbound label `%s'." i)
in
let instance_type_scheme =
try HopixTypes.instantiate_type_scheme label_scheme tlist' with
| HopixTypes.InvalidInstantiation { expected; given } ->
invalid_instantiation (Position.position pat) expected given
in
let _,expected = HopixTypes.destruct_function_type label_pos instance_type_scheme in
let (given,tenv) = synth_pattern tenv pat in
check_equal_types label_pos ~expected ~given; tenv
) tenv plist;
in
ATyCon(type_cons, tlist'),tenv
List.fold_left
(fun tenv (Position.{ position = label_pos; value = label_val }, pat) ->
let label_scheme =
try HopixTypes.lookup_type_scheme_of_label label_pos label_val tenv with
| HopixTypes.Unbound (pos, Label (LId i)) ->
HopixTypes.type_error pos (Printf.sprintf "Unbound label `%s'." i)
in
let instance_type_scheme =
try HopixTypes.instantiate_type_scheme label_scheme tlist' with
| HopixTypes.InvalidInstantiation { expected; given } ->
invalid_instantiation (Position.position pat) expected given
in
let _, expected =
HopixTypes.destruct_function_type label_pos instance_type_scheme
in
let given, tenv = synth_pattern tenv pat in
check_equal_types label_pos ~expected ~given;
tenv)
tenv
plist
in
ATyCon (type_cons, tlist'), tenv
and synth_variable
: HopixTypes.typing_environment -> identifier Position.located