Refactor: move handling of uncurried types for parser/printer to Res_uncurried.

Author: cristianoc

lib/4.06.1/unstable/js_compiler.ml

@@ -49496,6 +49496,77 @@ let debug t =
   toString ~width:10 doc |> print_endline
   [@@live]
 
+end
+module Res_uncurried
+= struct
+#1 "res_uncurried.ml"
+type config = Legacy | Default
+
+let init = Legacy
+
+let isDefault = function
+  | Legacy -> false
+  | Default -> true
+
+(* For parsing *)
+let fromDotted ~dotted = function
+  | Legacy -> dotted
+  | Default -> not dotted
+
+(* For printing *)
+let getDotted ~uncurried = function
+  | Legacy -> uncurried
+  | Default -> not uncurried
+
+let uncurriedType ~loc ~arity tArg =
+  Ast_helper.Typ.constr ~loc
+    {txt = Ldot (Ldot (Lident "Js", "Fn"), "arity" ^ string_of_int arity); loc}
+    [tArg]
+
+let uncurriedFun ~loc ~arity funExpr =
+  Ast_helper.Exp.record ~loc
+    [
+      ( {txt = Ldot (Ldot (Lident "Js", "Fn"), "I" ^ string_of_int arity); loc},
+        funExpr );
+    ]
+    None
+
+let exprIsUncurriedFun (expr : Parsetree.expression) =
+  match expr with
+  | {
+   pexp_desc =
+     Pexp_record ([({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, _e)], None);
+  } ->
+    true
+  | _ -> false
+
+let exprExtractUncurriedFun (expr : Parsetree.expression) =
+  match expr with
+  | {
+   pexp_desc =
+     Pexp_record ([({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, e)], None);
+  } ->
+    e
+  | _ -> assert false
+
+let typeIsUncurriedFun (typ : Parsetree.core_type) =
+  match typ.ptyp_desc with
+  | Ptyp_constr
+      ({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, [{ptyp_desc = Ptyp_arrow _}])
+    ->
+    true
+  | _ -> false
+
+let typeExtractUncurriedFun (typ : Parsetree.core_type) =
+  match typ.ptyp_desc with
+  | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), arity)}, [tArg]) ->
+    let arity =
+      (int_of_string [@doesNotRaise])
+        ((String.sub [@doesNotRaise]) arity 5 (String.length arity - 5))
+    in
+    (arity, tArg)
+  | _ -> assert false
+
 end
 module Res_parsetree_viewer : sig 
 #1 "res_parsetree_viewer.mli"
@@ -49659,7 +49730,7 @@ val hasIfLetAttribute : Parsetree.attributes -> bool
 
 val isRewrittenUnderscoreApplySugar : Parsetree.expression -> bool
 
-val isFunNewtype : Parsetree.expression_desc -> bool
+val isFunNewtype : Parsetree.expression -> bool
 
 end = struct
 #1 "res_parsetree_viewer.ml"
@@ -49841,22 +49912,17 @@ let funExpr expr =
     (* If a fun has an attribute, then it stops here and makes currying.
        i.e attributes outside of (...), uncurried `(.)` and `async` make currying *)
     | {pexp_desc = Pexp_fun _} -> (uncurried, attrsBefore, List.rev acc, expr)
