diff --git a/CHANGELOG.md b/CHANGELOG.md index 61ef2bd585..7dbdf0f85d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,11 +19,11 @@ - `rescript convert ` - Remove obsolete built-in project templates and the "rescript init" functionality. This will be replaced by the create-rescript-app project that is maintained separately. - Parse the attributes of labelled argument to the pattern attributes of argument instead of function. +- Made pinned dependencies transitive: if *a* is a pinned dependency of *b* and *b* is a pinned dependency of *c*, then *a* is implicitly a pinned dependency of *c*. This change is only breaking if your build process assumes non-transitivity. -#### :boom: Breaking Change +#### :nail_care: Polish -- Made pinned dependencies transitive: if *a* is a pinned dependency of *b* and *b* is a pinned dependency of *c*, then *a* is implicitly a pinned dependency of *c*. -- This change is only breaking if your build process assumes non-transitivity. Few if any builds do. In the typical case where you build your monorepo by running `rescript build` on each package in your repo, you don't need to make any changes. There is no way of building with the old, non-transitive behavior. +- Syntax: process uncurried types explicitly in the parser/printer https://github.com/rescript-lang/rescript-compiler/pull/5784 # 10.1.0-rc.3 diff --git a/jscomp/test/build.ninja b/jscomp/test/build.ninja index ed61ae122c..0fcb3ae194 100644 --- a/jscomp/test/build.ninja +++ b/jscomp/test/build.ninja @@ -419,7 +419,7 @@ o test/jsoo_485_test.cmi test/jsoo_485_test.cmj : cc test/jsoo_485_test.ml | $bs o test/key_word_property.cmi test/key_word_property.cmj : cc test/key_word_property.ml | $bsc $stdlib runtime o test/key_word_property2.cmi test/key_word_property2.cmj : cc test/key_word_property2.ml | test/export_keyword.cmj $bsc $stdlib runtime o test/key_word_property_plus_test.cmi test/key_word_property_plus_test.cmj : cc test/key_word_property_plus_test.ml | test/global_mangles.cmj test/mt.cmj $bsc $stdlib runtime -o test/label_uncurry.cmi test/label_uncurry.cmj : cc test/label_uncurry.ml | $bsc $stdlib runtime +o test/label_uncurry.cmi test/label_uncurry.cmj : cc test/label_uncurry.res | $bsc $stdlib runtime o test/large_integer_pat.cmi test/large_integer_pat.cmj : cc test/large_integer_pat.ml | $bsc $stdlib runtime o test/large_record_duplication_test.cmi test/large_record_duplication_test.cmj : cc test/large_record_duplication_test.ml | test/mt.cmj $bsc $stdlib runtime o test/largest_int_flow.cmi test/largest_int_flow.cmj : cc test/largest_int_flow.ml | $bsc $stdlib runtime @@ -491,8 +491,8 @@ o test/pipe_send_readline.cmi test/pipe_send_readline.cmj : cc test/pipe_send_re o test/pipe_syntax.cmi test/pipe_syntax.cmj : cc test/pipe_syntax.ml | $bsc $stdlib runtime o test/poly_empty_array.cmi test/poly_empty_array.cmj : cc test/poly_empty_array.ml | $bsc $stdlib runtime o test/poly_type.cmi test/poly_type.cmj : cc test/poly_type.ml | $bsc $stdlib runtime -o test/poly_variant_test.cmj : cc_cmi test/poly_variant_test.ml | test/mt.cmj test/poly_variant_test.cmi $bsc $stdlib runtime -o test/poly_variant_test.cmi : cc test/poly_variant_test.mli | $bsc $stdlib runtime +o test/poly_variant_test.cmj : cc_cmi test/poly_variant_test.res | test/mt.cmj test/poly_variant_test.cmi $bsc $stdlib runtime +o test/poly_variant_test.cmi : cc test/poly_variant_test.resi | $bsc $stdlib runtime o test/polymorphic_raw_test.cmi test/polymorphic_raw_test.cmj : cc test/polymorphic_raw_test.ml | test/mt.cmj $bsc $stdlib runtime o test/polymorphism_test.cmj : cc_cmi test/polymorphism_test.ml | test/polymorphism_test.cmi $bsc $stdlib runtime o test/polymorphism_test.cmi : cc test/polymorphism_test.mli | $bsc $stdlib runtime diff --git a/jscomp/test/label_uncurry.js b/jscomp/test/label_uncurry.js index d70b9466f8..9d121d3a9e 100644 --- a/jscomp/test/label_uncurry.js +++ b/jscomp/test/label_uncurry.js @@ -15,7 +15,7 @@ function u1(f) { console.log(f(2, "x")); } -function h(unit) { +function h(x) { return 3; } diff --git a/jscomp/test/label_uncurry.ml b/jscomp/test/label_uncurry.ml deleted file mode 100644 index bd752ade4f..0000000000 --- a/jscomp/test/label_uncurry.ml +++ /dev/null @@ -1,26 +0,0 @@ - - -open Js.Fn - -type t = x:int -> y:string -> int [@bs] - -type u = (x:int -> y:string -> int) arity2 - -let f (x : t) : u = x - -let u : u = fun [@bs] ~x ~y -> x + int_of_string y - -let u1 (f : u) = - (f ~y:"x" ~x:2 [@bs]) |. Js.log ; - (f ~x:2 ~y:"x" [@bs]) |. Js.log -let h = fun [@bs] ~x:unit -> 3 - -let a = u1 u - - - -type u0 = ?x:int -> y : string -> int [@bs] - -(*let f = fun[@bs] ?x y -> x + y *) - -(* let h (x :u0) = x ~y:"x" ~x:3 [@bs] *) \ No newline at end of file diff --git a/jscomp/test/label_uncurry.res b/jscomp/test/label_uncurry.res new file mode 100644 index 0000000000..fc13f6de93 --- /dev/null +++ b/jscomp/test/label_uncurry.res @@ -0,0 +1,17 @@ +type t = (. ~x: int, ~y: string) => int + +type u = Js.Fn.arity2<(~x: int, ~y: string) => int> + +let f = (x: t): u => x + +let u: u = (. ~x, ~y) => x + int_of_string(y) + +let u1 = (f: u) => { + f(. ~y="x", ~x=2)->Js.log + f(. ~x=2, ~y="x")->Js.log +} +let h = (. ~x : unit) => 3 + +let a = u1(u) + +type u0 = (. ~x: int=?, ~y: string) => int diff --git a/jscomp/test/poly_variant_test.js b/jscomp/test/poly_variant_test.js index 786c739b40..a49be884ae 100644 --- a/jscomp/test/poly_variant_test.js +++ b/jscomp/test/poly_variant_test.js @@ -59,13 +59,13 @@ var vv = [ hey_int(4) ]; -eq("File \"poly_variant_test.ml\", line 58, characters 5-12", vv, [ +eq("File \"poly_variant_test.res\", line 64, characters 5-12", vv, [ 3, 0, 4 ]); -eq("File \"poly_variant_test.ml\", line 59, characters 5-12", [ +eq("File \"poly_variant_test.res\", line 65, characters 5-12", [ hey_int(5), hey_int(6) ], [ @@ -73,7 +73,7 @@ eq("File \"poly_variant_test.ml\", line 59, characters 5-12", [ 6 ]); -eq("File \"poly_variant_test.ml\", line 60, characters 5-12", uu, [ +eq("File \"poly_variant_test.res\", line 66, characters 5-12", uu, [ "on_open", "on_closed", "in" @@ -91,9 +91,9 @@ function p_is_int_test(x) { } } -eq("File \"poly_variant_test.ml\", line 142, characters 5-12", 2, 2); +eq("File \"poly_variant_test.res\", line 156, characters 5-12", 2, 2); -eq("File \"poly_variant_test.ml\", line 143, characters 5-12", 3, p_is_int_test({ +eq("File \"poly_variant_test.res\", line 157, characters 5-12", 3, p_is_int_test({ NAME: "b", VAL: 2 })); diff --git a/jscomp/test/poly_variant_test.ml b/jscomp/test/poly_variant_test.ml deleted file mode 100644 index 542a7e2385..0000000000 --- a/jscomp/test/poly_variant_test.ml +++ /dev/null @@ -1,164 +0,0 @@ -let suites : Mt.pair_suites ref = ref [] -let test_id = ref 0 -let eq loc x y = - incr test_id ; - suites := - (loc ^" id " ^ (string_of_int !test_id), (fun _ -> Mt.Eq(x,y))) :: !suites - -[%%bs.raw{| -function hey_string (option){ - switch(option){ - case "on_closed" : - case "on_open" : - case "in" : return option - default : throw Error ("impossible") - } -} -function hey_int (option){ - switch (option){ - case 0 : - case 3 : - case 4 : - case 5: - case 6 : return option - default : throw Error("impossible") - } - } -|}] - -type u = [`on_closed | `on_open | `in_ - (* [@bs.as "in"] TODO: warning test *)] -(* indeed we have a warning here*) -(* TODO: add warning test -*) -(** when marshall, make sure location does not matter *) -external test_string_type : - flag:([`on_closed | `on_open | `in_ [@bs.as "in"]] - [@bs.string]) -> string = - "hey_string" [@@bs.val] - -external test_int_type : - ([`on_closed - | `on_open [@bs.as 3] - | `in_ - | `again [@bs.as 5] - | `hey - ] - [@bs.int]) -> int = - "hey_int" [@@bs.val] - -let uu = - [| test_string_type ~flag: `on_open; test_string_type ~flag: `on_closed; - test_string_type ~flag: `in_ |] - -let vv = - [| test_int_type `on_open; test_int_type `on_closed; test_int_type `in_ |] - -let () = - eq __LOC__ vv [|3;0;4|]; - eq __LOC__ (test_int_type `again, test_int_type `hey) (5,6); - eq __LOC__ uu [|"on_open"; "on_closed"; "in"|] - - -let option = `on_closed - -let v = test_string_type ~flag:option - -let ff h = test_string_type ~flag:h - -let xx = test_string_type ~flag:`in_ - -type readline -external on : - readline -> - ([ `line of (string -> unit [@bs]) - | `close of (unit -> unit [@bs])] - [@bs.string]) -> - unit = - "on" [@@bs.send] - - -let register readline = - on readline (`line begin fun[@bs] s -> Js.log s end); - on readline (`close begin fun[@bs] () -> Js.log "finished" end) - -(* external on : *) -(* ([ `line of (string -> unit [@bs]) *) -(* | `close of (unit -> unit [@bs])] *) -(* [@bs.string]) -> *) -(* readline -> readline = *) -(* "on" [@@bs.send] *) -external on2 : - readline -> - ([ `line of (string -> unit [@bs]) - | `close of (unit -> unit [@bs])] - [@bs.string]) -> - unit = - "on2" [@@bs.send] - -external readFileSync : - string -> ([`utf8 | `ascii] ) -> - string = "readFileSync" - [@@bs.module "fs"] - -let read name = - readFileSync name `utf8 - -module N = struct - external readFileSync : - string -> ([`utf8 | `ascii] ) -> - string = "readFileSync" - [@@bs.module "fs"] - let read name = - readFileSync name `utf8 - -end -let readN = N.read -(** -let register readline = - readline - |> on (`line begin fun [@bs] s -> Js.log s end) - |> on (`close begin fun [@bs] () -> Js.log "finished" end) - -{[ -let register readline = - on (`line begin fun [@bs] s -> Js.log s end) readline; - on (`close begin fun [@bs] () -> Js.log "finished" end) readline - -]} -*) -let test readline x = - on readline x - - -let p_is_int_test x = - match x with - | `a -> 2 - | `b _ -> 3 - -let u = `b 2 - -let () = - eq __LOC__ 2 (p_is_int_test `a); - eq __LOC__ 3 (p_is_int_test u) - - -let hey x = - match x with - | `a - | `b - | `d - | `c as u -> - Js.log "u"; - Js.log u - - | `e - | `f - | `h as v -> - Js.log "v"; - Js.log v -;; - - - -let () = Mt.from_pair_suites __MODULE__ !suites diff --git a/jscomp/test/poly_variant_test.mli b/jscomp/test/poly_variant_test.mli deleted file mode 100644 index d5e264e1c8..0000000000 --- a/jscomp/test/poly_variant_test.mli +++ /dev/null @@ -1,47 +0,0 @@ -#if 0 then - - -external test_string_type : flag:([`on_closed | `on_open | `in_ [@bs.as "in"]] - [@bs.string]) -> string = - "hey_string" [@@bs.val] - - -external test_int_type : - ([`on_closed | `on_open [@bs.as 3] - | `in_ - | `again [@bs.as 5] - | `hey - ] - [@bs.int]) -> int = - "hey_int" [@@bs.val] - -val uu : string array -val vv : int array - -type readline - -val register : readline -> unit - -val test : readline -> - [ `close of (unit -> unit [@bs]) - | `line of (string -> unit [@bs]) ] -> unit - - - -val on2 : - readline -> - ([ `line of (string -> unit [@bs]) - | `close of (unit -> unit [@bs])] - ) -> - unit - -val read : string -> string -val readN : string -> string - -val p_is_int_test - : [`a | `b of int] -> int - -val hey : - [ `a | `b | `c | `d | `e | `f | `h ] -> unit - -#end \ No newline at end of file diff --git a/jscomp/test/poly_variant_test.res b/jscomp/test/poly_variant_test.res new file mode 100644 index 0000000000..df61fea5f8 --- /dev/null +++ b/jscomp/test/poly_variant_test.res @@ -0,0 +1,176 @@ +let suites: ref = ref(list{}) +let test_id = ref(0) +let eq = (loc, x, y) => { + incr(test_id) + suites := + list{(loc ++ (" id " ++ string_of_int(test_id.contents)), _ => Mt.Eq(x, y)), ...suites.contents} +} + +%%raw(` +function hey_string (option){ + switch(option){ + case "on_closed" : + case "on_open" : + case "in" : return option + default : throw Error ("impossible") + } +} +function hey_int (option){ + switch (option){ + case 0 : + case 3 : + case 4 : + case 5: + case 6 : return option + default : throw Error("impossible") + } + } +`) + +@ocaml.doc(" when marshall, make sure location does not matter ") +type u = [ + | #on_closed + | #on_open + | #in_ + /* [@bs.as "in"] TODO: warning test */ +] +/* indeed we have a warning here */ +/* TODO: add warning test + */ + +@ocaml.doc(" when marshall, make sure location does not matter ") @val +external test_string_type: (~flag: @string [#on_closed | #on_open | @as("in") #in_]) => string = + "hey_string" + +@val +external test_int_type: @int +[ + | #on_closed + | @as(3) #on_open + | #in_ + | @as(5) #again + | #hey +] => int = "hey_int" + +let uu = [ + test_string_type(~flag=#on_open), + test_string_type(~flag=#on_closed), + test_string_type(~flag=#in_), +] + +let vv = [test_int_type(#on_open), test_int_type(#on_closed), test_int_type(#in_)] + +let () = { + eq(__LOC__, vv, [3, 0, 4]) + eq(__LOC__, (test_int_type(#again), test_int_type(#hey)), (5, 6)) + eq(__LOC__, uu, ["on_open", "on_closed", "in"]) +} + +let option = #on_closed + +let v = test_string_type(~flag=option) + +let ff = h => test_string_type(~flag=h) + +let xx = test_string_type(~flag=#in_) + +type readline +@send +external on: ( + readline, + @string + [ + | #line((. string) => unit) + | #close((. unit) => unit) + ], +) => unit = "on" + +let register = readline => { + on(readline, #line((. s) => Js.log(s))) + on(readline, #close((. ()) => Js.log("finished"))) +} + +/* external on : */ +/* ([ `line of (string -> unit [@bs]) */ +/* | `close of (unit -> unit [@bs])] */ +/* [@bs.string]) -> */ +/* readline -> readline = */ +/* "on" [@@bs.send] */ +@send +external on2: ( + readline, + @string + [ + | #line((. string) => unit) + | #close((. unit) => unit) + ], +) => unit = "on2" + +@module("fs") external readFileSync: (string, [#utf8 | #ascii]) => string = "readFileSync" + +let read = name => readFileSync(name, #utf8) + +module N = { + @module("fs") external readFileSync: (string, [#utf8 | #ascii]) => string = "readFileSync" + let read = name => readFileSync(name, #utf8) +} +@ocaml.doc(" +let register readline = + readline + |> on (`line begin fun [@bs] s -> Js.log s end) + |> on (`close begin fun [@bs] () -> Js.log \"finished\" end) + +{[ +let register readline = + on (`line begin fun [@bs] s -> Js.log s end) readline; + on (`close begin fun [@bs] () -> Js.log \"finished\" end) readline + +]} +") +let readN = N.read + +@ocaml.doc(" +let register readline = + readline + |> on (`line begin fun [@bs] s -> Js.log s end) + |> on (`close begin fun [@bs] () -> Js.log \"finished\" end) + +{[ +let register readline = + on (`line begin fun [@bs] s -> Js.log s end) readline; + on (`close begin fun [@bs] () -> Js.log \"finished\" end) readline + +]} +") +let test = (readline, x) => on(readline, x) + +let p_is_int_test = x => + switch x { + | #a => 2 + | #b(_) => 3 + } + +let u = #b(2) + +let () = { + eq(__LOC__, 2, p_is_int_test(#a)) + eq(__LOC__, 3, p_is_int_test(u)) +} + +let hey = x => + switch x { + | (#a + | #b + | #d + | #c) as u => + Js.log("u") + Js.log(u) + + | (#e + | #f + | #h) as v => + Js.log("v") + Js.log(v) + } + +let () = Mt.from_pair_suites(__MODULE__, suites.contents) diff --git a/jscomp/test/poly_variant_test.resi b/jscomp/test/poly_variant_test.resi new file mode 100644 index 0000000000..e69de29bb2 diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 830c4506fd..b31c98416c 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -54633,6 +54633,85 @@ and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) ]) and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = + let printArrow ~uncurried typExpr = + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let uncurried, attrsBefore = + (* Converting .ml code to .res requires processing uncurried attributes *) + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore + in + (uncurried || isUncurried, attrs) + in + let returnTypeNeedsParens = + match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not uncurried -> + let hasAttrsBefore = not (attrsBefore = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil + in + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc + in + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [typDoc; Doc.text " => "; returnDoc]); + ]) + | args -> + let attrs = + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if uncurried then Doc.concat [Doc.dot; Doc.space] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun tp -> printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] + in + Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc]) + in let renderedType = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" @@ -54659,6 +54738,16 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = (* object printings *) | Ptyp_object (fields, openFlag) -> printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_arrow _ -> printArrow ~uncurried:false typExpr + | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), "arity0")}, [tArg]) -> + let unitConstr = Location.mkloc (Longident.Lident "unit") tArg.ptyp_loc in + let tUnit = Ast_helper.Typ.constr unitConstr [] in + printArrow ~uncurried:true + {tArg with ptyp_desc = Ptyp_arrow (Nolabel, tUnit, tArg)} + | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), arity)}, [tArg]) + when String.length arity >= 5 + && (String.sub [@doesNotRaise]) arity 0 5 = "arity" -> + printArrow ~uncurried:true tArg | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we @@ -54706,78 +54795,6 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = Doc.softLine; Doc.greaterThan; ])) - | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in - match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil - in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc - in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); - ]) - | args -> - let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [Doc.dot; Doc.space] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun tp -> printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] - in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) | Ptyp_tuple types -> printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl @@ -54977,6 +54994,7 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = * type t = (~foo: string, ~bar: float=?, unit) => unit * i.e. ~foo: string, ~bar: float *) and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = + (* Converting .ml code to .res requires processing uncurried attributes *) let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index d66016b4c6..38b580b2e2 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -54633,6 +54633,85 @@ and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) ]) and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = + let printArrow ~uncurried typExpr = + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let uncurried, attrsBefore = + (* Converting .ml code to .res requires processing uncurried attributes *) + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore + in + (uncurried || isUncurried, attrs) + in + let returnTypeNeedsParens = + match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not uncurried -> + let hasAttrsBefore = not (attrsBefore = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil + in + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc + in + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [typDoc; Doc.text " => "; returnDoc]); + ]) + | args -> + let attrs = + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if uncurried then Doc.concat [Doc.dot; Doc.space] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun tp -> printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] + in + Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc]) + in let renderedType = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" @@ -54659,6 +54738,16 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = (* object printings *) | Ptyp_object (fields, openFlag) -> printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_arrow _ -> printArrow ~uncurried:false typExpr + | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), "arity0")}, [tArg]) -> + let unitConstr = Location.mkloc (Longident.Lident "unit") tArg.ptyp_loc in + let tUnit = Ast_helper.Typ.constr unitConstr [] in + printArrow ~uncurried:true + {tArg with ptyp_desc = Ptyp_arrow (Nolabel, tUnit, tArg)} + | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), arity)}, [tArg]) + when String.length arity >= 5 + && (String.sub [@doesNotRaise]) arity 0 5 = "arity" -> + printArrow ~uncurried:true tArg | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we @@ -54706,78 +54795,6 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = Doc.softLine; Doc.greaterThan; ])) - | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in - match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil - in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc - in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); - ]) - | args -> - let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [Doc.dot; Doc.space] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun tp -> printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] - in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) | Ptyp_tuple types -> printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl @@ -54977,6 +54994,7 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = * type t = (~foo: string, ~bar: float=?, unit) => unit * i.e. ~foo: string, ~bar: float *) and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = + (* Converting .ml code to .res requires processing uncurried attributes *) let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil @@ -287391,9 +287409,30 @@ and parseEs6ArrowType ~attrs p = let endPos = p.prevEndPos in let typ = List.fold_right - (fun (uncurried, attrs, argLbl, typ, startPos) t -> - let attrs = if uncurried then uncurryAttr :: attrs else attrs in - Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t) + (fun (uncurried, attrs, argLbl, (typ : Parsetree.core_type), startPos) t -> + if uncurried then + let isUnit = + match typ.ptyp_desc with + | Ptyp_constr ({txt = Lident "unit"}, []) -> true + | _ -> false + in + let _, args, _ = Res_parsetree_viewer.arrowType t in + let arity = 1 + List.length args in + let loc = mkLoc startPos endPos in + let arity, tArg = + if isUnit && arity = 1 then (0, t) + else (arity, Ast_helper.Typ.arrow ~loc ~attrs argLbl typ t) + in + Ast_helper.Typ.constr ~loc + { + txt = + Ldot (Ldot (Lident "Js", "Fn"), "arity" ^ string_of_int arity); + loc; + } + [tArg] + else + Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ + t) parameters returnType in { diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index b9ef9ed3a4..482a672e40 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -230495,6 +230495,85 @@ and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) ]) and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = + let printArrow ~uncurried typExpr = + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let uncurried, attrsBefore = + (* Converting .ml code to .res requires processing uncurried attributes *) + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore + in + (uncurried || isUncurried, attrs) + in + let returnTypeNeedsParens = + match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not uncurried -> + let hasAttrsBefore = not (attrsBefore = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil + in + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc + in + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [typDoc; Doc.text " => "; returnDoc]); + ]) + | args -> + let attrs = + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if uncurried then Doc.concat [Doc.dot; Doc.space] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun tp -> printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] + in + Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc]) + in let renderedType = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" @@ -230521,6 +230600,16 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = (* object printings *) | Ptyp_object (fields, openFlag) -> printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_arrow _ -> printArrow ~uncurried:false typExpr + | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), "arity0")}, [tArg]) -> + let unitConstr = Location.mkloc (Longident.Lident "unit") tArg.ptyp_loc in + let tUnit = Ast_helper.Typ.constr unitConstr [] in + printArrow ~uncurried:true + {tArg with ptyp_desc = Ptyp_arrow (Nolabel, tUnit, tArg)} + | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), arity)}, [tArg]) + when String.length arity >= 5 + && (String.sub [@doesNotRaise]) arity 0 5 = "arity" -> + printArrow ~uncurried:true tArg | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we @@ -230568,78 +230657,6 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = Doc.softLine; Doc.greaterThan; ])) - | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in - match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil - in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc - in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); - ]) - | args -> - let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [Doc.dot; Doc.space] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun tp -> printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] - in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) | Ptyp_tuple types -> printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl @@ -230839,6 +230856,7 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = * type t = (~foo: string, ~bar: float=?, unit) => unit * i.e. ~foo: string, ~bar: float *) and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = + (* Converting .ml code to .res requires processing uncurried attributes *) let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil @@ -300823,9 +300841,30 @@ and parseEs6ArrowType ~attrs p = let endPos = p.prevEndPos in let typ = List.fold_right - (fun (uncurried, attrs, argLbl, typ, startPos) t -> - let attrs = if uncurried then uncurryAttr :: attrs else attrs in - Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t) + (fun (uncurried, attrs, argLbl, (typ : Parsetree.core_type), startPos) t -> + if uncurried then + let isUnit = + match typ.ptyp_desc with + | Ptyp_constr ({txt = Lident "unit"}, []) -> true + | _ -> false + in + let _, args, _ = Res_parsetree_viewer.arrowType t in + let arity = 1 + List.length args in + let loc = mkLoc startPos endPos in + let arity, tArg = + if isUnit && arity = 1 then (0, t) + else (arity, Ast_helper.Typ.arrow ~loc ~attrs argLbl typ t) + in + Ast_helper.Typ.constr ~loc + { + txt = + Ldot (Ldot (Lident "Js", "Fn"), "arity" ^ string_of_int arity); + loc; + } + [tArg] + else + Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ + t) parameters returnType in { diff --git a/res_syntax/src/res_core.ml b/res_syntax/src/res_core.ml index 82f710370f..f99378fa64 100644 --- a/res_syntax/src/res_core.ml +++ b/res_syntax/src/res_core.ml @@ -4144,9 +4144,30 @@ and parseEs6ArrowType ~attrs p = let endPos = p.prevEndPos in let typ = List.fold_right - (fun (uncurried, attrs, argLbl, typ, startPos) t -> - let attrs = if uncurried then uncurryAttr :: attrs else attrs in - Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t) + (fun (uncurried, attrs, argLbl, (typ : Parsetree.core_type), startPos) t -> + if uncurried then + let isUnit = + match typ.ptyp_desc with + | Ptyp_constr ({txt = Lident "unit"}, []) -> true + | _ -> false + in + let _, args, _ = Res_parsetree_viewer.arrowType t in + let arity = 1 + List.length args in + let loc = mkLoc startPos endPos in + let arity, tArg = + if isUnit && arity = 1 then (0, t) + else (arity, Ast_helper.Typ.arrow ~loc ~attrs argLbl typ t) + in + Ast_helper.Typ.constr ~loc + { + txt = + Ldot (Ldot (Lident "Js", "Fn"), "arity" ^ string_of_int arity); + loc; + } + [tArg] + else + Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ + t) parameters returnType in { diff --git a/res_syntax/src/res_printer.ml b/res_syntax/src/res_printer.ml index 3dcd103439..86bc017c55 100644 --- a/res_syntax/src/res_printer.ml +++ b/res_syntax/src/res_printer.ml @@ -1568,6 +1568,85 @@ and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) ]) and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = + let printArrow ~uncurried typExpr = + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let uncurried, attrsBefore = + (* Converting .ml code to .res requires processing uncurried attributes *) + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore + in + (uncurried || isUncurried, attrs) + in + let returnTypeNeedsParens = + match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not uncurried -> + let hasAttrsBefore = not (attrsBefore = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil + in + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc + in + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [typDoc; Doc.text " => "; returnDoc]); + ]) + | args -> + let attrs = + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if uncurried then Doc.concat [Doc.dot; Doc.space] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun tp -> printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] + in + Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc]) + in let renderedType = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" @@ -1594,6 +1673,16 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = (* object printings *) | Ptyp_object (fields, openFlag) -> printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_arrow _ -> printArrow ~uncurried:false typExpr + | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), "arity0")}, [tArg]) -> + let unitConstr = Location.mkloc (Longident.Lident "unit") tArg.ptyp_loc in + let tUnit = Ast_helper.Typ.constr unitConstr [] in + printArrow ~uncurried:true + {tArg with ptyp_desc = Ptyp_arrow (Nolabel, tUnit, tArg)} + | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), arity)}, [tArg]) + when String.length arity >= 5 + && (String.sub [@doesNotRaise]) arity 0 5 = "arity" -> + printArrow ~uncurried:true tArg | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we @@ -1641,78 +1730,6 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = Doc.softLine; Doc.greaterThan; ])) - | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in - match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil - in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc - in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); - ]) - | args -> - let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [Doc.dot; Doc.space] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun tp -> printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] - in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) | Ptyp_tuple types -> printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl @@ -1912,6 +1929,7 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = * type t = (~foo: string, ~bar: float=?, unit) => unit * i.e. ~foo: string, ~bar: float *) and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = + (* Converting .ml code to .res requires processing uncurried attributes *) let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil diff --git a/res_syntax/tests/parsing/errors/other/expected/regionMissingComma.res.txt b/res_syntax/tests/parsing/errors/other/expected/regionMissingComma.res.txt index bb52d088ae..32b0e6ae43 100644 --- a/res_syntax/tests/parsing/errors/other/expected/regionMissingComma.res.txt +++ b/res_syntax/tests/parsing/errors/other/expected/regionMissingComma.res.txt @@ -24,7 +24,7 @@ external make : ?style:((ReactDOMRe.Style.t)[@ns.namedArgLoc ]) -> - ((?image:((bool)[@ns.namedArgLoc ]) -> React.element)[@bs ]) = + (?image:((bool)[@ns.namedArgLoc ]) -> React.element) Js.Fn.arity1 = "ModalContent" type nonrec 'extraInfo student = { diff --git a/res_syntax/tests/parsing/grammar/typexpr/expected/uncurried.res.txt b/res_syntax/tests/parsing/grammar/typexpr/expected/uncurried.res.txt index d7c79b79df..a1fefd1721 100644 --- a/res_syntax/tests/parsing/grammar/typexpr/expected/uncurried.res.txt +++ b/res_syntax/tests/parsing/grammar/typexpr/expected/uncurried.res.txt @@ -1,20 +1,22 @@ type nonrec t = { - mutable field: ((float -> int -> bool -> unit)[@bs ]) } -type nonrec t = ((float -> int -> bool -> unit)[@bs ]) + mutable field: (float -> int -> bool -> unit) Js.Fn.arity3 } +type nonrec t = (float -> int -> bool -> unit) Js.Fn.arity3 type nonrec t = - ((((float)[@attr ]) -> - ((int)[@attr2 ]) -> - ((((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit)[@bs ]))[@bs ]) + (((float)[@attr ]) -> + ((int)[@attr2 ]) -> + (((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit) Js.Fn.arity2) + Js.Fn.arity2 type nonrec t = - ((float -> - ((int)[@attr2 ]) -> - ((bool -> ((string)[@attr4 ]) -> unit)[@bs ][@attr3 ]))[@bs ] - [@attr ]) + (((float -> + ((int)[@attr2 ]) -> + (((bool -> ((string)[@attr4 ]) -> unit) Js.Fn.arity2)[@attr3 ])) + Js.Fn.arity2)[@attr ]) type nonrec t = - ((((float)[@attr ]) -> - ((int)[@attr2 ]) -> - ((((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit)[@bs ]))[@bs ]) -external setTimeout : ((unit -> unit)[@bs ]) -> int -> timerId = "setTimeout" + (((float)[@attr ]) -> + ((int)[@attr2 ]) -> + (((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit) Js.Fn.arity2) + Js.Fn.arity2 +external setTimeout : unit Js.Fn.arity0 -> int -> timerId = "setTimeout" [@@bs.val ] external setTimeout : - (((unit -> unit) -> int -> timerId)[@bs ]) = "setTimeout" \ No newline at end of file + ((unit -> unit) -> int -> timerId) Js.Fn.arity2 = "setTimeout" \ No newline at end of file diff --git a/res_syntax/tests/printer/typexpr/expected/arrow.res.txt b/res_syntax/tests/printer/typexpr/expected/arrow.res.txt index 4253ff517e..2c29260aba 100644 --- a/res_syntax/tests/printer/typexpr/expected/arrow.res.txt +++ b/res_syntax/tests/printer/typexpr/expected/arrow.res.txt @@ -211,7 +211,7 @@ type t = (. int, int) => (. int, int) => int type t = (. @attr int) => unit type t = (. @attr int) => (. @attr2 int) => unit type t = (. @attrOnInt int, @attrOnInt int) => (. @attrOnInt int, @attrOnInt int) => int -type t = (. @attr ~x: int, ~y: int, . @attr ~z: int, @attr ~omega: int) => unit +type t = (. @attr ~x: int, ~y: int) => (. @attr ~z: int, @attr ~omega: int) => unit @val external requestAnimationFrame: (float => unit) => unit = "requestAnimationFrame" @val external requestAnimationFrame: @attr ((float => unit) => unit) = "requestAnimationFrame"