Single source of truth for uncurried ast operations shared with syntax.

Author: cristianoc

jscomp/ml/ast_uncurried.ml

@@ -9,6 +9,11 @@ let arityType ~loc arity =
     [ Rtag ({ txt = encode_arity_string arity; loc }, [], true, []) ]
     Closed None
 
+let arityFromType (typ : Parsetree.core_type) =
+  match typ.ptyp_desc with
+  | Ptyp_variant ([Rtag ({txt}, _, _, _)], _, _) -> decode_arity_string txt
+  | _ -> assert false
+
 let uncurriedType ~loc ~arity tArg =
     let tArity = arityType ~loc arity in
     Ast_helper.Typ.constr ~loc
@@ -58,6 +63,18 @@ let exprExtractUncurriedFun (expr : Parsetree.expression) =
   | Pexp_construct ({ txt = Lident "Function$" }, Some e) -> e
   | _ -> assert false
 
+let typeIsUncurriedFun (typ : Parsetree.core_type) =
+  match typ.ptyp_desc with
+  | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow _}; _]) ->
+    true
+  | _ -> false
+
+let typeExtractUncurriedFun (typ : Parsetree.core_type) =
+  match typ.ptyp_desc with
+  | Ptyp_constr ({txt = Lident "function$"}, [tArg; tArity]) ->
+    (arityFromType tArity, tArg)
+  | _ -> assert false
+
 (* Typed AST *)
 
 let arity_to_type arity =

res_syntax/src/reactjs_jsx_v4.ml

@@ -752,8 +752,8 @@ let transformStructureItem ~config mapper item =
         check_string_int_attribute_iter.structure_item
           check_string_int_attribute_iter item;
         let pval_type =
-          if Res_uncurried.typeIsUncurriedFun pval_type then
-            let _arity, t = Res_uncurried.typeExtractUncurriedFun pval_type in
+          if Ast_uncurried.typeIsUncurriedFun pval_type then
+            let _arity, t = Ast_uncurried.typeExtractUncurriedFun pval_type in
             t
           else pval_type
         in
@@ -825,8 +825,8 @@ let transformStructureItem ~config mapper item =
           config.hasReactComponent <- true;
           let rec removeArityRecord expr =
             match expr.pexp_desc with
-            | _ when Res_uncurried.exprIsUncurriedFun expr ->
-              Res_uncurried.exprExtractUncurriedFun expr
+            | _ when Ast_uncurried.exprIsUncurriedFun expr ->
+              Ast_uncurried.exprExtractUncurriedFun expr
             | Pexp_apply (forwardRef, [(label, e)]) ->
               {
                 expr with
@@ -1248,8 +1248,8 @@ let transformSignatureItem ~config _mapper item =
         React_jsx_common.raiseErrorMultipleReactComponent ~loc:psig_loc
       else config.hasReactComponent <- true;
       let pval_type =
-        if Res_uncurried.typeIsUncurriedFun pval_type then
-          let _arity, t = Res_uncurried.typeExtractUncurriedFun pval_type in
+        if Ast_uncurried.typeIsUncurriedFun pval_type then
+          let _arity, t = Ast_uncurried.typeExtractUncurriedFun pval_type in
           t
         else pval_type
       in

res_syntax/src/res_core.ml

@@ -1599,7 +1599,7 @@ and parseEs6ArrowExpression ?(arrowAttrs = []) ?(arrowStartPos = None) ?context
             && (termParamNum = 1
                || not (p.uncurried_config |> Res_uncurried.isDefault))
           then
-            (termParamNum - 1, Res_uncurried.uncurriedFun ~loc ~arity funExpr, 1)
+            (termParamNum - 1, Ast_uncurried.uncurriedFun ~loc ~arity funExpr, 1)
           else (termParamNum - 1, funExpr, arity + 1)
         | TypeParameter {dotted = _; attrs; locs = newtypes; pos = startPos} ->
           ( termParamNum,
@@ -3917,7 +3917,7 @@ and parsePolyTypeExpr p =
         let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in
         let tFun = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in
         if p.uncurried_config |> Res_uncurried.isDefault then
-          Res_uncurried.uncurriedType ~loc ~arity:1 tFun
+          Ast_uncurried.uncurriedType ~loc ~arity:1 tFun
         else tFun
       | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt)
     | _ -> assert false)
@@ -4267,7 +4267,7 @@ and parseEs6ArrowType ~attrs p =
           then
             let loc = mkLoc startPos endPos in
             let tArg = Ast_helper.Typ.arrow ~loc ~attrs argLbl typ t in
