Adapt error messages to new uncurried representation.

Author: cristianoc

jscomp/ml/typecore.ml

@@ -2108,7 +2108,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
       | Lident "Uncurried$" ->
         let arity = Ast_uncurried.attributes_to_arity sexp.pexp_attributes in
         let uncurried_typ = Ast_uncurried.mk_js_fn ~env ~arity (newvar()) in
-        unify_exp_types loc env uncurried_typ ty_expected
+        unify_exp_types loc env ty_expected uncurried_typ
       | _ -> ());
       type_construct env loc lid sarg ty_expected sexp.pexp_attributes
   | Pexp_variant(l, sarg) ->
@@ -3666,16 +3666,6 @@ let report_error env ppf = function
       fprintf ppf "Variable %s must occur on both sides of this | pattern"
         (Ident.name id);
       spellcheck_idents ppf id valid_idents
-  | Expr_type_clash ( 
-    (_, {desc = Tarrow _}) ::
-    (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),_,_)}) :: _
-   ) -> 
-      fprintf ppf "This function is a curried function where an uncurried function is expected"    
-  | Expr_type_clash (
-      (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),a,_),_,_)}) ::
-      (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),b,_),_,_)}) :: _
-   ) when a <> b -> 
-      fprintf ppf "This function has %s but was expected %s" a b 
   | Expr_type_clash ( 
       (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),a,_),_,_)}) ::
       (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),b,_),_,_)}) :: _

jscomp/super_errors/super_typecore.ml

@@ -119,6 +119,12 @@ let print_expr_type_clash env trace ppf = begin
     show_extra_help ppf env trace;
 end
 
+let reportArityMismatch ~arityA ~arityB ppf =
+  fprintf ppf "This function expected @{<info>%s@} %s, but got @{<error>%s@}"
+    arityA
+    (if arityA = "1" then "argument" else "arguments")
+    arityB
+
 let reportJsFnArityMismatch ~arityA ~arityB ppf =
   let extractArity s =
     if Ext_string.starts_with s "arity" then
@@ -128,12 +134,9 @@ let reportJsFnArityMismatch ~arityA ~arityB ppf =
     else
       raise (Invalid_argument "Unrecognized arity type name.")
   in
-  let firstNumber = extractArity arityA in
-  fprintf ppf "This function expected @{<info>%s@} %s, but got @{<error>%s@}"
-    firstNumber
-    (if firstNumber = "1" then "argument" else "arguments")
-    (extractArity arityB)
-
+  let arityA = extractArity arityA in
+  let arityB = extractArity arityB in
+  reportArityMismatch ~arityA ~arityB ppf
 
 (* Pasted from typecore.ml. Needed for some cases in report_error below *)
 (* Records *)
@@ -177,13 +180,24 @@ let report_error env ppf = function
   | Expr_type_clash (
       (_, {desc = Tarrow _}) ::
       (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),_,_)}) :: _
-    ) ->
+    )
+  | Expr_type_clash ( 
+    (_, {desc = Tarrow _}) ::
+    (_, {desc = Tconstr (Pident {name = "uncurried$"},_,_)}) :: _
+   ) -> 
     fprintf ppf "This function is a curried function where an uncurried function is expected"
   | Expr_type_clash (
       (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),arityA,_),_,_)}) ::
       (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),arityB,_),_,_)}) :: _
     ) when arityA <> arityB ->
     reportJsFnArityMismatch ~arityA ~arityB ppf
+  | Expr_type_clash (
+      (_, {desc = Tconstr (Pident {name = "uncurried$"},[_; tA],_)}) ::
+      (_, {desc = Tconstr (Pident {name = "uncurried$"},[_; tB],_)}) :: _
+    ) when Ast_uncurried.type_to_arity tA <> Ast_uncurried.type_to_arity tB ->
+    let arityA = Ast_uncurried.type_to_arity tA |> string_of_int in
+    let arityB = Ast_uncurried.type_to_arity tB |> string_of_int in
+    reportArityMismatch ~arityA ~arityB ppf
   | Expr_type_clash (
       (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),a,_),_,_)}) ::
       (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),b,_),_,_)}) :: _

res_syntax/src/res_outcome_printer.ml

@@ -223,6 +223,10 @@ let rec printOutTypeDoc (outType : Outcometree.out_type) =
     when isArityIdent ident ->
     (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*)
     printOutArrowType ~uncurried:true arrowType
+  | Otyp_constr (Oide_ident "uncurried$", [(Otyp_arrow _ as arrowType); _arity])
+    ->
+    (* uncurried$<(int, int) => int, [#2]> -> (. int, int) => int *)
+    printOutArrowType ~uncurried:true arrowType
   | Otyp_constr (outIdent, []) -> printOutIdentDoc ~allowUident:false outIdent
   | Otyp_manifest (typ1, typ2) ->
     Doc.concat [printOutTypeDoc typ1; Doc.text " = "; printOutTypeDoc typ2]