diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..24acb2e --- /dev/null +++ b/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 diff --git a/README.md b/README.md index 1e5d50a..7d12368 100644 --- a/README.md +++ b/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,21 +112,16 @@ 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"] @@ -134,39 +129,33 @@ 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 diff --git a/src/expander.ml b/src/expander.ml index c7c19bd..34111e1 100644 --- a/src/expander.ml +++ b/src/expander.ml @@ -270,6 +270,29 @@ 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 @@ -277,45 +300,7 @@ let implementation_generator ~(loc : location) ~rec_flag ~substitutions 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" diff --git a/test/test.ml b/test/test.ml index 88f3bbc..e00a9fd 100644 --- a/test/test.ml +++ b/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))) ->