Add defaults to variant types

Signed-off-by: Jon Ludlam <[email protected]>

example/example.ml

@@ -126,6 +126,7 @@ let vm_name_label : (string, vm) field = {
   fname="name_label";
   fdescription="The name of the VM.";
   fversion=None;
+  fdefault=None;
   field=Basic String;
   fget = (fun f -> f.name_label);
   fset = (fun v s -> {s with name_label = v})
@@ -134,6 +135,7 @@ let vm_name_description : (string, vm) field = {
   fname="name_description";
   fdescription="The description of the VM.";
   fversion=None;
+  fdefault=None;
   field=Basic String;
   fget = (fun f -> f.name_description);
   fset = (fun v s -> {s with name_description = v})
@@ -195,10 +197,11 @@ let errors : (string, exnt) Rpc.Types.tag = Rpc.Types.{
 let exnt_variant : exnt variant = Rpc.Types.{
     variants = [ BoxedTag errors ];
     vversion = None;
-  vconstructor = (fun s t ->
-      match s with
-      | "Errors" -> Rresult.R.map errors.treview (t.tget (Basic String))
-      | s -> Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
+    vdefault = Some (Errors "unknown error tag!");
+    vconstructor = (fun s t ->
+        match s with
+        | "Errors" -> Rresult.R.map errors.treview (t.tget (Basic String))
+        | s -> Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
   }
 
 (* And finally we name and describe the type in an `exnt variant def` type *)
@@ -215,9 +218,9 @@ let err = exnt
 module VMRPC (R : RPC) = struct
   open R
 
-(* We can declare some more information about the interface here for more
-   interesting uses of these declarations - for example, the documentation
-   generator or Cmdliner term generator *)
+  (* We can declare some more information about the interface here for more
+     interesting uses of these declarations - for example, the documentation
+     generator or Cmdliner term generator *)
   let interface = describe Idl.Interface.({
       name="VM";
       description="The VM interface is used to perform power-state operations

lib/idl.ml

@@ -163,6 +163,7 @@ module DefaultError = struct
   let t : t Rpc.Types.variant = Rpc.Types.{
       variants = [ BoxedTag internalerror ];
       vversion = Some (1,0,0);
+      vdefault = Some (InternalError "Unknown error tag!");
       vconstructor = (fun s t ->
           match s with
           | "InternalError" -> Rresult.R.map (fun s -> internalerror.treview s) (t.tget (Basic String))

lib/rpc.ml

@@ -31,7 +31,6 @@ type t =
   | Dict of (string * t) list
   | Null
 
-
 module Version = struct
   type t = int * int * int
 
@@ -103,6 +102,7 @@ module Types = struct
   }
   and 'a variant = {
     variants : 'a boxed_tag list;
+    vdefault : 'a option;
     vversion : Version.t option;
     vconstructor : string -> tag_getter -> ('a, Rresult.R.msg) Result.result;
   }

lib/rpc.mli

@@ -92,6 +92,7 @@ module Types : sig
   }
   and 'a variant = {
     variants : 'a boxed_tag list;
+    vdefault : 'a option;
     vversion : Version.t option;
     vconstructor : string -> tag_getter -> ('a, Rresult.R.msg) Result.result;
   }

ppx/ppx_deriving_rpcty.ml

@@ -157,6 +157,7 @@ module Typ_of = struct
       | Ptype_open, _ ->
         failwith "Unhandled"
       | Ptype_variant constrs, _ ->
+        let default_case = attr_default type_decl.ptype_attributes in
         let cases =
           constrs |> List.map (fun { pcd_name = { txt = name }; pcd_args; pcd_attributes } ->
               let rpc_name = attr_name name pcd_attributes in
@@ -186,11 +187,15 @@ module Typ_of = struct
               let vconstructor_case = Exp.case (Pat.constant (Const_string (lower_rpc_name,None))) [%expr Rresult.R.bind (t.tget [%e contents]) ([%e Exp.function_ [Exp.case (ptuple pattern) [%expr Rresult.R.ok [%e (constr name args)]]]])] in
               (variant, vconstructor_case))
         in
-        let default = [Exp.case (Pat.any ()) [%expr Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s)]] in
+        let default = [Exp.case (Pat.any ())
+                         (match default_case with
+                         | None -> [%expr Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s)]
+                         | Some d -> [%expr Result.Ok [%e d]])] 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)]);
+                  vdefault=[%e match default_case with None -> [%expr None] | Some d -> [%expr Some [%e d]]];
                   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

ppx_test/tytest.ml

@@ -177,6 +177,18 @@ type test_defaults = {
 let test_defaults () =
   assert (Result.Ok {test_with_default=5} = Rpcmarshal.unmarshal typ_of_test_defaults (Rpc.Dict []))
 
+type test_defaults_var =
+   | X1
+   | X2
+  [@@deriving rpcty] [@@default X1]
+
+let test_defaults_var () =
+  assert_equal (Result.Ok X1) (Rpcmarshal.unmarshal typ_of_test_defaults_var (Rpc.String "X3"))
+
+let test_defaults_bad () =
+  match Rpcmarshal.unmarshal typ_of_test_defaults_var (Rpc.Int 3L) with
+  | Ok _ -> assert_failure "Should have had an error"
+  | Error _ -> ()
 
 let suite =
   "basic_tests" >:::
@@ -231,6 +243,8 @@ let suite =
     "poly" >:: test_poly;
     "fakegen" >:: fakegen;
     "defaults" >:: test_defaults;
+    "defaults_var" >:: test_defaults_var;
+    "defaults_bad" >:: test_defaults_bad;
   ]
 
 let _ =