-    | {
-     pexp_desc =
-       Pexp_record ([({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, expr)], None);
-    }
-      when nFun = 0 ->
+    | expr when nFun = 0 && Res_uncurried.exprIsUncurriedFun expr ->
+      let expr = Res_uncurried.exprExtractUncurriedFun expr in
       collect ~uncurried:true ~nFun attrsBefore acc expr
     | expr -> (uncurried, attrsBefore, List.rev acc, expr)
   in
   match expr with
   | {pexp_desc = Pexp_fun _} ->
     collect ~uncurried:false ~nFun:0 expr.pexp_attributes []
       {expr with pexp_attributes = []}
-  | {
-   pexp_desc =
-     Pexp_record ([({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, expr)], None);
-  } ->
+  | _ when Res_uncurried.exprIsUncurriedFun expr ->
+    let expr = Res_uncurried.exprExtractUncurriedFun expr in
     collect ~uncurried:true ~nFun:0 expr.pexp_attributes []
       {expr with pexp_attributes = []}
   | _ -> collect ~uncurried:false ~nFun:0 [] [] expr
@@ -50218,19 +50284,17 @@ let filterPrintableAttributes attrs = List.filter isPrintableAttribute attrs
 let partitionPrintableAttributes attrs =
   List.partition isPrintableAttribute attrs
 
-let isFunNewtype = function
+let isFunNewtype expr =
+  match expr.pexp_desc with
   | Pexp_fun _ | Pexp_newtype _ -> true
-  | Pexp_record ([({txt = Ldot (Ldot (Lident "Js", "Fn"), name)}, _)], None)
-    when String.length name >= 1 && (name.[0] [@doesNotRaise]) = 'I' ->
-    true
-  | _ -> false
+  | _ -> Res_uncurried.exprIsUncurriedFun expr
 
 let requiresSpecialCallbackPrintingLastArg args =
   let rec loop args =
     match args with
     | [] -> false
-    | [(_, {pexp_desc})] when isFunNewtype pexp_desc -> true
-    | (_, {pexp_desc}) :: _ when isFunNewtype pexp_desc -> false
+    | [(_, expr)] when isFunNewtype expr -> true
+    | (_, expr) :: _ when isFunNewtype expr -> false
     | _ :: rest -> loop rest
   in
   loop args
@@ -50239,12 +50303,12 @@ let requiresSpecialCallbackPrintingFirstArg args =
   let rec loop args =
     match args with
     | [] -> true
-    | (_, {pexp_desc}) :: _ when isFunNewtype pexp_desc -> false
+    | (_, expr) :: _ when isFunNewtype expr -> false
     | _ :: rest -> loop rest
   in
   match args with
-  | [(_, {pexp_desc})] when isFunNewtype pexp_desc -> false
-  | (_, {pexp_desc}) :: rest when isFunNewtype pexp_desc -> loop rest
+  | [(_, expr)] when isFunNewtype expr -> false
+  | (_, expr) :: rest when isFunNewtype expr -> loop rest
   | _ -> false
 
 let modExprApply modExpr =
@@ -52612,7 +52676,7 @@ let ternaryOperand expr =
     } ->
       Nothing
     | {pexp_desc = Pexp_constraint _} -> Parenthesized
-    | {pexp_desc} when Res_parsetree_viewer.isFunNewtype pexp_desc -> (
+    | _ when Res_parsetree_viewer.isFunNewtype expr -> (
       let _uncurried, _attrsOnArrow, _parameters, returnExpr =
         ParsetreeViewer.funExpr expr
       in
@@ -53029,28 +53093,6 @@ let isKeywordTxt str =
 
 let catch = Lident "catch"
 
-end
-module Res_uncurried
-= struct
-#1 "res_uncurried.ml"
-type t = Legacy | Default
-
-let init = Legacy
-
-let isDefault = function
-  | Legacy -> false
-  | Default -> true
-
-(* For parsing *)
-let fromDotted ~dotted = function
-  | Legacy -> dotted
-  | Default -> not dotted
-
-(* For printing *)
-let getDotted ~uncurried = function
-  | Legacy -> uncurried
-  | Default -> not uncurried
-
 end
 module Res_utf8 : sig 
 #1 "res_utf8.mli"
@@ -53819,9 +53861,9 @@ let printOptionalLabel attrs =
 module State = struct
   let customLayoutThreshold = 2
 
-  type t = {customLayout: int; mutable res_uncurried: Res_uncurried.t}
+  type t = {customLayout: int; mutable uncurried_config: Res_uncurried.config}
 
-  let init = {customLayout = 0; res_uncurried = Res_uncurried.init}
+  let init = {customLayout = 0; uncurried_config = Res_uncurried.init}
 
   let nextCustomLayout t = {t with customLayout = t.customLayout + 1}
 
@@ -54797,7 +54839,9 @@ and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl =
       ParsetreeViewer.arrowType ~arity typExpr
     in
     let dotted, attrsBefore =
-      let dotted = state.res_uncurried |> Res_uncurried.getDotted ~uncurried in
+      let dotted =
+        state.uncurried_config |> Res_uncurried.getDotted ~uncurried
+      in
       (* Converting .ml code to .res requires processing uncurried attributes *)
       let hasBs, attrs = ParsetreeViewer.processBsAttribute attrsBefore in
       (dotted || hasBs, attrs)
@@ -54824,11 +54868,8 @@ and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl =
       let typDoc =
         let doc = printTypExpr ~state n cmtTbl in
         match n.ptyp_desc with
-        | Ptyp_constr
-            ( {txt = Ldot (Ldot (Lident "Js", "Fn"), _)},
-              [{ptyp_desc = Ptyp_arrow _}] )
-        | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ ->
-          addParens doc
+        | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc
+        | _ when Res_uncurried.typeIsUncurriedFun n -> addParens doc
         | _ -> doc
       in
       Doc.group
@@ -54900,13 +54941,8 @@ and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl =
     | Ptyp_object (fields, openFlag) ->
       printObject ~state ~inline:false fields openFlag cmtTbl
     | Ptyp_arrow _ -> printArrow ~uncurried:false typExpr
-    | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), arity)}, [tArg])
-      when String.length arity >= 5
-           && (String.sub [@doesNotRaise]) arity 0 5 = "arity" ->
-      let arity =
-        (int_of_string [@doesNotRaise])
-          ((String.sub [@doesNotRaise]) arity 5 (String.length arity - 5))
-      in
+    | Ptyp_constr _ when Res_uncurried.typeIsUncurriedFun typExpr ->
+      let arity, tArg = Res_uncurried.typeExtractUncurriedFun typExpr in
       printArrow ~uncurried:true ~arity tArg
     | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}])
       ->
