Merge pull request #4 from benbellick/simplify-sum-type

Makefile

@@ -0,0 +1,8 @@
+dumpast:
+	ocamlfind ppx_tools/dumpast $(file)
+
+opam-install-dev-deps:
+	opam install ocamlformat ocaml-lsp-server ppx_tools
+
+show-ppx-test:
+	dune exec -- pp/pp.exe	test/test.ml

README.md

@@ -88,17 +88,17 @@ type bar = Int of int | String of string [@@deriving_inline decoders]
 let _ = fun (_ : bar) -> ()
 let bar_decoder =
   let open D in
-    one_of
-      [("Int",
-         (D.field "Int"
-            (let open D in
-               let (>>=::) fst rest = uncons rest fst in
-               D.int >>=:: (fun arg0 -> succeed (Int arg0)))));
-      ("String",
-        (D.field "String"
-           (let open D in
-              let (>>=::) fst rest = uncons rest fst in
-              D.string >>=:: (fun arg0 -> succeed (String arg0)))))]
+    single_field
+      (function
+       | "Int" ->
+           let open D in
+             let (>>=::) fst rest = uncons rest fst in
+             D.int >>=:: ((fun arg0 -> succeed (Int arg0)))
+       | "String" ->
+           let open D in
+             let (>>=::) fst rest = uncons rest fst in
+             D.string >>=:: ((fun arg0 -> succeed (String arg0)))
+       | any -> D.fail @@ (Printf.sprintf "Unrecognized field: %s" any))
 let _ = bar_decoder
 [@@@deriving.end]
 ```
@@ -112,61 +112,50 @@ The following file:
 module D = Decoders_yojson.Safe.Decode
 
 type expr = Num of int | BinOp of op * expr * expr
-
-and op = Add | Sub | Mul | Div
+and op = Add | Sub | Mul | Div [@@deriving_inline decoders]
 
 [@@@deriving.end]
 ```
 after invoking `dune build --auto-promote` will yield:
 ```ocaml 
 (* In file foo.ml *)
-module D = Decoders_yojson.Safe.Decode
-
-type expr = Num of int | BinOp of op * expr * expr
-
-and op = Add | Sub | Mul | Div
-[@@deriving decoders] [@@deriving_inline decoders]
-
+ type expr = Num of int | BinOp of op * expr * expr
+ and op = Add | Sub | Mul | Div [@@deriving_inline decoders]
+ 
 let _ = fun (_ : expr) -> ()
 let _ = fun (_ : op) -> ()
 [@@@ocaml.warning "-27"]
 let expr_decoder op_decoder =
   D.fix
     (fun expr_decoder_aux ->
        let open D in
-         one_of
-           [("Num",
-              (D.field "Num"
-                 (let open D in
-                    let (>>=::) fst rest = uncons rest fst in
-                    D.int >>=:: (fun arg0 -> succeed (Num arg0)))));
-           ("BinOp",
-             (D.field "BinOp"
-                (let open D in
-                   let (>>=::) fst rest = uncons rest fst in
-                   op_decoder >>=::
-                     (fun arg0 ->
+         single_field
+           (function
+            | "Num" ->
+                let open D in
+                  let (>>=::) fst rest = uncons rest fst in
+                  D.int >>=:: ((fun arg0 -> succeed (Num arg0)))
+            | "BinOp" ->
+                let open D in
+                  let (>>=::) fst rest = uncons rest fst in
+                  op_decoder >>=::
+                    ((fun arg0 ->
                         expr_decoder_aux >>=::
                           (fun arg1 ->
                              expr_decoder_aux >>=::
                                (fun arg2 ->
-                                  succeed (BinOp (arg0, arg1, arg2))))))))])
+                                  succeed (BinOp (arg0, arg1, arg2))))))
+            | any -> D.fail @@ (Printf.sprintf "Unrecognized field: %s" any)))
 let _ = expr_decoder
 let op_decoder op_decoder =
   let open D in
-    one_of
-      [("Add",
-         (D.string >>=
-            ((function | "Add" -> succeed Add | _ -> fail "Failure"))));
-      ("Sub",
-        (D.string >>=
-           ((function | "Sub" -> succeed Sub | _ -> fail "Failure"))));
-      ("Mul",
-        (D.string >>=
-           ((function | "Mul" -> succeed Mul | _ -> fail "Failure"))));
-      ("Div",
-        (D.string >>=
-           ((function | "Div" -> succeed Div | _ -> fail "Failure"))))]
+    single_field
+      (function
+       | "Add" -> succeed Add
+       | "Sub" -> succeed Sub
+       | "Mul" -> succeed Mul
+       | "Div" -> succeed Div
+       | any -> D.fail @@ (Printf.sprintf "Unrecognized field: %s" any))
 let _ = op_decoder
 let op_decoder = D.fix op_decoder
 let _ = op_decoder

src/expander.ml

@@ -270,52 +270,37 @@ and expr_of_record ~loc ~substitutions ?lift label_decls =
       in
       complete_partial_expr [%expr succeed [%e record_lift]]
 
+let expr_of_variant ~loc ~substitutions cstrs =
+  let open Ast_builder.Default in
+  let match_all_case =
+    let match_all_pvar = pvar ~loc "any" in
+    let match_all_evar = evar ~loc "any" in
+    case ~lhs:match_all_pvar ~guard:None
+      ~rhs:
+        [%expr
+          D.fail @@ Printf.sprintf "Unrecognized field: %s" [%e match_all_evar]]
+  in
+  let to_case (cstr : constructor_declaration) =
+    let name_pattern = pstring ~loc cstr.pcd_name.txt in
+    let dec_expression = expr_of_constr_decl ~substitutions cstr in
+    case ~lhs:name_pattern ~guard:None ~rhs:dec_expression
+  in
+
+  let cases = List.map to_case cstrs in
+  let cases = List.append cases [ match_all_case ] in
+  let decode_by_field = pexp_function ~loc cases in
+  [%expr
+    let open D in
+    single_field [%e decode_by_field]]
+
 let implementation_generator ~(loc : location) ~rec_flag ~substitutions
     type_decl : expression =
   let rec_flag = really_recursive rec_flag [ type_decl ] in
   let name = to_decoder_name type_decl.ptype_name.txt in
   let imple_expr =
     match (type_decl.ptype_kind, type_decl.ptype_manifest) with
     | Ptype_abstract, Some manifest -> expr_of_typ ~substitutions manifest
-    | Ptype_variant cstrs, None ->
-        let constr_decs =
-          Ast_builder.Default.(
-            elist ~loc
-              (List.map
-                 (fun cstr ->
-                   let s = estring ~loc cstr.pcd_name.txt in
-                   let s_p = pstring ~loc cstr.pcd_name.txt in
-                   if cstr.pcd_args = Pcstr_tuple [] then
-                     let lid = lident_of_constructor_decl cstr in
-                     let cstr =
-                       Ast_builder.Default.pexp_construct ~loc lid None
-                     in
-                     pexp_tuple ~loc
-                       [
-                         s;
-                         [%expr
-                           D.string >>= function
-                           | [%p s_p] -> succeed [%e cstr]
-                           | _ -> fail "Failure"];
-                         (* TODO better failure message *)
-                       ]
-                   else
-                     pexp_tuple ~loc
-                       [
-                         s;
-                         [%expr
-                           D.field [%e s]
-                             [%e expr_of_constr_decl ~substitutions cstr]];
-                       ])
-                 cstrs))
-        in
-        let one_of_decoder = Ast_builder.Default.evar ~loc "one_of" in
-        let full_dec =
-          Ast_helper.Exp.apply ~loc one_of_decoder [ (Nolabel, constr_decs) ]
-        in
-        [%expr
-          let open D in
-          [%e full_dec]]
+    | Ptype_variant cstrs, None -> expr_of_variant ~loc ~substitutions cstrs
     | Ptype_record label_decs, _ ->
         expr_of_record ~substitutions ~loc label_decs
     | Ptype_open, _ -> Location.raise_errorf ~loc "Unhandled open"

test/test.ml

@@ -147,11 +147,11 @@ let%test "complex record" =
   | Error _ -> false
 
 let%test "simple constructor-less variant" =
-  (match D.decode_string colors_decoder {|"Red"|} with
+  (match D.decode_string colors_decoder {|{"Red": {}}|} with
   | Ok Red -> true
   | _ -> false)
   &&
-  match D.decode_string colors_decoder {|"Blue"|} with
+  match D.decode_string colors_decoder {|{"Blue": []}|} with
   | Ok Blue -> true
   | _ -> false
 
@@ -160,21 +160,21 @@ let%test "mixed constructor/less variant" =
   | Ok (Online 10) -> true
   | _ -> false)
   &&
-  match D.decode_string status_decoder {|"Offline"|} with
+  match D.decode_string status_decoder {|{"Offline": {}}|} with
   | Ok Offline -> true
   | _ -> false
 
 let%test "my list" =
-  (match D.decode_string my_list_decoder {|"Null"|} with
+  (match D.decode_string my_list_decoder {|{"Null": "doesn't matter"}|} with
   | Ok Null -> true
   | _ -> false)
   &&
-  match D.decode_string my_list_decoder {|{"L": ["Null"]}|} with
+  match D.decode_string my_list_decoder {|{"L": [{"Null": {}}]}|} with
   | Ok (L Null) -> true
   | _ -> false
 
 let%test "variant w/ record constructor" =
-  (match D.decode_string constr_w_rec_decoder {|"Empty"|} with
+  (match D.decode_string constr_w_rec_decoder {|{"Empty": null}|} with
   | Ok Empty -> true
   | _ -> false)
   &&
@@ -219,9 +219,9 @@ let%test "expression mutually-recursive decoder" =
   match
     D.decode_string expr_decoder
       {|{"BinOp" : [
-       "Add",
-       {"BinOp" : ["Div", {"Num": [10]}, {"Num": [5]}]},
-       {"BinOp" : ["Mul", {"Num": [10]}, {"Num": [3]}]}
+       {"Add": {}},
+       {"BinOp" : [{"Div": {}}, {"Num": [10]}, {"Num": [5]}]},
+       {"BinOp" : [{"Mul": {}}, {"Num": [10]}, {"Num": [3]}]}
        ]}|}
   with
   | Ok (BinOp (Add, BinOp (Div, Num 10, Num 5), BinOp (Mul, Num 10, Num 3))) ->