PRecord (marche pas)

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