sync latest parser

Author: zth

analysis/vendor/ext/config.ml

@@ -13,7 +13,8 @@ let bs_only = ref true
 
 let unsafe_empty_array = ref false
 
-let use_automatic_curried_application = ref false
+type uncurried = Legacy | Uncurried | Swap
+let uncurried = ref Legacy
 
 and cmi_magic_number = "Caml1999I022"
 

analysis/vendor/ext/config.mli

@@ -47,4 +47,5 @@ val cmt_magic_number : string
 
 val print_config : out_channel -> unit
 
-val use_automatic_curried_application : bool ref
+type uncurried = Legacy | Uncurried | Swap
+val uncurried : uncurried ref

analysis/vendor/ml/ctype.ml

@@ -2341,9 +2341,6 @@ let rec unify (env:Env.t ref) t1 t2 =
         with Cannot_expand ->
           unify2 env t1 t2
         end
-    | (Tconstr (Pident {name="function$"}, [tFun; _], _), Tarrow _) when !Config.use_automatic_curried_application ->
-        (* subtype: an uncurried function is cast to a curried one *)
-        unify2 env tFun t2
     | _ ->
         unify2 env t1 t2
     end;
@@ -2399,6 +2396,9 @@ and unify3 env t1 t1' t2 t2' =
       link_type t2' t1;
   | (Tfield _, Tfield _) -> (* special case for GADTs *)
       unify_fields env t1' t2'
+  | (Tconstr (Pident {name="function$"}, [tFun; _], _), Tarrow _) when !Config.uncurried = Uncurried ->
+      (* subtype: an uncurried function is cast to a curried one *)
+      unify2 env tFun t2
   | _ ->
     begin match !umode with
     | Expression ->
@@ -3951,7 +3951,33 @@ let rec subtype_rec env trace t1 t2 cstrs =
         end
     | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 ->
         subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
-(*  | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
+    | (Tconstr(_, [], _), Tconstr(_, [], _)) -> (* type coercion for records *)
+      (match extract_concrete_typedecl env t1, extract_concrete_typedecl env t2 with
+      | (_, _, {type_kind=Type_record (fields1, repr1)}), (_, _, {type_kind=Type_record (fields2, repr2)}) ->
+        let field_is_optional id repr = match repr with
+          | Record_optional_labels lbls -> List.mem (Ident.name id) lbls
+          | _ -> false in
+        let violation = ref false in
+        let label_decl_sub (acc1, acc2) ld2 =
+          match fields1 |> List.find_opt (fun ld1 -> Ident.name ld1.ld_id = Ident.name ld2.ld_id) with
+          | Some ld1 ->
+            if field_is_optional ld1.ld_id repr1 && not (field_is_optional ld2.ld_id repr2) then
+              (* optional field can't be cast to non-optional one *)
+              violation := true;
+            ld1.ld_type :: acc1, ld2.ld_type :: acc2
+          | None ->
+            (* field must be present *)
+            violation := true;
+            (acc1, acc2) in
+        let tl1, tl2 = List.fold_left label_decl_sub ([], []) fields2 in
+        if !violation
+        then (trace, t1, t2, !univar_pairs)::cstrs
+        else
+          subtype_list env trace tl1 tl2 cstrs
+      | _ -> (trace, t1, t2, !univar_pairs)::cstrs
+      | exception Not_found -> (trace, t1, t2, !univar_pairs)::cstrs
+    )
+    (*  | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
         subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *)
     | (Tobject (f1, _), Tobject (f2, _))
       when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->

analysis/vendor/ml/typecore.ml

@@ -2980,7 +2980,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
       texp
 and is_automatic_curried_application env funct =
   (* When a curried function is used with uncurried application, treat it as a curried application *)
-  !Config.use_automatic_curried_application &&
+  !Config.uncurried = Uncurried &&
   match (expand_head env funct.exp_type).desc with
   | Tarrow _ -> true
   | _ -> false

analysis/vendor/res_syntax/reactjs_jsx_v3.ml

@@ -597,6 +597,7 @@ let jsxMapper ~config =
       match List.filter React_jsx_common.hasAttr pval_attributes with
       | [] -> [item]
       | [_] ->
+        let pval_type = React_jsx_common.extractUncurried pval_type in
         let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) =
           match ptyp_desc with
           | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest))
@@ -648,6 +649,7 @@ let jsxMapper ~config =
       let emptyLoc = Location.in_file fileName in
       let mapBinding binding =
         if React_jsx_common.hasAttrOnBinding binding then
+          let binding = React_jsx_common.removeArity binding in
           let bindingLoc = binding.pvb_loc in
           let bindingPatLoc = binding.pvb_pat.ppat_loc in
           let binding =
@@ -957,6 +959,13 @@ let jsxMapper ~config =
               }
               innerExpressionWithRef
           in
+          let fullExpression =
+            if !Config.uncurried = Uncurried then
+              fullExpression
+              |> Ast_uncurried.uncurriedFun ~loc:fullExpression.pexp_loc
+                   ~arity:1
+            else fullExpression
+          in
           let fullExpression =
             match fullModuleName with
             | "" -> fullExpression
@@ -1031,6 +1040,7 @@ let jsxMapper ~config =
       match List.filter React_jsx_common.hasAttr pval_attributes with
       | [] -> [item]
       | [_] ->
+        let pval_type = React_jsx_common.extractUncurried pval_type in
         let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) =
           match ptyp_desc with
           | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest))

analysis/vendor/res_syntax/reactjs_jsx_v4.ml

@@ -952,6 +952,12 @@ let mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding =
            innerExpression
         else innerExpression)
     in
+    let fullExpression =
+      if !Config.uncurried = Uncurried then
+        fullExpression
+        |> Ast_uncurried.uncurriedFun ~loc:fullExpression.pexp_loc ~arity:1
+      else fullExpression
+    in
     let fullExpression =
       match fullModuleName with
       | "" -> fullExpression