Merge pull request #8 from francoisthire/francois@some-fixes

Some miscellaneous fixes

.ocamlformat

@@ -1,2 +1,2 @@
-version=0.26.1
-profile=ocamlformat
+version=0.26.2
+profile=ocamlformat

example/1-simple/dune

@@ -1,3 +1,3 @@
 (library
-  (name simple)
-  (libraries tezt-bam))
+ (name simple)
+ (libraries tezt-bam))

example/2-simple-failure/dune

@@ -1,3 +1,3 @@
 (library
-  (name simple_failure)
-  (libraries tezt-bam))
+ (name simple_failure)
+ (libraries tezt-bam))

example/3-writing-generators/dune

@@ -1,3 +1,3 @@
 (library
-  (name writing_generators)
-  (libraries tezt-bam))
+ (name writing_generators)
+ (libraries tezt-bam))

example/6-debugging/dune

@@ -1,3 +1,3 @@
 (library
-  (name debugging)
-  (libraries tezt-bam))
+ (name debugging)
+ (libraries tezt-bam))

lib_bam/dune

@@ -4,4 +4,4 @@
  (libraries pringo zarith))
 
 (documentation
- (package bam))
+ (package bam))

lib_bam/gen.ml

@@ -72,7 +72,7 @@ let root (gen : 'a t) f rs =
      to the function [f] is indeed the one that would be produced with
      a bind. *)
   let rs_left, _ = Random.split rs in
-  Forest.first (gen rs_left) |> Tree.root |> Fun.flip f rs
+  Forest.uncons (gen rs_left) |> fst |> Tree.root |> Fun.flip f rs
 
 module Syntax = struct
   let ( let* ) x f = bind x f
@@ -120,8 +120,8 @@ let with_merge : 'a Merge.t -> 'a t -> 'a t =
  fun merge gen rs ->
   Forest.map_tree (fun tree -> Tree.with_merge ~merge tree) (gen rs)
 
-let z_range : ?origin:Z.t -> min:Z.t -> max:Z.t -> unit -> Z.t t =
- fun ?origin ~min ~max () rs ->
+let z_range : ?root:Z.t -> ?origin:Z.t -> min:Z.t -> max:Z.t -> unit -> Z.t t =
+ fun ?root ?origin ~min ~max () rs ->
   let open Z.Compare in
   if max <= min then Forest.return min
   else
@@ -132,28 +132,35 @@ let z_range : ?origin:Z.t -> min:Z.t -> max:Z.t -> unit -> Z.t t =
         ~fill:(fun bytes pos len -> PRNG.Splitmix.State.bytes rs bytes pos len)
         upper_bound
     in
-    let initial = Z.add min start in
+    let initial = match root with None -> Z.add min start | Some v -> v in
     let origin =
       Option.value origin
         ~default:(if min <= Z.zero && Z.zero <= max then Z.zero else min)
     in
     Tree.binary_search ~initial ~origin () |> Forest.lift
 
 let float_range :
-       ?exhaustive_search_digits:int
+       ?root:float
+    -> ?exhaustive_search_digits:int
     -> ?precision_digits:int
     -> ?origin:float
     -> min:float
     -> max:float
     -> unit
     -> float t =
- fun ?exhaustive_search_digits ?precision_digits ?origin ~min ~max () rs ->
+ fun ?root ?exhaustive_search_digits ?precision_digits ?origin ~min ~max () rs ->
   let origin =
     Option.value origin ~default:(if min <= 0. && 0. <= max then 0. else min)
   in
   if min >= max then return min rs
   else if max -. min <= 1. then
-    let initial, _ = Random.float (max -. min) rs in
+    let initial =
+      match root with
+      | None ->
+          Random.float (max -. min) rs |> fst
+      | Some float ->
+          float
+    in
     Tree.fractional_search ?exhaustive_search_digits ?precision_digits ~initial
       ~origin ()
     |> Forest.lift
@@ -171,7 +178,9 @@ let float_range :
         ~max:(Z.sub (Z.of_float maxi) shift)
         () rs
     in
-    let fractional = Random.float 1. rs' |> fst in
+    let fractional =
+      match root with None -> Random.float 1. rs' |> fst | Some float -> float
+    in
     let ff, fi = Float.modf fractional in
     let fractional_forest =
       Tree.fractional_search ?exhaustive_search_digits ?precision_digits
