add an example that requires dynamic_bind

examples/serializer/jbuild

@@ -0,0 +1,11 @@
+(jbuild_version 1)
+
+(executable
+ ((name test_serializer)
+  (libraries (crowbar))
+))
+
+(alias
+ ((name runtest)
+  (action (run ${exe:test_serializer.exe}))
+))

examples/serializer/serializer.ml

@@ -0,0 +1,34 @@
+type data =
+  | Datum of string
+  | Block of header * data list
+and header = string
+
+type _ ty =
+  | Int : int ty
+  | Bool : bool ty
+  | Prod : 'a ty * 'b ty -> ('a * 'b) ty
+  | List : 'a ty -> 'a list ty
+
+let rec pp_ty : type a . _ -> a ty -> unit = fun ppf ->
+  let printf fmt = Format.fprintf ppf fmt in
+  function
+  | Int -> printf "Int"
+  | Bool -> printf "Bool"
+  | Prod(ta, tb) -> printf "Prod(%a,%a)" pp_ty ta pp_ty tb
+  | List t -> printf "List(%a)" pp_ty t
+
+let rec serialize : type a . a ty -> a -> data = function
+  | Int -> fun n -> Datum (string_of_int n)
+  | Bool -> fun b -> Datum (string_of_bool b)
+  | Prod (ta, tb) -> fun (va, vb) ->
+    Block("pair", [serialize ta va; serialize tb vb])
+  | List t -> fun vs ->
+    Block("list", List.map (serialize t) vs)
+
+let rec deserialize : type a . a ty -> data -> a = function[@warning "-8"]
+  | Int -> fun (Datum s) -> int_of_string s
+  | Bool -> fun (Datum s) -> bool_of_string s
+  | Prod (ta, tb) -> fun (Block("pair", [sa; sb])) ->
+    (deserialize ta sa, deserialize tb sb)
+  | List t -> fun (Block("list", ss)) ->
+    List.map (deserialize t) ss

examples/serializer/test_serializer.ml

@@ -0,0 +1,47 @@
+open Crowbar
+
+module S = Serializer
+
+type any_ty = Any : 'a S.ty -> any_ty
+
+let ty_gen =
+  with_printer (fun ppf (Any t)-> S.pp_ty ppf t) @@
+  fix (fun ty_gen -> choose [
+    const (Any S.Int);
+    const (Any S.Bool);
+    map [ty_gen; ty_gen] (fun (Any ta) (Any tb) ->
+      Any (S.Prod (ta, tb)));
+    map [ty_gen] (fun (Any t) -> Any (List t));
+  ])
+
+let prod_gen ga gb = map [ga; gb] (fun va vb -> (va, vb))
+
+let rec gen_of_ty : type a . a S.ty -> a gen = function
+  | S.Int -> int
+  | S.Bool -> bool
+  | S.Prod (ta, tb) -> prod_gen (gen_of_ty ta) (gen_of_ty tb)
+  | S.List t -> list (gen_of_ty t)
+
+type pair = Pair : 'a S.ty * 'a -> pair
+
+(* The generator for the final value, [gen_of_ty t], depends on the
+   generated type representation, [t]. This dynamic dependency cannot
+   be expressed with [map], it requires [dynamic_bind]. *)
+let pair_gen : pair gen =
+  dynamic_bind ty_gen @@ fun (Any t) ->
+  map [gen_of_ty t] (fun v -> Pair (t, v))
+
+let rec printer_of_ty : type a . a S.ty -> a printer = function
+  | S.Int -> pp_int
+  | S.Bool -> pp_bool
+  | S.Prod (ta, tb) -> (fun ppf (a, b) ->
+      pp ppf "(%a, %a)" (printer_of_ty ta) a (printer_of_ty tb) b)
+  | S.List t -> pp_list (printer_of_ty t)
+
+let check_pair (Pair (t, v)) =
+  let data = S.serialize t v in
+  match S.deserialize t data with
+  | exception _ -> fail "incorrect deserialization"
+  | v' -> check_eq ~pp:(printer_of_ty t) v v'
+
+let () = add_test ~name:"pairs" [pair_gen] check_pair