@@ -55919,6 +55955,17 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl =
   in
   let printedExpression =
     match e.pexp_desc with
+    | Pexp_fun
+        ( Nolabel,
+          None,
+          {ppat_desc = Ppat_var {txt = "__x"}},
+          {pexp_desc = Pexp_apply _} ) ->
+      (* (__x) => f(a, __x, c) -----> f(a, _, c)  *)
+      printExpressionWithComments ~state
+        (ParsetreeViewer.rewriteUnderscoreApply e)
+        cmtTbl
+    | _ when Res_uncurried.exprIsUncurriedFun e -> printArrow e
+    | Pexp_fun _ | Pexp_newtype _ -> printArrow e
     | Parsetree.Pexp_constant c ->
       printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c
     | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes ->
@@ -56165,24 +56212,6 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl =
             ]
       in
       Doc.group (Doc.concat [variantName; args])
-    | Pexp_fun
-        ( Nolabel,
-          None,
-          {ppat_desc = Ppat_var {txt = "__x"}},
-          {pexp_desc = Pexp_apply _} ) ->
-      (* (__x) => f(a, __x, c) -----> f(a, _, c)  *)
-      printExpressionWithComments ~state
-        (ParsetreeViewer.rewriteUnderscoreApply e)
-        cmtTbl
-    | Pexp_fun _
-    | Pexp_record
-        ( [
-            ( {txt = Ldot (Ldot (Lident "Js", "Fn"), _)},
-              {pexp_desc = Pexp_fun _} );
-          ],
-          None )
-    | Pexp_newtype _ ->
-      printArrow e
     | Pexp_record (rows, spreadExpr) ->
       if rows = [] then
         Doc.concat
@@ -57198,7 +57227,7 @@ and printPexpApply ~state expr cmtTbl =
     let uncurried, attrs =
       ParsetreeViewer.processUncurriedAppAttribute expr.pexp_attributes
     in
-    let dotted = state.res_uncurried |> Res_uncurried.getDotted ~uncurried in
+    let dotted = state.uncurried_config |> Res_uncurried.getDotted ~uncurried in
     let callExprDoc =
       let doc = printExpressionWithComments ~state callExpr cmtTbl in
       match Parens.callExpr callExpr with
@@ -57973,7 +58002,7 @@ and printCase ~state (case : Parsetree.case) cmtTbl =
 
 and printExprFunParameters ~state ~inCallback ~async ~uncurried ~hasConstraint
     parameters cmtTbl =
-  let dotted = state.res_uncurried |> Res_uncurried.getDotted ~uncurried in
+  let dotted = state.uncurried_config |> Res_uncurried.getDotted ~uncurried in
   match parameters with
   (* let f = _ => () *)
   | [
@@ -58520,10 +58549,10 @@ and printAttribute ?(standalone = false) ~state
     let id =
       match id.txt with
       | "uncurried" ->
-        state.res_uncurried <- Res_uncurried.Default;
+        state.uncurried_config <- Res_uncurried.Default;
         id
       | "toUncurried" ->
-        state.res_uncurried <- Res_uncurried.Default;
+        state.uncurried_config <- Res_uncurried.Default;
         {id with txt = "uncurried"}
       | _ -> id
     in
@@ -154127,9 +154156,10 @@ let transformStructureItem ~config mapper item =
         check_string_int_attribute_iter.structure_item
           check_string_int_attribute_iter item;
         let pval_type =
-          match pval_type.ptyp_desc with
-          | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, [t]) -> t
-          | _ -> pval_type
+          if Res_uncurried.typeIsUncurriedFun pval_type then
+            let _arity, t = Res_uncurried.typeExtractUncurriedFun pval_type in
+            t
+          else pval_type
         in
         let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in
         let typVarsOfCoreType =
@@ -154199,9 +154229,8 @@ let transformStructureItem ~config mapper item =
           config.hasReactComponent <- true;
           let rec removeArityRecord expr =
             match expr.pexp_desc with
-            | Pexp_record
-                ([({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, e)], None) ->
-              e
+            | _ when Res_uncurried.exprIsUncurriedFun expr ->
+              Res_uncurried.exprExtractUncurriedFun expr
             | Pexp_apply (forwardRef, [(label, e)]) ->
               {
                 expr with
@@ -154626,9 +154655,10 @@ let transformSignatureItem ~config _mapper item =
         React_jsx_common.raiseErrorMultipleReactComponent ~loc:psig_loc
       else config.hasReactComponent <- true;
       let pval_type =
-        match pval_type.ptyp_desc with
-        | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, [t]) -> t
-        | _ -> pval_type
+        if Res_uncurried.typeIsUncurriedFun pval_type then
+          let _arity, t = Res_uncurried.typeExtractUncurriedFun pval_type in
+          t
+        else pval_type
       in
       check_string_int_attribute_iter.signature_item
         check_string_int_attribute_iter item;