PTagged 72/111

flap/src/hopix/hopixTypechecker.ml

@@ -213,9 +213,8 @@ 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 -> (*failwith "synth_pattern | PTagged"*)
-(* (* TODO : à finir (trop fatigué sah):
+
-     s'inspirer de ce qui a déjà été fait pour lex expressions. *)
   let cons_scheme =
     try HopixTypes.lookup_type_scheme_of_constructor cons.position cons.value tenv with
     | HopixTypes.Unbound (pos, Constructor (KId c)) ->
@@ -232,7 +231,33 @@ and pattern_tagval
     try HopixTypes.instantiate_type_scheme cons_scheme tys with
     | HopixTypes.InvalidInstantiation { expected; given } ->
       invalid_instantiation cons.position expected given
-  in *)
+  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
+
+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
 
 and pattern_record
   :  HopixTypes.typing_environment