Permalink
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...
hcarty committed Oct 8, 2012
1 parent 8870196 commit 5bd449c3def45728607dba8c88d74b21989742a2
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
@@ -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
Oops, something went wrong.

0 comments on commit 5bd449c

Please sign in to comment.