From f0ce1d969a3fa6aca12def4db32f84eb8e20e758 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 12 Oct 2016 17:14:15 +0100 Subject: [PATCH] Fix defaults Signed-off-by: Jon Ludlam --- lib/rpc.ml | 1 + lib/rpc.mli | 1 + ppx/ppx_deriving_rpcty.ml | 14 +++++++++++--- ppx_test/tytest.ml | 9 +++++++++ 4 files changed, 22 insertions(+), 3 deletions(-) diff --git a/lib/rpc.ml b/lib/rpc.ml index 5a62b14e..409ab41d 100644 --- a/lib/rpc.ml +++ b/lib/rpc.ml @@ -75,6 +75,7 @@ module Types = struct fdescription : string; fversion : Version.t option; field : 'a typ; + fdefault : 'a option; fget : 's -> 'a; (* Lenses *) fset : 'a -> 's -> 's; } diff --git a/lib/rpc.mli b/lib/rpc.mli index 2bdf576c..a957f83b 100644 --- a/lib/rpc.mli +++ b/lib/rpc.mli @@ -64,6 +64,7 @@ module Types : sig fdescription : string; fversion : Version.t option; field : 'a typ; + fdefault : 'a option; fget : 's -> 'a; fset : 'a -> 's -> 's; } diff --git a/ppx/ppx_deriving_rpcty.ml b/ppx/ppx_deriving_rpcty.ml index b65cf401..46b35673 100644 --- a/ppx/ppx_deriving_rpcty.ml +++ b/ppx/ppx_deriving_rpcty.ml @@ -116,6 +116,7 @@ module Typ_of = struct [%expr let open Rpc.Types in [%e record ["fname", str rpc_name; "field", expr_of_typ pld_type; + "fdefault", (match default with None -> [%expr None] | Some d -> [%expr Some [%e d]]); "fdescription", str (attr_doc "" pld_attributes); "fversion", (match attr_version pld_attributes with | Some v -> [%expr Some [%e v]] | None -> [%expr None]); "fget", fget; @@ -131,7 +132,10 @@ module Typ_of = struct let construct_record = List.fold_left (fun expr (fname,rpc_name,field_name,pld_type,_,def) -> match def with | Some d -> - [%expr getter.Rpc.Types.fget (*~default:[%e d]*) [%e str rpc_name] [%e expr_of_typ pld_type] >>= fun [%p pvar field_name] -> [%e expr]] + [%expr (match getter.Rpc.Types.fget + [%e str rpc_name] [%e expr_of_typ pld_type] with + | Result.Ok x as y -> y + | Result.Error _ -> Result.Ok [%e d])>>= fun [%p pvar field_name] -> [%e expr]] | None -> [%expr getter.Rpc.Types.fget [%e str rpc_name] [%e expr_of_typ pld_type] >>= fun [%p pvar field_name] -> [%e expr]] ) @@ -145,7 +149,7 @@ module Typ_of = struct [%expr Struct ({ fields=[%e boxed_fields ]; sname=[%e str name]; - version=None; + version=[%e match attr_version type_decl.ptype_attributes with | Some v -> [%expr Some [%e v]] | None -> [%expr None];]; constructor = fun getter -> let open Rresult.R in [%e construct_record] } : [%t mytype ] Rpc.Types.structure)])) ] | Ptype_abstract, None -> @@ -184,7 +188,11 @@ module Typ_of = struct in let default = [Exp.case (Pat.any ()) [%expr Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s)]] in let vconstructor = [%expr fun s' t -> let s = String.lowercase s' in [%e Exp.match_ (evar "s") ((List.map snd cases) @ default)]] in - [ Vb.mk (pvar typ_of_lid) (wrap_runtime (polymorphize ([%expr Variant ({ variants=([%e list (List.map fst cases)]); vversion=None; vconstructor=[%e vconstructor] } : [%t mytype ] variant) ]))) ] + [ Vb.mk (pvar typ_of_lid) (wrap_runtime (polymorphize ( + [%expr Variant ({ + variants=([%e list (List.map fst cases)]); + vversion=[%e match attr_version type_decl.ptype_attributes with | Some v -> [%expr Some [%e v]] | None -> [%expr None];]; + vconstructor=[%e vconstructor] } : [%t mytype ] variant) ]))) ] in let doc = attr_doc "" type_decl.ptype_attributes in let name = type_decl.ptype_name.txt in diff --git a/ppx_test/tytest.ml b/ppx_test/tytest.ml index ae8101e0..935544d6 100644 --- a/ppx_test/tytest.ml +++ b/ppx_test/tytest.ml @@ -170,6 +170,14 @@ let fakegen () = fake typ_of_test_variant_name; fake typ_of_nested +type test_defaults = { + test_with_default : int [@default 5]; +} [@@deriving rpcty] + +let test_defaults () = + assert (Result.Ok {test_with_default=5} = Rpcmarshal.unmarshal typ_of_test_defaults (Rpc.Dict [])) + + let suite = "basic_tests" >::: [ @@ -222,6 +230,7 @@ let suite = "record_attrs" >:: test_record_attrs; "poly" >:: test_poly; "fakegen" >:: fakegen; + "defaults" >:: test_defaults; ] let _ =