Fix defaults

Signed-off-by: Jon Ludlam <[email protected]>
jonludlam · Oct 12, 2016 · f0ce1d9 · f0ce1d9
1 parent 0f83e4c
commit f0ce1d9
Show file tree

Hide file tree

Showing 4 changed files with 22 additions and 3 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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 _ =