Merge pull request #176 from edwintorok/master

Rpc_genfake.{gentest,genall}: avoid crash on recursive types

src/lib/rpc_genfake.ml

@@ -6,8 +6,19 @@ type err = [ `Msg of string ]
 
 let badstuff msg = failwith (Printf.sprintf "Failed to construct the record: %s" msg)
 
-let rec gentest : type a. a typ -> a list =
- fun t ->
+module SeenType = struct
+  type t = T : _ typ -> t
+  let compare a b = if a == b then 0 else Stdlib.compare a b
+end
+
+module Seen = Set.Make(SeenType)
+
+let rec gentest : type a. Seen.t -> a typ -> a list =
+ fun seen t ->
+  let seen_t = SeenType.T t in
+  if Seen.mem seen_t seen then []
+  else
+  let gentest t = gentest (Seen.add seen_t seen) t in
   match t with
   | Basic Int -> [ 0; 1; max_int; -1; 1000000 ]
   | Basic Int32 -> [ 0l; 1l; Int32.max_int; -1l; 999999l ]
@@ -95,10 +106,18 @@ let rec gentest : type a. a typ -> a list =
   | Abstract { test_data; _ } -> test_data
 
 
-let thin d result = if d < 0 then [ List.hd result ] else result
+let thin d result =
+  if d < 0 then match result with
+  | [] -> []
+  | hd :: _ -> [hd]
+  else result
 
-let rec genall : type a. int -> string -> a typ -> a list =
- fun depth strhint t ->
+let rec genall: type a. Seen.t -> int -> string -> a typ -> a list =
+ fun seen depth strhint t ->
+  let seen_t = SeenType.T t in
+  if Seen.mem seen_t seen then []
+  else
+  let genall depth strhint t = genall (Seen.add seen_t seen) depth strhint t in
   match t with
   | Basic Int -> [ 0 ]
   | Basic Int32 -> [ 0l ]
@@ -192,6 +211,8 @@ let rec genall : type a. int -> string -> a typ -> a list =
   | Abstract { test_data; _ } -> test_data
 
 
+(* don't use this on recursive types! *)
+
 let rec gen_nice : type a. a typ -> string -> a =
  fun ty hint ->
   let narg n = Printf.sprintf "%s_%d" hint n in
@@ -235,3 +256,8 @@ let rec gen_nice : type a. a typ -> string -> a =
       let content = gen_nice v.tcontents v.tname in
       v.treview content)
   | Abstract { test_data; _ } -> List.hd test_data
+
+(** don't use this on recursive types! *)
+let gentest t = gentest Seen.empty t
+
+let genall t = genall Seen.empty t

tests/ppx/test_deriving_rpcty.ml

@@ -312,6 +312,11 @@ type nested =
   }
 [@@deriving rpcty]
 
+type recursive =
+  | A of recursive * string
+  | B of int
+[@@deriving rpcty]
+
 let fakegen () =
   let fake ty =
     let fake = Rpc_genfake.genall 10 "string" ty in
@@ -335,7 +340,8 @@ let fakegen () =
   in
   fake typ_of_test_record_opt;
   fake typ_of_test_variant_name;
-  fake typ_of_nested
+  fake typ_of_nested;
+  fake typ_of_recursive
 
 
 type test_defaults = { test_with_default : int [@default 5] } [@@deriving rpcty]