Skip to content
Browse files

Require low and high bounded value defaults

Also require a conversion function for bounding_of_ord* for some extra
flexibility.  This cleans up saturate_of_ord.

map and map2 are now automatically derived in the BatBounded.Make functor.

Add an experimental MakeNumeric functor which adds a few infix operators
to the generated module.

Fix test_bounded.ml by bringing it up to date with BatBounded changes.
  • Loading branch information...
1 parent 8870196 commit 5bd449c3def45728607dba8c88d74b21989742a2 @hcarty hcarty committed Oct 8, 2012
Showing with 179 additions and 117 deletions.
  1. +91 −60 src/batBounded.ml
  2. +37 −23 src/batBounded.mli
  3. +51 −34 testsuite/test_bounded.ml
View
151 src/batBounded.ml
@@ -1,8 +1,5 @@
module O = BatOrd
-let ( |? ) = BatOption.( |? )
-let ( |- ) f g x = g (f x)
-
exception Invalid_bounds
type 'a bound_t = [ `o of 'a | `c of 'a | `u]
@@ -11,8 +8,10 @@ type ('a, 'b) bounding_f = bounds:('a bound_t * 'a bound_t) -> 'a -> 'b
let ret_some x = Some x
let ret_none _ = None
+let const a _ = a
+external identity : 'a -> 'a = "%identity"
-let bounding_of_ord ?default_low ?default_high ord =
+let bounding_of_ord ~default_low ~default_high conv ord =
fun ~(bounds : 'a bound_t * 'a bound_t) ->
match bounds with
| `c l, `c u -> begin
@@ -23,23 +22,23 @@ let bounding_of_ord ?default_low ?default_high ord =
| _, O.Gt -> default_high
| O.Eq, _
| _, O.Eq
- | O.Gt, _ -> Some x
+ | O.Gt, _ -> conv x
end
| `u, `c u -> begin
fun x ->
match ord x u with
| O.Gt -> default_high
| O.Eq
- | O.Lt -> Some x
+ | O.Lt -> conv x
end
| `c l, `u -> begin
fun x ->
match ord x l with
| O.Lt -> default_low
| O.Gt
- | O.Eq -> Some x
+ | O.Eq -> conv x
end
- | `u, `u -> ret_some
+ | `u, `u -> conv
| `o l, `o u -> begin
if ord l u = O.Gt then raise Invalid_bounds;
fun x ->
@@ -48,21 +47,21 @@ let bounding_of_ord ?default_low ?default_high ord =
| O.Eq, _ -> default_low
| _, O.Gt
| _, O.Eq -> default_high
- | O.Gt, _ -> Some x
+ | O.Gt, _ -> conv x
end
| `u, `o u -> begin
fun x ->
match ord x u with
| O.Gt
| O.Eq -> default_high
- | O.Lt -> Some x
+ | O.Lt -> conv x
end
| `o l, `u -> begin
fun x ->
match ord x l with
| O.Lt
| O.Eq -> default_low
- | O.Gt -> Some x
+ | O.Gt -> conv x
end
| `c l, `o u -> begin
if ord l u = O.Gt then raise Invalid_bounds;
@@ -72,7 +71,7 @@ let bounding_of_ord ?default_low ?default_high ord =
| _, O.Gt
| _, O.Eq -> default_high
| O.Eq, _
- | O.Gt, _ -> Some x
+ | O.Gt, _ -> conv x
end
| `o l, `c u -> begin
if ord l u = O.Gt then raise Invalid_bounds;
@@ -82,26 +81,24 @@ let bounding_of_ord ?default_low ?default_high ord =
| O.Eq, _ -> default_low
| _, O.Gt -> default_high
| _, O.Eq
- | O.Gt, _ -> Some x
+ | O.Gt, _ -> conv x
end
(*$T bounding_of_ord
- bounding_of_ord BatInt.ord ~bounds:(`u, `u) 0 = Some 0
- bounding_of_ord BatInt.ord ~bounds:(`c 0, `u) 0 = Some 0
- bounding_of_ord BatInt.ord ~bounds:(`o 0, `u) 0 = None
- bounding_of_ord BatInt.ord ~bounds:(`u, `c 0) 0 = Some 0
- bounding_of_ord BatInt.ord ~bounds:(`u, `o 0) 0 = None
+ bounding_of_ord ~default_low:None ~default_high:None (fun x -> Some x) BatInt.ord ~bounds:(`u, `u) 0 = Some 0
+ bounding_of_ord ~default_low:None ~default_high:None (fun x -> Some x) BatInt.ord ~bounds:(`c 0, `u) 0 = Some 0
+ bounding_of_ord ~default_low:None ~default_high:None (fun x -> Some x) BatInt.ord ~bounds:(`o 0, `u) 0 = None
+ bounding_of_ord ~default_low:None ~default_high:None (fun x -> Some x) BatInt.ord ~bounds:(`u, `c 0) 0 = Some 0
+ bounding_of_ord ~default_low:None ~default_high:None (fun x -> Some x) BatInt.ord ~bounds:(`u, `o 0) 0 = None
- bounding_of_ord ~default_low:~-10 ~default_high:10 BatInt.ord ~bounds:(`u, `u) 0 = Some 0
- bounding_of_ord ~default_low:~-10 ~default_high:10 BatInt.ord ~bounds:(`c 0, `u) 0 = Some 0
- bounding_of_ord ~default_low:~-10 ~default_high:10 BatInt.ord ~bounds:(`o 0, `u) 0 = Some ~-10
- bounding_of_ord ~default_low:~-10 ~default_high:10 BatInt.ord ~bounds:(`u, `c 0) 0 = Some 0
- bounding_of_ord ~default_low:~-10 ~default_high:10 BatInt.ord ~bounds:(`u, `o 0) 0 = Some 10
+ bounding_of_ord ~default_low:(Some ~-10) ~default_high:(Some 10) (fun x -> Some x) BatInt.ord ~bounds:(`u, `u) 0 = Some 0
+ bounding_of_ord ~default_low:(Some ~-10) ~default_high:(Some 10) (fun x -> Some x) BatInt.ord ~bounds:(`c 0, `u) 0 = Some 0
+ bounding_of_ord ~default_low:(Some ~-10) ~default_high:(Some 10) (fun x -> Some x) BatInt.ord ~bounds:(`o 0, `u) 0 = Some ~-10
+ bounding_of_ord ~default_low:(Some ~-10) ~default_high:(Some 10) (fun x -> Some x) BatInt.ord ~bounds:(`u, `c 0) 0 = Some 0
+ bounding_of_ord ~default_low:(Some ~-10) ~default_high:(Some 10) (fun x -> Some x) BatInt.ord ~bounds:(`u, `o 0) 0 = Some 10
*)
-let bounding_of_ord_chain ?low ?high ord =
- let low = low |? ret_none in
- let high = high |? ret_none in
+let bounding_of_ord_chain ~low ~high conv ord =
fun ~(bounds : 'a bound_t * 'a bound_t) ->
match bounds with
(* Closed bounds (inclusive) *)
@@ -113,21 +110,21 @@ let bounding_of_ord_chain ?low ?high ord =
| _, O.Gt -> high x
| O.Eq, _
| _, O.Eq
- | O.Gt, _ -> Some x
+ | O.Gt, _ -> conv x
end
| `u, `c u -> begin
fun x ->
match ord x u with
| O.Gt -> high x
| O.Eq
- | O.Lt -> Some x
+ | O.Lt -> conv x
end
| `c l, `u -> begin
fun x ->
match ord x l with
| O.Lt -> low x
| O.Gt
- | O.Eq -> Some x
+ | O.Eq -> conv x
end
(* Open bounds (exclusive) *)
| `o l, `o u -> begin
@@ -138,21 +135,21 @@ let bounding_of_ord_chain ?low ?high ord =
| O.Eq, _ -> low x
| _, O.Gt
| _, O.Eq -> high x
- | O.Gt, _ -> Some x
+ | O.Gt, _ -> conv x
end
| `u, `o u -> begin
fun x ->
match ord x u with
| O.Gt
| O.Eq -> high x
- | O.Lt -> Some x
+ | O.Lt -> conv x
end
| `o l, `u -> begin
fun x ->
match ord x l with
| O.Lt
| O.Eq -> low x
- | O.Gt -> Some x
+ | O.Gt -> conv x
end
(* Mixed open and closed bounds *)
| `c l, `o u -> begin
@@ -163,7 +160,7 @@ let bounding_of_ord_chain ?low ?high ord =
| _, O.Gt
| _, O.Eq -> high x
| O.Eq, _
- | O.Gt, _ -> Some x
+ | O.Gt, _ -> conv x
end
| `o l, `c u -> begin
if ord l u = O.Gt then raise Invalid_bounds;
@@ -173,22 +170,22 @@ let bounding_of_ord_chain ?low ?high ord =
| O.Eq, _ -> low x
| _, O.Gt -> high x
| _, O.Eq
- | O.Gt, _ -> Some x
+ | O.Gt, _ -> conv x
end
- | `u, `u -> ret_some
+ | `u, `u -> conv
(*$T bounding_of_ord_chain as f
- f BatInt.ord ~bounds:(`u, `u) 0 = Some 0
- f BatInt.ord ~bounds:(`c 0, `u) 0 = Some 0
- f BatInt.ord ~bounds:(`o 0, `u) 0 = None
- f BatInt.ord ~bounds:(`u, `c 0) 0 = Some 0
- f BatInt.ord ~bounds:(`u, `o 0) 0 = None
+ f (fun x -> Some x) BatInt.ord ~low:(const None) ~high:(const None) ~bounds:(`u, `u) 0 = Some 0
+ f (fun x -> Some x) BatInt.ord ~low:(const None) ~high:(const None) ~bounds:(`c 0, `u) 0 = Some 0
+ f (fun x -> Some x) BatInt.ord ~low:(const None) ~high:(const None) ~bounds:(`o 0, `u) 0 = None
+ f (fun x -> Some x) BatInt.ord ~low:(const None) ~high:(const None) ~bounds:(`u, `c 0) 0 = Some 0
+ f (fun x -> Some x) BatInt.ord ~low:(const None) ~high:(const None) ~bounds:(`u, `o 0) 0 = None
- f ~low:(fun x -> Some ~-10) ~high:(fun x -> Some 10) BatInt.ord ~bounds:(`u, `u) 0 = Some 0
- f ~low:(fun x -> Some ~-10) ~high:(fun x -> Some 10) BatInt.ord ~bounds:(`c 0, `u) 0 = Some 0
- f ~low:(fun x -> Some ~-10) ~high:(fun x -> Some 10) BatInt.ord ~bounds:(`o 0, `u) 0 = Some ~-10
- f ~low:(fun x -> Some ~-10) ~high:(fun x -> Some 10) BatInt.ord ~bounds:(`u, `c 0) 0 = Some 0
- f ~low:(fun x -> Some ~-10) ~high:(fun x -> Some 10) BatInt.ord ~bounds:(`u, `o 0) 0 = Some 10
+ f (fun x -> Some x) ~low:(fun x -> Some ~-10) ~high:(fun x -> Some 10) BatInt.ord ~bounds:(`u, `u) 0 = Some 0
+ f (fun x -> Some x) ~low:(fun x -> Some ~-10) ~high:(fun x -> Some 10) BatInt.ord ~bounds:(`c 0, `u) 0 = Some 0
+ f (fun x -> Some x) ~low:(fun x -> Some ~-10) ~high:(fun x -> Some 10) BatInt.ord ~bounds:(`o 0, `u) 0 = Some ~-10
+ f (fun x -> Some x) ~low:(fun x -> Some ~-10) ~high:(fun x -> Some 10) BatInt.ord ~bounds:(`u, `c 0) 0 = Some 0
+ f (fun x -> Some x) ~low:(fun x -> Some ~-10) ~high:(fun x -> Some 10) BatInt.ord ~bounds:(`u, `o 0) 0 = Some 10
*)
let saturate_of_ord ~(bounds : 'a bound_t * 'a bound_t) ord =
@@ -197,22 +194,19 @@ let saturate_of_ord ~(bounds : 'a bound_t * 'a bound_t) ord =
| `c l, `c h
| `o l, `c h
| `c l, `o h ->
- bounding_of_ord ~default_low:l ~default_high:h ord ~bounds
- |- BatOption.get
+ bounding_of_ord_chain
+ ~low:(const l) ~high:(const h) identity ord ~bounds
| `u, `o h
| `u, `c h ->
- bounding_of_ord ~default_high:h ord ~bounds
- |- BatOption.get
+ bounding_of_ord_chain ~low:identity ~high:(const h) identity ord ~bounds
| `o l, `u
| `c l, `u ->
- bounding_of_ord ~default_low:l ord ~bounds
- |- BatOption.get
+ bounding_of_ord_chain ~low:(const l) ~high:identity identity ord ~bounds
| `u, `u ->
- bounding_of_ord ord ~bounds
- |- BatOption.get
+ bounding_of_ord_chain ~low:identity ~high:identity identity ord ~bounds
let opt_of_ord ~(bounds : 'a bound_t * 'a bound_t) ord =
- bounding_of_ord ord ~bounds
+ bounding_of_ord_chain ~low:ret_none ~high:ret_none ret_some ord ~bounds
module type BoundedType = sig
type base_t
@@ -221,8 +215,11 @@ module type BoundedType = sig
val bounded : (base_t, t) bounding_f
val base_of_t : t -> base_t option
val base_of_t_exn : t -> base_t
- val map : (base_t -> base_t) -> t -> t
- val map2 : (base_t -> base_t -> base_t) -> t -> t -> t
+end
+
+module type BoundedNumericType = sig
+ include BoundedType
+ module Infix : BatNumber.Infix with type bat__infix_t := base_t
end
module type S = sig
@@ -238,6 +235,19 @@ module type S = sig
val map2_exn : (base_u -> base_u -> base_u) -> t -> t -> t
end
+module type NumericSig = sig
+ include S
+
+ val ( + ) : t -> base_u -> t
+ val ( - ) : t -> base_u -> t
+ val ( * ) : t -> base_u -> t
+ val ( / ) : t -> base_u -> t
+ val ( +: ) : t -> t -> t
+ val ( -: ) : t -> t -> t
+ val ( *: ) : t -> t -> t
+ val ( /: ) : t -> t -> t
+end
+
module Make(M : BoundedType) : (
S with type base_u = M.base_t with type u = M.t with type t = private M.t
) = struct
@@ -247,12 +257,33 @@ module Make(M : BoundedType) : (
let make = bounded ~bounds
external extract : t -> u = "%identity"
let map f x =
- BatOption.map make (base_of_t (M.map f x))
+ BatOption.map make (BatOption.map f (base_of_t x))
let map2 f x y =
- BatOption.map make (base_of_t (M.map2 f x y))
+ match base_of_t x, base_of_t y with
+ | Some bx, Some by ->
+ Some (make (f bx by))
+ | None, Some _
+ | Some _, None
+ | None, None ->
+ None
let map_exn f x =
- make (base_of_t_exn (M.map f x))
+ make (f (base_of_t_exn x))
let map2_exn f x y =
- make (base_of_t_exn (M.map2 f x y))
+ let bx = base_of_t_exn x in
+ let by = base_of_t_exn y in
+ make (f bx by)
end
+module MakeNumeric(M : BoundedNumericType) = struct
+ include Make(M)
+ module I = M.Infix
+
+ let ( + ) a b = map_exn (I.( + ) b) a
+ let ( - ) a b = map_exn (I.( - ) b) a
+ let ( * ) a b = map_exn (I.( * ) b) a
+ let ( / ) a b = map_exn (I.( / ) b) a
+ let ( +: ) = map2_exn I.( + )
+ let ( -: ) = map2_exn I.( - )
+ let ( *: ) = map2_exn I.( * )
+ let ( /: ) = map2_exn I.( / )
+end
View
60 src/batBounded.mli
@@ -14,38 +14,36 @@ type ('a, 'b) bounding_f = bounds:('a bound_t * 'a bound_t) -> 'a -> 'b
(** The type of a bounding function with limits specified by [bounds] *)
val bounding_of_ord :
- ?default_low:'a ->
- ?default_high:'a ->
- ('a -> 'a -> BatOrd.order) -> ('a, 'a option) bounding_f
-(** [bounding_of_ord ?default_low ?default_high ord] will returning a bounding
- function using [ord] for value comparison and [default_low] and
- [default_high] for values which fall outside of the requested range. If
- no default out of range values are provided, the resulting function will
- return [None] for out of range inputs. *)
+ default_low:'b ->
+ default_high:'b ->
+ ('a -> 'b) ->
+ ('a -> 'a -> BatOrd.order) -> ('a, 'b) bounding_f
+(** [bounding_of_ord ~default_low ~default_high conv ord] will returning a
+ bounding function using [ord] for value comparison and [default_low] and
+ [default_high] for values which fall outside of the requested range.
+ [conv] is used to convert values which are in-range to the result type. *)
val bounding_of_ord_chain :
- ?low:('a -> 'a option) ->
- ?high:('a -> 'a option) ->
- ('a -> 'a -> BatOrd.order) -> ('a, 'a option) bounding_f
+ low:('a -> 'b) ->
+ high:('a -> 'b) ->
+ ('a -> 'b) ->
+ ('a -> 'a -> BatOrd.order) -> ('a, 'b) bounding_f
(** [bounding_oF_ord_chain ?low ?high ord] is like {!bounding_of_ord} except
that functions are used to handle out of range values rather than single
- default values.
-
- @param low defaults to returning [None] for out of range values
- @param high defaults to returning [None] for out of range values *)
+ default values. *)
val saturate_of_ord :
bounds:('a bound_t * 'a bound_t) ->
('a -> 'a -> BatOrd.order) -> 'a -> 'a
(** [saturate_of_ord ~bounds:(low, high) ord] will returning a bounding
- function using [ord] for value com parison and [low] and [high] for values
+ function using [ord] for value comparison and [low] and [high] for values
which fall outside of the requested range. *)
val opt_of_ord :
bounds:('a bound_t * 'a bound_t) ->
('a -> 'a -> BatOrd.order) -> 'a -> 'a option
(** [opt_of_ord ~bounds:(low, high) ord] will returning a bounding function
- using [ord] for value comparison a nd [None] for values which fall outside
+ using [ord] for value comparison and [None] for values which fall outside
of the requested range. *)
module type BoundedType = sig
@@ -68,13 +66,11 @@ module type BoundedType = sig
val base_of_t_exn : t -> base_t
(** [base_of_t_exn x] converts a value of type {!t} back to a {!base_t}. If
a conversion is not possible then an exception will be raised. *)
+end
- val map : (base_t -> base_t) -> t -> t
- (** [map f x] applies [f] to [x], converting the result back to type {!t} *)
-
- val map2 : (base_t -> base_t -> base_t) -> t -> t -> t
- (** [map f x y] applies [f] to [x] and [y], converting the result back to
- type {!t}. *)
+module type BoundedNumericType = sig
+ include BoundedType
+ module Infix : BatNumber.Infix with type bat__infix_t := base_t
end
module type S = sig
@@ -115,10 +111,28 @@ module type S = sig
can be converted back to type {!base_u}, otherwise raise an exception. *)
end
+module type NumericSig = sig
+ include S
+
+ val ( + ) : t -> base_u -> t
+ val ( - ) : t -> base_u -> t
+ val ( * ) : t -> base_u -> t
+ val ( / ) : t -> base_u -> t
+ val ( +: ) : t -> t -> t
+ val ( -: ) : t -> t -> t
+ val ( *: ) : t -> t -> t
+ val ( /: ) : t -> t -> t
+end
+
module Make : functor (M : BoundedType) ->
S with type base_u = M.base_t
with type u = M.t
with type t = private M.t
(** Functor to build an implementation of a bounded type given the bounded
values definition [M] *)
+module MakeNumeric : functor (M : BoundedNumericType) ->
+ NumericSig with type base_u = M.base_t
+ with type u = M.t
+ with type t = private M.t
+
View
85 testsuite/test_bounded.ml
@@ -1,57 +1,74 @@
open BatPervasives
module R = BatRandom
module U = OUnit
-open BatPrintf
module Int10_base = struct
- type t = int
+ type base_t = int
+ type t = int option
let bounds = `c 1, `c 10
- let default_low = None
- let default_high = None
- let bounded = BatBounded.bounding_of_ord ?default_low ?default_high BatInt.ord
+ let bounded = BatBounded.opt_of_ord BatInt.ord
+ let base_of_t x = x
+ let base_of_t_exn x = BatOption.get x
+ module Infix = BatInt.Infix
end
(** Only accept integers between 1 and 10, inclusive *)
-module Int10 = BatBounded.Make(Int10_base)
+module Int10 = BatBounded.MakeNumeric(Int10_base)
module Float10_base = struct
- type t = float
+ type base_t = float
+ type t = float option
let bounds = `o 1.0, `o 10.0
- let default_low = None
- let default_high = None
- let bounded = BatBounded.bounding_of_ord ?default_low ?default_high BatFloat.ord
+ let bounded = BatBounded.opt_of_ord BatFloat.ord
+ let base_of_t x = x
+ let base_of_t_exn x = BatOption.get x
+ module Infix = BatFloat.Infix
end
(** Only accept floating point values between 1 and 10, exclusive *)
-module Float10 = BatBounded.Make(Float10_base)
-
-let assert_make_make_exn (type s) m to_string x =
- let module B = (val m : BatBounded.S with type u = s) in
- let res = B.make x in
- let res_exn =
- try
- Some (B.make_exn x)
- with
- | B.Out_of_range -> None
+module Float10 = BatBounded.MakeNumeric(Float10_base)
+
+let assert_make (type s) m to_string (xs : s list) =
+ let module B =
+ (
+ val m :
+ BatBounded.NumericSig with type base_u = s and type u = s option
+ )
+ in
+ let min_bound, max_bound = B.bounds in
+ let min_check =
+ match min_bound with
+ | `o a -> (fun x -> x > a)
+ | `c a -> (fun x -> x >= a)
+ | `u -> (const true)
+ in
+ let max_check =
+ match max_bound with
+ | `o a -> (fun x -> x < a)
+ | `c a -> (fun x -> x <= a)
+ | `u -> (const true)
in
- if res = res_exn then
- ()
- else
- U.assert_failure (sprintf "make mismatch for %s" (to_string x))
+ List.iter (
+ fun x ->
+ let printer b = Printf.sprintf "%s (%b)" (to_string x) b in
+ U.assert_equal ~printer (max_check x && min_check x) (BatOption.is_some ((B.make |- B.extract) x))
+ ) xs;
+ ()
-let test_make_make_exn () =
+let test_make () =
let xs = BatList.init 100 identity in
- let m = (module Int10 : BatBounded.S with type u = int) in
- List.iter (assert_make_make_exn m string_of_int) xs;
+ let m =
+ (module Int10 : BatBounded.NumericSig with type base_u = int and type u = int option)
+ in
+ assert_make m string_of_int xs;
let xs = BatList.init 110 (fun x -> float_of_int x /. 10.0) in
- let m = (module Float10 : BatBounded.S with type u = float) in
- List.iter (assert_make_make_exn m string_of_float) xs
-
-let (>:), (>::), (>:::) = U.(>:), U.(>::), U.(>:::)
-let (@?) = U.(@?)
-let (@!) msg (exn, f) = U.assert_raises ~msg exn f
+ let m =
+ (module Float10 : BatBounded.NumericSig with type base_u = float and type u = float option)
+ in
+ assert_make m string_of_float xs
+let (>::), (>:::) = U.(>::), U.(>:::)
let tests = "Bounded" >::: [
- "value creation" >:: test_make_make_exn
+ "value creation" >:: test_make
]

0 comments on commit 5bd449c

Please sign in to comment.
Something went wrong with that request. Please try again.