Merge pull request #308 from jmid/add-result-combinators

Add missing `result` combinators

CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## NEXT RELEASE
 
+- Add `result` combinators to `QCheck`, `QCheck.{Gen,Print,Shrink,Observable}`,
+  and `QCheck2.{Gen,Print,Observable}`.
 - Add missing combinators `QCheck{,2}.Print.int{32,64}`, `QCheck.Gen.int{32,64}`,
   `QCheck{,2}.Observable.int{32,64}`, and deprecate `QCheck.Gen.{ui32,ui64}`
 - Document `dune` usage in README

src/core/QCheck.ml

@@ -195,6 +195,12 @@ module Gen = struct
 
   let opt = option
 
+  let result ?(ratio = 0.75) vg eg st =
+    let p = RS.float st 1. in
+    if p < (1.0 -. ratio)
+    then Error (eg st)
+    else Ok (vg st)
+
   (* Uniform random int generator *)
   let pint =
     if Sys.word_size = 32 then
@@ -492,6 +498,10 @@ module Print = struct
     | None -> "None"
     | Some x -> "Some (" ^ f x ^ ")"
 
+  let result vp ep = function
+    | Error e -> "Error (" ^ ep e ^ ")"
+    | Ok v -> "Ok (" ^ vp v ^ ")"
+
   let pair a b (x,y) = Printf.sprintf "(%s, %s)" (a x) (b y)
   let triple a b c (x,y,z) = Printf.sprintf "(%s, %s, %s)" (a x) (b y) (c z)
   let quad a b c d (x,y,z,w) =
@@ -740,6 +750,10 @@ module Shrink = struct
     | None -> Iter.empty
     | Some x -> Iter.(return None <+> map (fun y->Some y) (s x))
 
+  let result vs es x = match x with
+    | Error e -> Iter.map (fun e -> Error e) (es e)
+    | Ok v -> Iter.map (fun v -> Ok v) (vs v)
+
   let array ?shrink a yield =
     let n = Array.length a in
     let chunk_size = ref n in
@@ -975,6 +989,9 @@ module Observable = struct
     let opt f = function
       | None -> 42
       | Some x -> combine 43 (f x)
+    let result vh eh = function
+      | Error e -> combine 17 (eh e)
+      | Ok v -> combine 19 (vh v)
     let list f l = List.fold_left (combine_f f) 0x42 l
     let array f l = Array.fold_left (combine_f f) 0x42 l
     let pair f g (x,y) = combine (f x) (g y)
@@ -1013,6 +1030,8 @@ module Observable = struct
       | None, Some _ -> false
       | Some x, Some y -> f x y
 
+    let result ok error r1 r2 = Result.equal ~ok ~error r1 r2
+
     let pair f g (x1,y1)(x2,y2) = f x1 x2 && g y1 y2
   end
 
@@ -1030,6 +1049,10 @@ module Observable = struct
     make ~hash:(H.opt p.hash) ~eq:(Eq.option p.eq)
       (Print.option p.print)
 
+  let result op rp =
+    make ~hash:(H.result op.hash rp.hash) ~eq:(Eq.result op.eq rp.eq)
+      (Print.result op.print rp.print)
+
   let array p =
     make ~hash:(H.array p.hash) ~eq:(Eq.array p.eq) (Print.array p.print)
   let list p =
@@ -1342,6 +1365,21 @@ let option ?ratio a =
     ?print:(_opt_map ~f:Print.option a.print)
     g
 
+let result ?ratio ok err =
+  let g = Gen.result ?ratio ok.gen err.gen
+  and shrink = _opt_map_2 ok.shrink err.shrink ~f:Shrink.result
+  and small = match ok.small, err.small with
+    | None, None -> (function Ok _ -> 0 | Error _ -> 1)
+    | None, Some es -> (function Ok _ -> 0 | Error e -> es e)
+    | Some os, None -> (function Ok o -> os o | Error _ -> 1)
+    | Some os, Some es -> (function Ok o -> os o | Error e -> es e)
+  in
+  make
+    ~small
+    ?shrink:shrink
+    ?print:(_opt_map_2 ~f:Print.result ok.print err.print)
+    g
+
 let map ?rev f a =
   make
     ?print:(_opt_map_2 rev a.print ~f:(fun r p x -> p (r x)))

src/core/QCheck.mli

@@ -387,6 +387,14 @@ module Gen : sig
       @since 0.18 ([?ratio] parameter)
   *)
 
+  val result : ?ratio:float -> 'a t -> 'e t -> ('a, 'e) result t
+  (** A result generator, with optional ratio.
+      @param ratio a float between [0.] and [1.] indicating the probability of a sample to be [Ok _]
+      rather than [Error _].
+
+      @since NEXT_RELEASE
+  *)
+
   val char : char t
   (** Generates characters upto character code 255. *)
 
@@ -675,6 +683,10 @@ module Print : sig
 
   val option : 'a t -> 'a option t (** Option printer. *)
 
+  val result : 'a t -> 'e t -> ('a, 'e) result t
+  (** Result printer.
+      @since NEXT_RELEASE *)
+
   val pair : 'a t -> 'b t -> ('a*'b) t
   (** Pair printer. Expects printers for each component. *)
 
@@ -818,6 +830,9 @@ module Shrink : sig
 
   val option : 'a t -> 'a option t
 
+  val result : 'a t -> 'e t -> ('a, 'e) result t
+  (** @since NEXT_RELEASE *)
+
   val bytes : ?shrink:(char t) -> bytes t
   (** @since 0.20 *)
 