-            (paramNum - 1, Res_uncurried.uncurriedType ~loc ~arity tArg, 1)
+            (paramNum - 1, Ast_uncurried.uncurriedType ~loc ~arity tArg, 1)
           else
             ( paramNum - 1,
               Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl
@@ -4330,7 +4330,7 @@ and parseArrowTypeRest ~es6Arrow ~startPos typ p =
     let loc = mkLoc startPos p.prevEndPos in
     let arrowTyp = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in
     if p.uncurried_config |> Res_uncurried.isDefault then
-      Res_uncurried.uncurriedType ~loc ~arity:1 arrowTyp
+      Ast_uncurried.uncurriedType ~loc ~arity:1 arrowTyp
     else arrowTyp
   | _ -> typ
 

res_syntax/src/res_parsetree_viewer.ml

@@ -176,17 +176,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)
-    | expr when nFun = 0 && Res_uncurried.exprIsUncurriedFun expr ->
-      let expr = Res_uncurried.exprExtractUncurriedFun expr in
+    | expr when nFun = 0 && Ast_uncurried.exprIsUncurriedFun expr ->
+      let expr = Ast_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 = []}
-  | _ when Res_uncurried.exprIsUncurriedFun expr ->
-    let expr = Res_uncurried.exprExtractUncurriedFun expr in
+  | _ when Ast_uncurried.exprIsUncurriedFun expr ->
+    let expr = Ast_uncurried.exprExtractUncurriedFun expr in
     collect ~uncurried:true ~nFun:0 expr.pexp_attributes []
       {expr with pexp_attributes = []}
   | _ -> collect ~uncurried:false ~nFun:0 [] [] expr
@@ -551,7 +551,7 @@ let partitionPrintableAttributes attrs =
 let isFunNewtype expr =
   match expr.pexp_desc with
   | Pexp_fun _ | Pexp_newtype _ -> true
-  | _ -> Res_uncurried.exprIsUncurriedFun expr
+  | _ -> Ast_uncurried.exprIsUncurriedFun expr
 
 let requiresSpecialCallbackPrintingLastArg args =
   let rec loop args =

res_syntax/src/res_printer.ml

@@ -1583,7 +1583,7 @@ and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl =
         let doc = printTypExpr ~state n cmtTbl in
         match n.ptyp_desc with
         | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc
-        | _ when Res_uncurried.typeIsUncurriedFun n -> addParens doc
+        | _ when Ast_uncurried.typeIsUncurriedFun n -> addParens doc
         | _ -> doc
       in
       Doc.group
@@ -1655,8 +1655,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 _ when Res_uncurried.typeIsUncurriedFun typExpr ->
-      let arity, tArg = Res_uncurried.typeExtractUncurriedFun typExpr in
+    | Ptyp_constr _ when Ast_uncurried.typeIsUncurriedFun typExpr ->
+      let arity, tArg = Ast_uncurried.typeExtractUncurriedFun typExpr in
       printArrow ~uncurried:true ~arity tArg
     | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}])
       ->
@@ -2678,7 +2678,7 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl =
       printExpressionWithComments ~state
         (ParsetreeViewer.rewriteUnderscoreApply e)
         cmtTbl
-    | _ when Res_uncurried.exprIsUncurriedFun e -> printArrow e
+    | _ when Ast_uncurried.exprIsUncurriedFun e -> printArrow e
     | Pexp_fun _ | Pexp_newtype _ -> printArrow e
     | Parsetree.Pexp_constant c ->
       printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c

res_syntax/src/res_uncurried.ml

@@ -15,61 +15,3 @@ let fromDotted ~dotted = function
 let getDotted ~uncurried = function
   | Legacy -> uncurried
   | Default -> not uncurried
-
-let encode_arity_string arity = "Has_arity" ^ string_of_int arity
-let decode_arity_string arity_s =
-  (int_of_string [@doesNotRaise])
-    ((String.sub [@doesNotRaise]) arity_s 9 (String.length arity_s - 9))
-
-let arityType ~loc arity =
-  Ast_helper.Typ.variant ~loc
-    [Rtag ({txt = encode_arity_string arity; loc}, [], true, [])]
-    Closed None
-
-let arityFromType (typ : Parsetree.core_type) =
-  match typ.ptyp_desc with
-  | Ptyp_variant ([Rtag ({txt}, _, _, _)], _, _) -> decode_arity_string txt
-  | _ -> assert false
-
-let uncurriedType ~loc ~arity tArg =
-  let tArity = arityType ~loc arity in
-  Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [tArg; tArity]
-
-let arity_to_attributes arity =
-  [
-    ( Location.mknoloc "res.arity",
-      Parsetree.PStr
-        [
-          Ast_helper.Str.eval
-            (Ast_helper.Exp.constant
-               (Pconst_integer (string_of_int arity, None)));
-        ] );
-  ]
-
-let uncurriedFun ~loc ~arity funExpr =
-  Ast_helper.Exp.construct ~loc
-    ~attrs:(arity_to_attributes arity)
-    {txt = Lident "Function$"; loc}
-    (Some funExpr)
-
-let exprIsUncurriedFun (expr : Parsetree.expression) =
-  match expr.pexp_desc with
-  | Pexp_construct ({txt = Lident "Function$"}, Some _) -> true
-  | _ -> false
-
-let exprExtractUncurriedFun (expr : Parsetree.expression) =
-  match expr.pexp_desc with
-  | Pexp_construct ({txt = Lident "Function$"}, Some e) -> e
-  | _ -> assert false
-
-let typeIsUncurriedFun (typ : Parsetree.core_type) =
-  match typ.ptyp_desc with
-  | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow _}; _]) ->
-    true
-  | _ -> false
-
-let typeExtractUncurriedFun (typ : Parsetree.core_type) =
-  match typ.ptyp_desc with
-  | Ptyp_constr ({txt = Lident "function$"}, [tArg; tArity]) ->
-    (arityFromType tArity, tArg)
-  | _ -> assert false