Add support of toArray for polymorphic variants (#18)

green-labs · Jan 11, 2023 · 78fa3b4 · 78fa3b4
1 parent ae2bb49
commit 78fa3b4
Show file tree

Hide file tree

Showing 10 changed files with 114 additions and 48 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -1,5 +1,9 @@
 # CHANGELOG
 
+# 0.1.11
+
+- Add `@ppx_ts.toArray` feature for polymorphic variants
+
 # 0.1.10
 
 - Add `@ppx_ts.toArray` feature

diff --git a/package.json b/package.json
@@ -1,6 +1,6 @@
 {
   "name": "@greenlabs/ppx-ts",
-  "version": "0.1.10",
+  "version": "0.1.11",
   "description": "ReScript PPX helps binding to typescript modules",
   "license": "MIT",
   "author": "Greenlabs Dev <[email protected]>",

diff --git a/ppx_ts.opam b/ppx_ts.opam
@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.1.10"
+version: "0.1.11"
 synopsis: "A PPX helps binding to typescript modules"
 description: ""
 maintainer: ["[email protected]"]

diff --git a/rescript/__tests__/test.js b/rescript/__tests__/test.js
diff --git a/rescript/__tests__/test.res b/rescript/__tests__/test.res
diff --git a/rescript/src/View.js b/rescript/src/View.js
diff --git a/rescript/src/View.res b/rescript/src/View.res
diff --git a/rescript/src/View.resi b/rescript/src/View.resi
diff --git a/src/sig_to_array.ml b/src/sig_to_array.ml
@@ -5,25 +5,32 @@ open Utils
 
 (* keyOf attribute mapper *)
 let make_signature_items name loc manifest kind suffix =
+  let value_binding =
+    [
+      Sig.value ~loc
+        (Val.mk
+           (mkloc (name ^ "_" ^ suffix) loc)
+           (Typ.constr (Utils.lid "array")
+              [ Typ.constr (Utils.lid "string") [] ]));
+    ]
+  in
+
   match (manifest, kind) with
-  | None, Ptype_abstract -> fail loc "Can't handle the unspecified type"
+  | Some { ptyp_desc = Ptyp_variant (_, _, _) }, Ptype_abstract
   | None, Ptype_variant _ ->
-      [
-        Sig.value ~loc
-          (Val.mk
-             (mkloc (name ^ "_" ^ suffix) loc)
-             (Typ.constr (Utils.lid "array")
-                [ Typ.constr (Utils.lid "string") [] ]));
-      ]
+      value_binding
   | _ -> fail loc "This type is not handled by ppx_ts"
 
 (* keyOf extension mapper *)
 let make_new_signature_item name loc manifest kind attributes =
+  let value_description =
+    Sig.value ~loc
+      (Val.mk ~loc ~attrs:attributes (mkloc name loc)
+         (Typ.constr (Utils.lid "array") [ Typ.constr (Utils.lid "string") [] ]))
+  in
+
   match (manifest, kind) with
-  | None, Ptype_abstract -> fail loc "Can't handle the unspecified type"
+  | Some { ptyp_desc = Ptyp_variant (_, _, _) }, Ptype_abstract
   | None, Ptype_record _ ->
-      Sig.value ~loc
-        (Val.mk ~loc ~attrs:attributes (mkloc name loc)
-           (Typ.constr (Utils.lid "array")
-              [ Typ.constr (Utils.lid "string") [] ]))
+      value_description
   | _ -> fail loc "This type is not handled by ppx_ts"
diff --git a/src/str_to_array.ml b/src/str_to_array.ml
@@ -5,43 +5,54 @@ open Utils
 
 (* toArray attribute mapper *)
 let make_structure_items name loc manifest kind suffix =
-  match (manifest, kind) with
-  (* type t *)
-  | None, Ptype_abstract -> fail loc "Can't handle the unspecified type"
-  | None, Ptype_variant cds ->
-      let keys =
+  let keys =
+    match (manifest, kind) with
+    (* type t *)
+    | Some { ptyp_desc = Ptyp_variant (row_fields, _, _) }, Ptype_abstract ->
+        row_fields
+        |> List.filter_map (fun { prf_desc; prf_loc = loc } ->
+               match prf_desc with
+               | Rtag ({ txt }, _, _) -> Some (txt, loc)
+               | Rinherit _ -> None)
+    | None, Ptype_variant cds ->
         cds |> List.map (fun { pcd_name = { txt }; pcd_loc } -> (txt, pcd_loc))
-      in
+    | _ -> fail loc "This type is not handled by @ppx_ts.toArray"
+  in
 
+  [
+    Str.value ~loc Nonrecursive
       [
-        Str.value ~loc Nonrecursive
-          [
-            Vb.mk
-              (Pat.var (mkloc (name ^ "_" ^ suffix) loc))
-              (Exp.array
-                 (keys
-                 |> List.map (fun (key, loc) ->
-                        Exp.constant (Pconst_string (key, loc, None)))));
-          ];
-      ]
-  | _ -> fail loc "This type is not handled by @ppx_ts.toArray"
+        Vb.mk
+          (Pat.var (mkloc (name ^ "_" ^ suffix) loc))
+          (Exp.array
+             (keys
+             |> List.map (fun (key, loc) ->
+                    Exp.constant (Pconst_string (key, loc, None)))));
+      ];
+  ]
 
 (* toArray extension mapper *)
 let make_new_structure_item name loc manifest kind attributes =
-  match (manifest, kind) with
-  (* type t *)
-  | None, Ptype_abstract -> fail loc "Can't handle the unspecified type"
-  | None, Ptype_variant cds ->
-      let keys =
+  let keys =
+    match (manifest, kind) with
+    (* type t *)
+    | Some { ptyp_desc = Ptyp_variant (row_fields, _, _) }, Ptype_abstract ->
+        row_fields
+        |> List.filter_map (fun { prf_desc; prf_loc = loc } ->
+               match prf_desc with
+               | Rtag ({ txt }, _, _) -> Some (txt, loc)
+               | Rinherit _ -> None)
+    | None, Ptype_variant cds ->
         cds |> List.map (fun { pcd_name = { txt }; pcd_loc } -> (txt, pcd_loc))
-      in
-      Str.value ~loc Nonrecursive
-        [
-          Vb.mk ~loc ~attrs:attributes
-            (Pat.var (mkloc name loc))
-            (Exp.array
-               (keys
-               |> List.map (fun (key, loc) ->
-                      Exp.constant (Pconst_string (key, loc, None)))));
-        ]
-  | _ -> fail loc "This type is not handled by %ppx_ts.toArray"
+    | _ -> fail loc "This type is not handled by %ppx_ts.toArray"
+  in
+
+  Str.value ~loc Nonrecursive
+    [
+      Vb.mk ~loc ~attrs:attributes
+        (Pat.var (mkloc name loc))
+        (Exp.array
+           (keys
+           |> List.map (fun (key, loc) ->
+                  Exp.constant (Pconst_string (key, loc, None)))));
+    ]