diff --git a/flap/src/hopix/hopixTypechecker.ml b/flap/src/hopix/hopixTypechecker.ml index fe5a885..409bee1 100644 --- a/flap/src/hopix/hopixTypechecker.ml +++ b/flap/src/hopix/hopixTypechecker.ml @@ -213,7 +213,7 @@ and pattern_tagval -> HopixAST.ty Position.located list option -> HopixAST.pattern Position.located list -> HopixTypes.aty * HopixTypes.typing_environment = - fun tenv cons tlist plist -> (*failwith "synth_pattern | PTagged"*) + fun tenv cons tlist plist -> let cons_scheme = try HopixTypes.lookup_type_scheme_of_constructor cons.position cons.value tenv with @@ -265,7 +265,38 @@ and pattern_record -> HopixAST.ty Position.located list option -> HopixTypes.aty * HopixTypes.typing_environment = - fun tenv plist tlist -> failwith "synth_pattern | PRecord" + fun tenv plist tlist -> + let label = fst(List.hd plist) in + let type_cons,_,labels = + let LId label_name = label.value in + HopixTypes.lookup_type_constructor_of_label label.position label.value tenv + (* Printf.sprintf "erreur message ici"*) + + in + let tlist' = + match tlist with + | Some tlist -> List.map (fun t -> HopixTypes.internalize_ty tenv t) tlist + | None -> HopixTypes.type_error label.position "No types found." + in + List.iter + (fun (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 arrow = + 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 arrow in + let given,_ = synth_pattern tenv pat in + check_equal_types label_pos ~expected ~given) + plist; + ATyCon (type_cons, tlist'),tenv + + and synth_variable : HopixTypes.typing_environment -> identifier Position.located