@@ -1189,6 +1204,14 @@ val array_of_size : int Gen.t -> 'a arbitrary -> 'a array arbitrary
 val option : ?ratio:float -> 'a arbitrary -> 'a option arbitrary
 (** Choose between returning Some random value with optional ratio, or None. *)
 
+val result : ?ratio:float -> 'a arbitrary -> 'e arbitrary -> ('a, 'e) result arbitrary
+(** [result ~ratio okgen errgen] generates [Ok v] with [v] coming from [okgen]
+    or [Error e] with [e] coming from [errgen], depending on [ratio]. The latter
+    is a float between [0.] and [1.] indicating the probability of a sample to
+    be [Ok _] rather than [Error _].
+
+    @since NEXT_RELEASE *)
+
 
 (** {2 Tuples of arbitrary generators}
 
@@ -1663,6 +1686,7 @@ module Observable : sig
   val map : ('a -> 'b) -> 'b t -> 'a t
 
   val option : 'a t -> 'a option t
+  val result : 'a t -> 'e t -> ('a, 'e) result t (** @since NEXT_RELEASE *)
   val list : 'a t -> 'a list t
   val array : 'a t -> 'a array t
 

src/core/QCheck2.ml

@@ -387,6 +387,12 @@ module Gen = struct
   (** [opt] is an alias of {!val:option} for backward compatibility. *)
   let opt = option
 
+  let result ?(ratio : float = 0.75) (ok_gen : 'a t) (err_gen : 'e t) : ('a, 'e) result t = fun st ->
+    let p = RS.float st 1. in
+    if p < (1. -. ratio)
+    then Tree.map (fun e -> Error e) (err_gen st)
+    else Tree.map (fun o -> Ok o) (ok_gen st)
+
   (* Uniform positive random int generator.
 
      We can't use {!RS.int} because the upper bound must be positive and is excluded,
@@ -809,6 +815,10 @@ module Print = struct
     | None -> "None"
     | Some x -> "Some (" ^ f x ^ ")"
 
+  let result vp ep = function
+    | Error e -> "Error (" ^ ep e ^ ")"
+    | Ok v -> "Ok (" ^ vp v ^ ")"
+
   let pair a b (x,y) = Printf.sprintf "(%s, %s)" (a x) (b y)
 
   let triple a b c (x,y,z) = Printf.sprintf "(%s, %s, %s)" (a x) (b y) (c z)
@@ -995,6 +1005,11 @@ module Observable = struct
     let option f = function
       | None -> 42
       | Some x -> combine 43 (f x)
+
+    let result vh eh = function
+      | Error e -> combine 17 (eh e)
+      | Ok v -> combine 19 (vh v)
+
     let list f l = List.fold_left (combine_f f) 0x42 l
 
     let array f l = Array.fold_left (combine_f f) 0x42 l
@@ -1041,6 +1056,8 @@ module Observable = struct
       | None, Some _ -> false
       | Some x, Some y -> f x y
 
+    let result ok error r1 r2 = Result.equal ~ok ~error r1 r2
+
     let pair f g (x1,y1)(x2,y2) = f x1 x2 && g y1 y2
   end
 
@@ -1064,6 +1081,10 @@ module Observable = struct
     make ~hash:(H.option p.hash) ~eq:(Eq.option p.eq)
       (Print.option p.print)
 
+  let result op rp =
+    make ~hash:(H.result op.hash rp.hash) ~eq:(Eq.result op.eq rp.eq)
+      (Print.result op.print rp.print)
+
   let array p =
     make ~hash:(H.array p.hash) ~eq:(Eq.array p.eq) (Print.array p.print)
 

src/core/QCheck2.mli

@@ -702,6 +702,16 @@ module Gen : sig
   val opt : ?ratio:float -> 'a t -> 'a option t
   (** [opt] is an alias of {!val:option} for backward compatibility. *)
 
+  val result : ?ratio:float -> 'a t -> 'e t -> ('a, 'e) result t
+  (** [result ~ratio okgen errgen] generates [Ok v] with [v] coming from [okgen]
+      or [Error e] with [e] coming from [errgen], depending on [ratio].
+
+      @param ratio a float between [0.] and [1.] indicating the probability of a sample to
+      be [Ok _] rather than [Error _].
+
+      @since NEXT_RELEASE *)
+
+
   (** {3 Combining generators} *)
 
   val pair : 'a t -> 'b t -> ('a * 'b) t
@@ -1140,6 +1150,12 @@ module Print : sig
   val option : 'a t -> 'a option t
   (** [option p] is a printer of ['a option], using [p] if it is a [Some]. *)
 
+  val result : 'a t -> 'e t -> ('a, 'e) result t
+  (** [result okp errp] is a printer of [('a,'e) result], using [okp] for printing [Ok _]
+      and [errp] for printing [Error _].
+
+      @since NEXT_RELEASE *)
+
   val pair : 'a t -> 'b t -> ('a*'b) t
   (** [pair p1 p2] is a printer of pair. *)
 
@@ -1379,6 +1395,11 @@ module Observable : sig
   (** [option o] wraps the observable [o] of ['a] into an observable of
       ['a option]. *)
 
+  val result : 'a t -> 'e t -> ('a, 'e) result t
+  (** [result ok_o err_o] creates an [('a, 'e) result] observable out of
+      two observables [ok_o] and [err_o].
+      @since NEXT_RELEASE *)
+
   val list : 'a t -> 'a list t
   (** [list o] wraps the observable [o] of ['a] into an observable of
       ['a list]. *)