Implement pretty outcome printing for uncurried outcometree types (#214)

Author: IwanKaramazow

src/res_outcome_printer.ml

@@ -10,6 +10,13 @@
 module Doc = Res_doc
 module Token = Res_token
 
+(* checks if ident contains "arity", like in "arity1", "arity2", "arity3" etc. *)
+let isArityIdent ident =
+  if String.length ident >= 6 then
+    (String.sub [@doesNotRaise]) ident 0 5 = "arity"
+  else
+    false
+
 type identifierStyle =
   | ExoticIdent
   | NormalIdent
@@ -195,6 +202,21 @@ let printIdentLike ~allowUident txt =
          Doc.text " as '";
          Doc.text aliasTxt
        ]
+     | Otyp_constr (
+        Oide_dot (Oide_dot (Oide_ident "Js", "Fn") , "arity0"), (* Js.Fn.arity0 *)
+        [Otyp_constr (Oide_ident ident, [])] (* int or unit or string *)
+       ) ->
+        (* Js.Fn.arity0<int> -> (.) => int*)
+        Doc.concat [
+          Doc.text "(.) => ";
+          Doc.text ident;
+        ]
+     | Otyp_constr (
+        Oide_dot (Oide_dot (Oide_ident "Js", "Fn") , ident), (* Js.Fn.arity2 *)
+        [(Otyp_arrow _) as arrowType] (* (int, int) => int *)
+     ) when isArityIdent ident ->
+      (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*)
+       printOutArrowType ~uncurried:true arrowType
      | Otyp_constr (outIdent, []) ->
        printOutIdentDoc ~allowUident:false outIdent
      | Otyp_manifest (typ1, typ2) ->
@@ -283,51 +305,56 @@ let printIdentLike ~allowUident txt =
          ]
        )
      | Otyp_arrow _ as typ ->
-       let (typArgs, typ) = collectArrowArgs typ [] in
-       let args = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
-         List.map (fun (lbl, typ) ->
-           if lbl = "" then
-             printOutTypeDoc typ
-           else
-             Doc.group (
-               Doc.concat [
-                 Doc.text ("~" ^ lbl ^ ": ");
-                 printOutTypeDoc typ
-               ]
-             )
-         ) typArgs
-       ) in
-       let argsDoc =
-         let needsParens = match typArgs with
-         | [_, (Otyp_tuple _ | Otyp_arrow _)] -> true
-         (* single argument should not be wrapped *)
-         | ["", _] -> false
-         | _ -> true
-         in
-         if needsParens then
+       printOutArrowType ~uncurried:false typ
+     | Otyp_module (_modName, _stringList, _outTypes) ->
+         Doc.nil
+
+   and printOutArrowType ~uncurried typ =
+     let (typArgs, typ) = collectArrowArgs typ [] in
+     let args = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+       List.map (fun (lbl, typ) ->
+         if lbl = "" then
+           printOutTypeDoc typ
+         else
            Doc.group (
              Doc.concat [
-               Doc.lparen;
-               Doc.indent (
-                 Doc.concat [
-                   Doc.softLine;
-                   args;
-                 ]
-               );
-               Doc.trailingComma;
-               Doc.softLine;
-               Doc.rparen;
+               Doc.text ("~" ^ lbl ^ ": ");
+               printOutTypeDoc typ
              ]
            )
-         else args
+       ) typArgs
+     ) in
+     let argsDoc =
+       let needsParens = match typArgs with
+       | _ when uncurried -> true
+       | [_, (Otyp_tuple _ | Otyp_arrow _)] -> true
+       (* single argument should not be wrapped *)
+       | ["", _] -> false
+       | _ -> true
        in
-       Doc.concat [
-         argsDoc;
-         Doc.text " => ";
-         printOutTypeDoc typ;
-       ]
-     | Otyp_module (_modName, _stringList, _outTypes) ->
-         Doc.nil
+       if needsParens then
+         Doc.group (
+           Doc.concat [
+             if uncurried then Doc.text "(. " else Doc.lparen;
+             Doc.indent (
+               Doc.concat [
+                 Doc.softLine;
+                 args;
+               ]
+             );
+             Doc.trailingComma;
+             Doc.softLine;
+             Doc.rparen;
+           ]
+         )
+       else args
+     in
+     Doc.concat [
+       argsDoc;
+       Doc.text " => ";
+       printOutTypeDoc typ;
+     ]
+
 
    and printOutVariant variant = match variant with
      | Ovar_fields fields -> (* (string * bool * out_type list) list *)

tests/oprint/oprint.res

@@ -188,3 +188,57 @@ type exoticUser = {
   \"let": string,
   \"type": float
 }
+
+module Js = {
+  module Fn = {
+    type arity0<'a> = {i0: unit => 'a}
+    type arity1<'a> = {i1: 'a}
+    type arity2<'a> = {i2: 'a}
+    type arity3<'a> = {i3: 'a}
+    type arity4<'a> = {i4: 'a}
+    type arity5<'a> = {i5: 'a}
+    type arity6<'a> = {i6: 'a}
+    type arity7<'a> = {i7: 'a}
+    type arity8<'a> = {i8: 'a}
+    type arity9<'a> = {i9: 'a}
+    type arity10<'a> = {i10: 'a}
+    type arity11<'a> = {i11: 'a}
+    type arity12<'a> = {i12: 'a}
+    type arity13<'a> = {i13: 'a}
+    type arity14<'a> = {i14: 'a}
+    type arity15<'a> = {i15: 'a}
+    type arity16<'a> = {i16: 'a}
+    type arity17<'a> = {i17: 'a}
+    type arity18<'a> = {i18: 'a}
+    type arity19<'a> = {i19: 'a}
+    type arity20<'a> = {i20: 'a}
+    type arity21<'a> = {i21: 'a}
+    type arity22<'a> = {i22: 'a}
+  }
+}
+
+type arity0 = Js.Fn.arity0<unit>
+type arity0b = Js.Fn.arity0<int>
+type arity1 = Js.Fn.arity1<(int) => int>
+type arity2 = Js.Fn.arity2<(int, int) => int>
+type arity3 = Js.Fn.arity3<(int, int, int) => int>
+type arity4 = Js.Fn.arity4<(int, int, int, int) => int>
+type arity5 = Js.Fn.arity5<(int, int, int, int, int) => int>
+type arity6 = Js.Fn.arity6<(int, int, int, int, int, int) => int>
+type arity7 = Js.Fn.arity7<(int, int, int, int, int, int, int) => int>
+type arity8 = Js.Fn.arity8<(int, int, int, int, int, int, int, int) => int>
+type arity9 = Js.Fn.arity9<(int, int, int, int, int, int, int, int, int) => int>
+type arity10 = Js.Fn.arity10<(int, int, int, int, int, int, int, int, int, int) => int>
+type arity11 = Js.Fn.arity11<(int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity12 = Js.Fn.arity12<(int, int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity13 = Js.Fn.arity13<(int, int, int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity14 = Js.Fn.arity14<(int, int, int, int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity15 = Js.Fn.arity15<(int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity16 = Js.Fn.arity16<(int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity17 = Js.Fn.arity17<(int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity18 = Js.Fn.arity18<(int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity19 = Js.Fn.arity19<(int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity20 = Js.Fn.arity20<(int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity21 = Js.Fn.arity21<(int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) => int>
+type arity22 = Js.Fn.arity22<(int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int, int) => int>
+