This commit is contained in:
Mylloon 2023-12-05 23:55:40 +01:00
parent 026805bd12
commit e8c6f8da9b
Signed by: Anri
GPG key ID: A82D63DFF8D1317F

View file

@ -150,48 +150,63 @@ and pattern_tannot
let aty_of_ty = HopixTypes.internalize_ty tenv ty in let aty_of_ty = HopixTypes.internalize_ty tenv ty in
match p.value with match p.value with
| PWildcard -> aty_of_ty, tenv | PWildcard -> aty_of_ty, tenv
| PVariable i -> aty_of_ty,HopixTypes.bind_value i.value (HopixTypes.monomorphic_type_scheme aty_of_ty) tenv | PVariable i ->
| _ -> let pattern_type, tenv = synth_pattern tenv p in ( aty_of_ty
check_equal_types p.position ~expected:aty_of_ty ~given:pattern_type; pattern_type, tenv , HopixTypes.bind_value i.value (HopixTypes.monomorphic_type_scheme aty_of_ty) tenv )
| _ ->
let pattern_type, tenv = synth_pattern tenv p in
check_equal_types p.position ~expected:aty_of_ty ~given:pattern_type;
pattern_type, tenv
and pattern_tuple and pattern_tuple
: HopixTypes.typing_environment -> HopixAST.pattern Position.located list : HopixTypes.typing_environment -> HopixAST.pattern Position.located list
-> HopixTypes.aty * HopixTypes.typing_environment -> HopixTypes.aty * HopixTypes.typing_environment
= =
fun tenv plist -> let tys, tenv = fun tenv plist ->
List.fold_left( let tys, tenv =
fun(tys,tenv) pat -> List.fold_left
let (ty,tenv) = synth_pattern tenv pat in (fun (tys, tenv) pat ->
(ty::tys,tenv) let ty, tenv = synth_pattern tenv pat in
) ([],tenv) plist in ty :: tys, tenv)
HopixTypes.ATyTuple(List.rev tys), tenv ([], tenv)
plist
in
HopixTypes.ATyTuple (List.rev tys), tenv
and pattern_or and pattern_or
: HopixTypes.typing_environment -> HopixAST.pattern Position.located list : HopixTypes.typing_environment -> HopixAST.pattern Position.located list
-> HopixTypes.aty * HopixTypes.typing_environment -> HopixTypes.aty * HopixTypes.typing_environment
= =
fun tenv plist -> fun tenv plist ->
let ty', tenv' = synth_pattern tenv (List.hd (plist)) in let ty', tenv' = synth_pattern tenv (List.hd plist) in
let tenv = List.fold_left ( let tenv =
fun tenv pat -> List.fold_left
(fun tenv pat ->
let pattern_type, tenv = synth_pattern tenv pat in let pattern_type, tenv = synth_pattern tenv pat in
check_equal_types pat.position ~expected:pattern_type ~given:ty';tenv check_equal_types pat.position ~expected:pattern_type ~given:ty';
) tenv' plist tenv)
in ty', tenv tenv'
plist
in
ty', tenv
(* TODO : Même code que pattern_or, à revoir ?*) (* TODO : Même code que pattern_or, à revoir ? *)
and pattern_and and pattern_and
: HopixTypes.typing_environment -> HopixAST.pattern Position.located list : HopixTypes.typing_environment -> HopixAST.pattern Position.located list
-> HopixTypes.aty * HopixTypes.typing_environment -> HopixTypes.aty * HopixTypes.typing_environment
= =
fun tenv plist -> fun tenv plist ->
let ty', tenv' = synth_pattern tenv (List.hd (plist)) in let ty', tenv' = synth_pattern tenv (List.hd plist) in
let tenv = List.fold_left ( let tenv =
fun tenv pat -> List.fold_left
(fun tenv pat ->
let pattern_type, tenv = synth_pattern tenv pat in let pattern_type, tenv = synth_pattern tenv pat in
check_equal_types pat.position ~expected:pattern_type ~given:ty';tenv check_equal_types pat.position ~expected:pattern_type ~given:ty';
) tenv' plist tenv)
in ty', tenv tenv'
plist
in
ty', tenv
and pattern_tagval and pattern_tagval
: HopixTypes.typing_environment -> HopixAST.constructor Position.located : HopixTypes.typing_environment -> HopixAST.constructor Position.located
@ -199,7 +214,8 @@ and pattern_tagval
-> HopixTypes.aty * HopixTypes.typing_environment -> HopixTypes.aty * HopixTypes.typing_environment
= =
fun tenv cons tlist plist -> failwith "synth_pattern | PTagged" fun tenv cons tlist plist -> failwith "synth_pattern | PTagged"
(* TODO : à finir (trop fatigué sah): s'inspirer de ce qui a déjà été fait pour lex expressions. (* (* TODO : à finir (trop fatigué sah):
s'inspirer de ce qui a déjà été fait pour lex expressions. *)
let cons_scheme = let cons_scheme =
try HopixTypes.lookup_type_scheme_of_constructor cons.position cons.value tenv with try HopixTypes.lookup_type_scheme_of_constructor cons.position cons.value tenv with
| HopixTypes.Unbound (pos, Constructor (KId c)) -> | HopixTypes.Unbound (pos, Constructor (KId c)) ->
@ -216,8 +232,7 @@ and pattern_tagval
try HopixTypes.instantiate_type_scheme cons_scheme tys with try HopixTypes.instantiate_type_scheme cons_scheme tys with
| HopixTypes.InvalidInstantiation { expected; given } -> | HopixTypes.InvalidInstantiation { expected; given } ->
invalid_instantiation cons.position expected given invalid_instantiation cons.position expected given
in in *)
*)
and pattern_record and pattern_record
: HopixTypes.typing_environment : HopixTypes.typing_environment
@ -227,7 +242,6 @@ and pattern_record
= =
fun tenv plist tlist -> failwith "synth_pattern | PRecord" fun tenv plist tlist -> failwith "synth_pattern | PRecord"
and synth_variable and synth_variable
: HopixTypes.typing_environment -> identifier Position.located : HopixTypes.typing_environment -> identifier Position.located
-> ty Position.located list option -> HopixTypes.aty -> ty Position.located list option -> HopixTypes.aty