@@ -185,6 +194,10 @@ let float_range :
             Float.max min (value +. fractional +. min) |> Float.min max )
           fractional_forest )
 
+let of_seq roots =
+  let roots = Seq.to_dispenser roots in
+  fun rs -> return (roots ()) rs
+
 let crunch i (gen : 'a t) : 'a t =
  fun rs ->
   let forest = gen rs in
@@ -205,4 +218,5 @@ let run ?(on_failure = failwith) gen state =
      [on_failure] argument to [Gen.run]."
   in
   let forest = gen state in
-  if Forest.is_singleton forest then Forest.first forest else on_failure message
+  let first, remaining_trees = forest |> Forest.uncons in
+  if Seq.is_empty remaining_trees then first else on_failure message

lib_bam/gen.mli

@@ -36,29 +36,36 @@ val make : 'a -> ('a -> 'a Seq.t) -> 'a t
     build an infinite tree if the function [f] never returns an empty
     sequence. *)
 
-val z_range : ?origin:Z.t -> min:Z.t -> max:Z.t -> unit -> Z.t t
-(** [range ?shrink min max] returns a generator producing a uniform
-    value between [min] (inclusive) and [max] (exclusive). It shrinks
-    towards the value [origin] using a binary search (see
+val z_range : ?root:Z.t -> ?origin:Z.t -> min:Z.t -> max:Z.t -> unit -> Z.t t
+(** [z_range ?root ?shrink min max] returns a generator producing a
+    uniform value between [min] (inclusive) and [max] (exclusive). It
+    shrinks towards the value [origin] using a binary search (see
     [Tree.binary_search]. By default [origin] is [0] if [0] is in the
-    interval [min;max]. Otherwise [origin] is set to [min].     
+    interval [min;max]. Otherwise [origin] is set to [min].
+
+    If [root] is specified, the value returned is [root] with the same
+    shrinking tree as if the random generator had produce this value.
 *)
 
 val float_range :
-     ?exhaustive_search_digits:int
+     ?root:float
+  -> ?exhaustive_search_digits:int
   -> ?precision_digits:int
   -> ?origin:float
   -> min:float
   -> max:float
   -> unit
   -> float t
-(** [range ?shrink min max] returns a generator producing a value
-    between [min] (inclusive) and [max] (exclusive). It shrinks
-    towards the value [min] using a binary search (see
+(** [float_range ?root ?shrink min max] returns a generator producing
+    a value between [min] (inclusive) and [max] (exclusive). It
+    shrinks towards the value [min] using a binary search (see
     [Tree.binary_search]. The generator is not uniform. In particular
     when the fractional part of [min] and [max] are getting closer to
     [0.5], the generator may tend to create more values equal to [min]
     or [max]. If the fractional part is [0.], it should be uniform.
+
+    If [root] is specified, the value returned is [root] with the same
+    shrinking tree as if the random generator had produce this value.
 *)
 
 val run : ?on_failure:(string -> 'a Tree.t) -> 'a t -> Random.t -> 'a Tree.t
@@ -90,6 +97,10 @@ val root : 'a t -> ('a -> 'b t) -> 'b t
     As a result, this new generator forgets completely the other
     values of [gen]. It acts as if it contains only the root. *)
 
+val of_seq : 'a Seq.t -> 'a option t
+(** [of_seq seq] returns a generator that will produce successively
+    the values of the sequence until the sequence is empty. *)
+
 module Syntax : sig
   val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
   (** Alias for {!bind}. *)

lib_bam/std.ml

@@ -36,10 +36,14 @@ let root = Gen.root
 
 let crunch = Gen.crunch
 
-let int ?(shrinker = Shrinker.Default) ?(min = 0) ?(max = Int.max_int) () =
+let of_seq = Gen.of_seq
+
+let int ?root ?(shrinker = Shrinker.Default) ?(min = 0) ?(max = Int.max_int) ()
+    =
   let range ?origin ~min ~max () =
     let origin = Option.map Z.of_int origin in
-    Gen.z_range ?origin ~min:(Z.of_int min) ~max:(Z.of_int max) ()
+    let root = Option.map Z.of_int root in
+    Gen.z_range ?root ?origin ~min:(Z.of_int min) ~max:(Z.of_int max) ()
     |> Gen.map Z.to_int
   in
   match shrinker with
@@ -51,11 +55,12 @@ let int ?(shrinker = Shrinker.Default) ?(min = 0) ?(max = Int.max_int) () =
   | Int n ->
       range ~origin:n ~min ~max ()
 
-let int32 ?(shrinker = Shrinker.Default) ?(min = Int32.zero)
+let int32 ?root ?(shrinker = Shrinker.Default) ?(min = Int32.zero)
     ?(max = Int32.max_int) () =
   let range ?origin ~min ~max () =
     let origin = Option.map Z.of_int32 origin in
-    Gen.z_range ?origin ~min:(Z.of_int32 min) ~max:(Z.of_int32 max) ()
+    let root = Option.map Z.of_int32 root in
+    Gen.z_range ?root ?origin ~min:(Z.of_int32 min) ~max:(Z.of_int32 max) ()
     |> Gen.map Z.to_int32
   in
   match shrinker with
@@ -67,11 +72,12 @@ let int32 ?(shrinker = Shrinker.Default) ?(min = Int32.zero)
   | Int32 n ->
       range ~origin:n ~min ~max ()
 
-let int64 ?(shrinker = Shrinker.Default) ?(min = Int64.zero)
+let int64 ?root ?(shrinker = Shrinker.Default) ?(min = Int64.zero)
     ?(max = Int64.max_int) () =
   let range ?origin ~min ~max () =
     let origin = Option.map Z.of_int64 origin in
-    Gen.z_range ?origin ~min:(Z.of_int64 min) ~max:(Z.of_int64 max) ()
+    let root = Option.map Z.of_int64 root in
+    Gen.z_range ?root ?origin ~min:(Z.of_int64 min) ~max:(Z.of_int64 max) ()
     |> Gen.map Z.to_int64
   in
   match shrinker with
@@ -83,19 +89,19 @@ let int64 ?(shrinker = Shrinker.Default) ?(min = Int64.zero)
   | Int64 n ->
       range ~origin:n ~min ~max ()
 
-let float ?(shrinker = Shrinker.Default) ?(min = 0.) ?(max = Float.max_float) ()
-    =
+let float ?root ?(shrinker = Shrinker.Default) ?(min = 0.)
+    ?(max = Float.max_float) () =
   match shrinker with
   | Manual shrinker ->
-      let*! root = Gen.float_range ~min ~max () in
+      let*! root = Gen.float_range ?root ~min ~max () in
       Gen.make root shrinker
   | Default ->
-      Gen.float_range ~min ~max ()
+      Gen.float_range ?root ~min ~max ()
   | Float f ->
-      Gen.float_range ~origin:f ~min ~max ()
+      Gen.float_range ?root ~origin:f ~min ~max ()
   | Float_precision {exhaustive_search_digits; precision_digits; target} ->
-      Gen.float_range ~exhaustive_search_digits ~precision_digits ~origin:target
-        ~min ~max ()
+      Gen.float_range ?root ~exhaustive_search_digits ~precision_digits
+        ~origin:target ~min ~max ()
 
 let pair ?(shrinker = Shrinker.Default) left right =
   match shrinker with
@@ -128,19 +134,20 @@ let bool ?(shrinker = Shrinker.Default) () =
       let* x = int ~min:0 ~max:2 () in
       if x = 0 = b then return true else return false
 
-let char ?(shrinker = Shrinker.Default) ?(printable = true) () =
+let char ?root ?(shrinker = Shrinker.Default) ?(printable = true) () =
   let base = if printable then Char.code 'a' else 0 in
   let max = if printable then 26 else 256 in
+  let root = root |> Option.map (fun root -> Char.code root - Char.code 'a') in
   match shrinker with
   | Manual shrinker ->
-      let*! root = int ~min:0 ~max () in
+      let*! root = int ?root ~min:0 ~max () in
       Gen.make (Char.chr (base + root)) shrinker
   | Default ->
-      let* offset = int ~min:0 ~max () in
+      let* offset = int ?root ~min:0 ~max () in
       return (Char.chr (base + offset))
   | Char c ->
       let origin = Char.code c - base in
-      let* offset = int ~shrinker:(Int origin) ~min:0 ~max () in
+      let* offset = int ?root ~shrinker:(Int origin) ~min:0 ~max () in
       return (Char.chr (base + offset))
 
 module Gen_list = struct

lib_bam/std.mli

@@ -119,32 +119,53 @@ val crunch : int -> 'a t -> 'a t
     shrinking. It increases the number of values that will be used
     during the shrinking. More details in {!page-shrinking}. *)
 
-val int : ?shrinker:int Shrinker.t -> ?min:int -> ?max:int -> unit -> int t
-(** [int ?shrinker ?(min=0) ?(max=Int.max_int) ()] is a generator for
+val of_seq : 'a Seq.t -> 'a option t
+(** [of_seq seq] returns a generator that will produce successively
+    the values of the sequence until the sequence is empty. Those
+    values are intended to be used as the root argument of other generators. *)
+
+val int :
+  ?root:int -> ?shrinker:int Shrinker.t -> ?min:int -> ?max:int -> unit -> int t
+(** [int ?root ?shrinker ?(min=0) ?(max=Int.max_int) ()] is a generator for
     integers. Bounds are inclusive.
 
     Default strategy is {!constructor:Shrinker.Int}[0].
  *)
 
 val int32 :
-  ?shrinker:int32 Shrinker.t -> ?min:int32 -> ?max:int32 -> unit -> int32 t
-(** [int ?shrinker ?(min=0) ?(max=Int.max_int) ()] is a generator for
+     ?root:int32
+  -> ?shrinker:int32 Shrinker.t
+  -> ?min:int32
+  -> ?max:int32
+  -> unit
+  -> int32 t
+(** [int ?root ?shrinker ?(min=0) ?(max=Int.max_int) ()] is a generator for
     integers. Bounds are inclusive.
 
     Default strategy is {!constructor:Shrinker.Int}[0].
  *)
 
 val int64 :
-  ?shrinker:int64 Shrinker.t -> ?min:int64 -> ?max:int64 -> unit -> int64 t
-(** [int ?shrinker ?(min=0) ?(max=Int.max_int) ()] is a generator for
+     ?root:int64
+  -> ?shrinker:int64 Shrinker.t
+  -> ?min:int64
+  -> ?max:int64
+  -> unit
+  -> int64 t
+(** [int ?root ?shrinker ?(min=0) ?(max=Int.max_int) ()] is a generator for
     integers. Bounds are inclusive.
 
     Default strategy is {!constructor:Shrinker.Int}[0].
  *)
 
 val float :
-  ?shrinker:float Shrinker.t -> ?min:float -> ?max:float -> unit -> float t
-(** [float ?shrinker ?(min=0.) ?(max=Float.max_float) ()] generates
+     ?root:float
+  -> ?shrinker:float Shrinker.t
+  -> ?min:float
+  -> ?max:float
+  -> unit
+  -> float t
+(** [float ?root ?shrinker ?(min=0.) ?(max=Float.max_float) ()] generates
     integers. Bounds are inclusive.
 
     Default strategy is {!constructor:Shrinker.Float}[0.].
@@ -163,8 +184,9 @@ val bool : ?shrinker:bool Shrinker.t -> unit -> bool t
     Default strategy is {!constructor:Shrinker.Bool}[false].
  *)
 
-val char : ?shrinker:Char.t Shrinker.t -> ?printable:bool -> unit -> char t
-(** [char ?shrinker ?(printable=true) ()] generates a char.
+val char :
+  ?root:char -> ?shrinker:Char.t Shrinker.t -> ?printable:bool -> unit -> char t
+(** [char ?root ?shrinker ?(printable=true) ()] generates a char.
 
     Default strategy is {!constructor:Shrinker.Char}['a].    
  *)

lib_bam/tree.ml

@@ -123,20 +123,13 @@ module Forest = struct
 
   let map f = Seq.map (map f)
 
-  let first seq =
+  let uncons seq =
     match Seq.uncons seq with
     | None ->
         (* This invariant is ensured by the module itself. *)
         assert false
-    | Some (x, _) ->
-        x
-
-  let is_singleton seq =
-    match Seq.uncons seq with
-    | None ->
-        false
-    | Some (_x, seq) ->
-        Seq.is_empty seq
+    | Some (x, seq) ->
+        (x, seq)
 
   let crunch i seq = Seq.map (crunch i) seq