M src/oth/oth.ml +84 -97
@@ 11,38 11,41 @@ module State = struct
end
module Test_result = struct
- type t = { name : string
- ; desc : string option
- ; duration : Duration.t
- ; res : [ `Ok | `Exn of (exn * Printexc.raw_backtrace option) | `Timedout ]
- }
+ type t = {
+ name : string;
+ desc : string option;
+ duration : Duration.t;
+ res : [ `Ok | `Exn of exn * Printexc.raw_backtrace option | `Timedout ];
+ }
end
module Run_result = struct
type t = Test_result.t list
+
let of_test_results = CCFun.id
+
let test_results = CCFun.id
end
module Test = struct
- type t = (State.t -> Run_result.t)
+ type t = State.t -> Run_result.t
end
module Outputter = struct
- type t = (Run_result.t -> unit)
+ type t = Run_result.t -> unit
let basic_stdout =
- List.iter
- ~f:(fun tr ->
- match tr.Test_result.res with
- | `Timedout ->
- Printf.printf "Test: %s\t\tTIMEDOUT\n" tr.Test_result.name
- | `Ok ->
- Printf.printf "Test: %s\t\tPASSED (%0.02f sec)\n"
+ List.iter ~f:(fun tr ->
+ match tr.Test_result.res with
+ | `Timedout -> Printf.printf "Test: %s\t\tTIMEDOUT\n" tr.Test_result.name
+ | `Ok ->
+ Printf.printf
+ "Test: %s\t\tPASSED (%0.02f sec)\n"
tr.Test_result.name
(Duration.to_f tr.Test_result.duration)
- | `Exn (exn, bt_opt) ->
- Printf.printf "Test: %s\t\tFAILED (%0.02f sec)\n"
+ | `Exn (exn, bt_opt) ->
+ Printf.printf
+ "Test: %s\t\tFAILED (%0.02f sec)\n"
tr.Test_result.name
(Duration.to_f tr.Test_result.duration);
CCOpt.iter (Printf.printf "Description: %s\n") tr.Test_result.desc;
@@ 54,7 57,7 @@ module Outputter = struct
let basic_tap out rr =
let (oc, close) =
match out with
- | `Filename s -> (open_out s, close_out)
+ | `Filename s -> (open_out s, close_out)
| `Out_channel oc -> (oc, CCFun.const ())
in
let num_tests = List.length rr in
@@ 62,55 65,54 @@ module Outputter = struct
let end_test = num_tests in
Printf.fprintf oc "%d..%d\n" start_test end_test;
let rec output_test n = function
- | [] ->
- ()
- | tr::trs ->
- assert (n <= end_test);
- begin match tr.Test_result.res with
- | `Ok ->
- Printf.fprintf
- oc
- "ok %d %s\n# Elapsed %0.02f sec\n"
- n
- tr.Test_result.name
- (Duration.to_f tr.Test_result.duration)
- | `Timedout ->
- Printf.fprintf
- oc
- "not ok %d %s\n# Elapsed %0.02f sec\n"
- n
- tr.Test_result.name
- (Duration.to_f tr.Test_result.duration);
- Printf.fprintf oc "# TIMEDOUT\n"
- | `Exn (exn, bt_opt) ->
- Printf.fprintf
- oc
- "not ok %d %s\n# Elapsed %0.02f sec\n"
- n
- tr.Test_result.name
- (Duration.to_f tr.Test_result.duration);
- Printf.fprintf
- oc
- "# Description: %s\n"
- (CCString.replace
- ~which:`All
- ~sub:"\n"
- ~by:"\n# "
- (CCOpt.get_or ~default:"" tr.Test_result.desc));
- Printf.fprintf
- oc
- "# Exn: %s\n"
- (CCString.replace ~which:`All ~sub:"\n" ~by:"\n# " (Printexc.to_string exn));
- Printf.fprintf
- oc
- "# Backtrace: %s\n"
- (CCString.replace
- ~which:`All
- ~sub:"\n"
- ~by:"\n# "
- (CCOpt.get_or ~default:"" (CCOpt.map Printexc.raw_backtrace_to_string bt_opt)))
- end;
- output_test (n + 1) trs
+ | [] -> ()
+ | tr :: trs ->
+ assert (n <= end_test);
+ ( match tr.Test_result.res with
+ | `Ok ->
+ Printf.fprintf
+ oc
+ "ok %d %s\n# Elapsed %0.02f sec\n"
+ n
+ tr.Test_result.name
+ (Duration.to_f tr.Test_result.duration)
+ | `Timedout ->
+ Printf.fprintf
+ oc
+ "not ok %d %s\n# Elapsed %0.02f sec\n"
+ n
+ tr.Test_result.name
+ (Duration.to_f tr.Test_result.duration);
+ Printf.fprintf oc "# TIMEDOUT\n"
+ | `Exn (exn, bt_opt) ->
+ Printf.fprintf
+ oc
+ "not ok %d %s\n# Elapsed %0.02f sec\n"
+ n
+ tr.Test_result.name
+ (Duration.to_f tr.Test_result.duration);
+ Printf.fprintf
+ oc
+ "# Description: %s\n"
+ (CCString.replace
+ ~which:`All
+ ~sub:"\n"
+ ~by:"\n# "
+ (CCOpt.get_or ~default:"" tr.Test_result.desc));
+ Printf.fprintf
+ oc
+ "# Exn: %s\n"
+ (CCString.replace ~which:`All ~sub:"\n" ~by:"\n# " (Printexc.to_string exn));
+ Printf.fprintf
+ oc
+ "# Backtrace: %s\n"
+ (CCString.replace
+ ~which:`All
+ ~sub:"\n"
+ ~by:"\n# "
+ (CCOpt.get_or ~default:"" (CCOpt.map Printexc.raw_backtrace_to_string bt_opt)))
+ );
+ output_test (n + 1) trs
in
output_test start_test rr;
close oc
@@ 118,69 120,55 @@ module Outputter = struct
let of_env ?(default = []) env_name outputter_map rr =
let outputters =
let outputter_names =
- try
- CCString.Split.list_cpy ~by:" " (Sys.getenv env_name)
- with
- | Not_found ->
- default
+ try CCString.Split.list_cpy ~by:" " (Sys.getenv env_name) with Not_found -> default
in
List.map
~f:(fun on -> CCList.Assoc.get_exn ~eq:CCString.equal on outputter_map)
outputter_names
in
- List.iter
- ~f:(fun outputter -> outputter rr)
- outputters
+ List.iter ~f:(fun outputter -> outputter rr) outputters
end
let time_test s f =
let start = Unix.gettimeofday () in
let res =
match CCResult.guard (fun () -> f s) with
- | Ok () -> `Ok
+ | Ok () -> `Ok
| Error exn -> `Exn (exn, Some (Printexc.get_raw_backtrace ()))
in
let stop = Unix.gettimeofday () in
let duration = Duration.of_f (stop -. start) in
(duration, res)
-let serial tests state =
- List.concat
- (List.map
- ~f:(fun test -> test state)
- tests)
+let serial tests state = List.concat (List.map ~f:(fun test -> test state) tests)
let parallel = serial
let test ?desc ~name f state =
let (duration, res) = time_test state f in
- Test_result.([{ name; desc; duration; res }])
+ Test_result.[ { name; desc; duration; res } ]
let raw_test f state = f state
let result_test rtest state =
let res = rtest state in
match res with
- | Ok _ -> ()
+ | Ok _ -> ()
| Error _ -> assert false
let test_with_revops ?desc ~name ~revops tst =
- test
- ?desc
- ~name
- (fun state -> Revops.run_in_context revops (CCFun.flip tst state))
+ test ?desc ~name (fun state -> Revops.run_in_context revops (CCFun.flip tst state))
-let eval test =
- test (State.create ())
+let eval test = test (State.create ())
let main outputter test =
let rr = eval test in
outputter rr;
List.iter
(fun tr ->
- match tr.Test_result.res with
- | `Ok -> ()
- | _ -> exit 1)
+ match tr.Test_result.res with
+ | `Ok -> ()
+ | _ -> exit 1)
rr;
exit 0
@@ 189,17 177,15 @@ let run test =
try
let dir = Sys.getenv "OTH_TAP_DIR" in
Filename.concat dir (Filename.basename Sys.executable_name)
- with
- | Not_found ->
- Filename.basename Sys.executable_name
+ with Not_found -> Filename.basename Sys.executable_name
in
let tap_output_name = tap_output_base_name ^ ".tap" in
let outputter =
Outputter.of_env
- ~default:["stdout"; "tap"]
+ ~default:[ "stdout"; "tap" ]
"OTH_OUTPUTTER"
- [ ("stdout", Outputter.basic_stdout)
- ; ("tap", Outputter.basic_tap (`Filename tap_output_name))
+ [
+ ("stdout", Outputter.basic_stdout); ("tap", Outputter.basic_tap (`Filename tap_output_name));
]
in
main outputter test
@@ 216,4 202,5 @@ let loop n test state =
loop' n
let verbose = CCFun.id
+
let silent = CCFun.id
M src/oth/oth.mli +13 -17
@@ 12,30 12,33 @@ end
(** The result of a single test. *)
module Test_result : sig
- type t = { name : string
- ; desc : string option
- ; duration : Duration.t
- ; res : [ `Ok | `Exn of (exn * Printexc.raw_backtrace option) | `Timedout ]
- }
+ type t = {
+ name : string;
+ desc : string option;
+ duration : Duration.t;
+ res : [ `Ok | `Exn of exn * Printexc.raw_backtrace option | `Timedout ];
+ }
end
(** The result of a run, which is a list of tests. The order of the tests is
undefined. *)
module Run_result : sig
type t
+
val of_test_results : Test_result.t list -> t
+
val test_results : t -> Test_result.t list
end
module Outputter : sig
- type t = (Run_result.t -> unit)
+ type t = Run_result.t -> unit
(** An outputter that writes a basic format to stdout. *)
val basic_stdout : t
(** An outputter that writes to a file. The [out_channel] specifies where to
write the results to. *)
- val basic_tap : [`Filename of string | `Out_channel of out_channel] -> t
+ val basic_tap : [ `Filename of string | `Out_channel of out_channel ] -> t
(** Takes an environment variable name and a list of tuples mapping a string
name to an Outputter. The environment variable will be compared to the
@@ 91,18 94,11 @@ val name : name:string -> Test.t -> Test
(** Turn a test that returns a result into one that returns a unit. This
asserts that the result is on the 'Ok' path. *)
-val result_test :
- (State.t -> (unit, 'err) result) ->
- State.t ->
- unit
+val result_test : (State.t -> (unit, 'err) result) -> State.t -> unit
(** Turn a function into a test with a setup and teardown phase *)
val test_with_revops :
- ?desc:string ->
- name:string ->
- revops:'a Revops.Oprev.t ->
- ('a -> State.t -> unit) ->
- Test.t
+ ?desc:string -> name:string -> revops:'a Revops.Oprev.t -> ('a -> State.t -> unit) -> Test.t
(** Turn verbose logging on. This is the default but can be turned off with
{!silent}, this will turn it back on.
@@ 113,4 109,4 @@ val verbose : Test.t -> Test.t
(** Turn logging off in the test, this is useful in combination with {!loop}.
@deprecated This no longer does anything. *)
-val silent : Test.t -> Test.t
+val silent : Test.t -> Test.t
M src/revops/revops.ml +4 -1
@@ 2,10 2,13 @@
module Monad = struct
type 'a t = 'a
+
let ( >>= ) v f = f v
+
let return = CCFun.id
+
let protect ~f ~finally = CCFun.finally ~f ~h:finally
end
(* Functor application, see revops_fn.ml *)
-include Revops_fn.Make(Monad)
+include Revops_fn.Make (Monad)
M src/revops/revops_fn.ml +47 -57
@@ 1,69 1,59 @@
(* Implementation for reversible operations. *)
-module Make = functor (Monad : Revops_intf.MONAD) -> struct
- module M = Monad
+module Make =
+functor
+ (Monad : Revops_intf.MONAD)
+ ->
+ struct
+ module M = Monad
- module Oprev = struct
- type 'a t = (unit -> 'a M.t) * ('a -> unit M.t)
-
- let make do_fun undo_fun = (do_fun, undo_fun)
- end
+ module Oprev = struct
+ type 'a t = (unit -> 'a M.t) * ('a -> unit M.t)
- module Revop = struct
- type 'a t = ('a * ('a -> unit M.t))
- end
+ let make do_fun undo_fun = (do_fun, undo_fun)
+ end
- open M
+ module Revop = struct
+ type 'a t = 'a * ('a -> unit M.t)
+ end
- let doop (do_fun, undo_fun) =
- do_fun ()
- >>= fun undo_state ->
- return (undo_state, undo_fun)
+ open M
+
+ let doop (do_fun, undo_fun) = do_fun () >>= fun undo_state -> return (undo_state, undo_fun)
- let undo (undo_state, undo_fun) = undo_fun undo_state
+ let undo (undo_state, undo_fun) = undo_fun undo_state
- let peek (undo_state, undo_fun) = undo_state
+ let peek (undo_state, undo_fun) = undo_state
- let compose ~introduce
- ~eliminate_first
- ~eliminate_second
- ~first
- ~second =
- let (_, undo_first) = first in
- let (_, undo_second) = second in
- let do_fun () =
- doop first
- >>= fun first_revop ->
- doop second
- >>= fun second_revop ->
- introduce (peek first_revop) (peek second_revop)
- in
- let undo_fun undo_state =
- eliminate_second undo_state
- >>= fun second_state ->
- undo_second second_state
- >>= fun () ->
- eliminate_first undo_state
- >>= fun first_state ->
- undo_first first_state
- in
- Oprev.make do_fun undo_fun
+ let compose ~introduce ~eliminate_first ~eliminate_second ~first ~second =
+ let (_, undo_first) = first in
+ let (_, undo_second) = second in
+ let do_fun () =
+ doop first
+ >>= fun first_revop ->
+ doop second >>= fun second_revop -> introduce (peek first_revop) (peek second_revop)
+ in
+ let undo_fun undo_state =
+ eliminate_second undo_state
+ >>= fun second_state ->
+ undo_second second_state
+ >>= fun () -> eliminate_first undo_state >>= fun first_state -> undo_first first_state
+ in
+ Oprev.make do_fun undo_fun
- let compose_tuple first second =
- compose
- (fun l r -> return (l, r))
- (CCFun.compose fst return)
- (CCFun.compose snd return)
- first
- second
+ let compose_tuple first second =
+ compose
+ (fun l r -> return (l, r))
+ (CCFun.compose fst return)
+ (CCFun.compose snd return)
+ first
+ second
- let ( +* ) = compose_tuple
+ let ( +* ) = compose_tuple
- let run_in_context oprev action =
- doop oprev
- >>= fun revop ->
- let unit_action () = action (peek revop) in
- M.protect
- ~f:unit_action
- ~finally:(fun () -> undo revop)
-end
+ let run_in_context oprev action =
+ doop oprev
+ >>= fun revop ->
+ let unit_action () = action (peek revop) in
+ M.protect ~f:unit_action ~finally:(fun () -> undo revop)
+ end
M src/revops/revops_fn.mli +1 -3
@@ 2,6 2,4 @@
* Interface for reversible operations.
*)
-module Make :
- functor (Monad : Revops_intf.MONAD) ->
- (Revops_intf.S with type 'a M.t = 'a Monad.t)
+module Make : functor (Monad : Revops_intf.MONAD) -> Revops_intf.S with type 'a M.t = 'a Monad.t
M src/revops/revops_intf.ml +10 -6
@@ 2,7 2,9 @@ module type MONAD = sig
type 'a t
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
+
val return : 'a -> 'a t
+
val protect : f:(unit -> 'a t) -> finally:(unit -> 'b) -> 'a t
end
@@ 11,6 13,7 @@ module type S = sig
module Oprev : sig
type 'a t
+
val make : (unit -> 'a M.t) -> ('a -> unit M.t) -> 'a t
end
@@ 29,12 32,13 @@ module type S = sig
* oprev is setup and then the second. The order of evaluation on an undo is the
* second oprev is torn-down and then the first.
*)
- val compose : introduce:('a -> 'b -> 'c M.t) ->
- eliminate_first:('c -> 'a M.t) ->
- eliminate_second:('c -> 'b M.t) ->
- first:'a Oprev.t ->
- second:'b Oprev.t ->
- 'c Oprev.t
+ val compose :
+ introduce:('a -> 'b -> 'c M.t) ->
+ eliminate_first:('c -> 'a M.t) ->
+ eliminate_second:('c -> 'b M.t) ->
+ first:'a Oprev.t ->
+ second:'b Oprev.t ->
+ 'c Oprev.t
val compose_tuple : 'a Oprev.t -> 'b Oprev.t -> ('a * 'b) Oprev.t
M src/revops/revops_sys.ml +1 -1
@@ 1,6 1,6 @@
(* Implementation of basic revops for system operations. *)
-let temp_file ?(prefix="Temp") ?(suffix = "CleanMe") () =
+let temp_file ?(prefix = "Temp") ?(suffix = "CleanMe") () =
Revops.Oprev.make
(fun () -> Filename.temp_file prefix suffix)
(fun filename -> Unix.unlink filename)