Index: trunk/omega/src/thoString.ml =================================================================== --- trunk/omega/src/thoString.ml (revision 8806) +++ trunk/omega/src/thoString.ml (revision 8807) @@ -1,231 +1,231 @@ (* thoString.ml -- Copyright (C) 1999-2022 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let strip_prefix p s = let lp = String.length p and ls = String.length s in if lp > ls then s else let rec strip_prefix' i = if i >= lp then String.sub s i (ls - i) else if p.[i] <> s.[i] then s else strip_prefix' (succ i) in strip_prefix' 0 let strip_prefix_star p s = let ls = String.length s in if ls < 1 then s else let rec strip_prefix_star' i = if i < ls then begin if p <> s.[i] then String.sub s i (ls - i) else strip_prefix_star' (succ i) end else "" in strip_prefix_star' 0 let strip_required_prefix p s = let lp = String.length p and ls = String.length s in if lp > ls then invalid_arg ("strip_required_prefix: expected `" ^ p ^ "' got `" ^ s ^ "'") else let rec strip_prefix' i = if i >= lp then String.sub s i (ls - i) else if p.[i] <> s.[i] then invalid_arg ("strip_required_prefix: expected `" ^ p ^ "' got `" ^ s ^ "'") else strip_prefix' (succ i) in strip_prefix' 0 let strip_from_first c s = try String.sub s 0 (String.index s c) with | Not_found -> s let strip_from_last c s = try String.sub s 0 (String.rindex s c) with | Not_found -> s let index_string pat s = let lpat = String.length pat and ls = String.length s in if lpat = 0 then 0 else let rec index_string' n = let i = String.index_from s n pat.[0] in if i + lpat > ls then raise Not_found else if String.compare pat (String.sub s i lpat) = 0 then i else index_string' (succ i) in index_string' 0 let quote s = if String.contains s ' ' || String.contains s '\n' then begin if String.contains s '"' then "'" ^ s ^ "'" else "\"" ^ s ^ "\"" end else s -let uppercase = String.uppercase -let lowercase = String.lowercase +let uppercase = String.uppercase_ascii +let lowercase = String.lowercase_ascii let compare_caseless s1 s2 = String.compare (lowercase s1) (lowercase s2) let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_numeric c = '0' <= c && c <= '9' let is_alphanum c = is_alpha c || is_numeric c || c = '_' let valid_fortran_id s = let rec valid_fortran_id' n = if n < 0 then false else if n = 0 then is_alpha s.[0] else if is_alphanum s.[n] then valid_fortran_id' (pred n) else false in valid_fortran_id' (pred (String.length s)) let sanitize_fortran_id s = let sanitize s = String.map (fun c -> if is_alphanum c then c else '_') s in if String.length s <= 0 then invalid_arg "ThoString.sanitize_fortran_id: empty" else if is_alpha s.[0] then sanitize s else "N_" ^ sanitize s module Test = struct open OUnit let fortran_empty = "empty" >:: (fun () -> assert_equal false (valid_fortran_id "")) let fortran_digit = "0" >:: (fun () -> assert_equal false (valid_fortran_id "0")) let fortran_digit_alpha = "0abc" >:: (fun () -> assert_equal false (valid_fortran_id "0abc")) let fortran_underscore = "_" >:: (fun () -> assert_equal false (valid_fortran_id "_")) let fortran_underscore_alpha = "_ABC" >:: (fun () -> assert_equal false (valid_fortran_id "_ABC")) let fortran_questionmark = "A?C" >:: (fun () -> assert_equal false (valid_fortran_id "A?C")) let fortran_valid = "A_xyz_0_" >:: (fun () -> assert_equal true (valid_fortran_id "A_xyz_0_")) let sanitize_digit = "0" >:: (fun () -> assert_equal "N_0" (sanitize_fortran_id "0")) let sanitize_digit_alpha = "0abc" >:: (fun () -> assert_equal "N_0abc" (sanitize_fortran_id "0abc")) let sanitize_underscore = "_" >:: (fun () -> assert_equal "N__" (sanitize_fortran_id "_")) let sanitize_underscore_alpha = "_ABC" >:: (fun () -> assert_equal "N__ABC" (sanitize_fortran_id "_ABC")) let sanitize_questionmark = "A?C" >:: (fun () -> assert_equal "A_C" (sanitize_fortran_id "A?C")) let sanitize_valid = "A_xyz_0_" >:: (fun () -> assert_equal "A_xyz_0_" (sanitize_fortran_id "A_xyz_0_")) let suite_fortran = "valid_fortran_id" >::: [fortran_empty; fortran_digit; fortran_digit_alpha; fortran_underscore; fortran_underscore_alpha; fortran_questionmark; fortran_valid] let suite_sanitize = "sanitize_fortran_id" >::: [sanitize_digit; sanitize_digit_alpha; sanitize_underscore; sanitize_underscore_alpha; sanitize_questionmark; sanitize_valid] let suite = "ThoString" >::: [suite_fortran; suite_sanitize] end Index: trunk/omega/src/OUnit.ml =================================================================== --- trunk/omega/src/OUnit.ml (revision 8806) +++ trunk/omega/src/OUnit.ml (revision 8807) @@ -1,805 +1,779 @@ (* oUnit.ml -- *) (***********************************************************************) (* The OUnit library *) (* *) (* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) (* Copyright (C) 2010 OCamlCore SARL *) (* *) (***********************************************************************) (* Version 1.1.2, with minor modifications by Thorsten Ohl *) (************************************************************************ The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL. Permission is hereby granted, free of charge, to any person obtaining a copy of this document and the OUnit software ("the Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. The Software is provided ``as is'', without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall Maas-Maarten Zeeman be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the Software or the use or other dealings in the software. ************************************************************************) open Format (* TODO: really use Format in printf call. Most of the time, not * cuts/spaces/boxes are used *) let global_verbose = ref false let buff_printf f = let buff = Buffer.create 13 in let fmt = formatter_of_buffer buff in f fmt; pp_print_flush fmt (); Buffer.contents buff let bracket set_up f tear_down () = let fixture = set_up () in let () = try let () = f fixture in tear_down fixture with e -> let () = tear_down fixture in raise e in () let bracket_tmpfile ?(prefix="ounit-") ?(suffix=".txt") ?mode f = bracket (fun () -> Filename.open_temp_file ?mode prefix suffix) f (fun (fn, chn) -> begin try close_out chn with _ -> () end; begin try Sys.remove fn with _ -> () end) exception Skip of string let skip_if b msg = if b then raise (Skip msg) exception Todo of string let todo msg = raise (Todo msg) let assert_failure msg = failwith ("OUnit: " ^ msg) let assert_bool msg b = if not b then assert_failure msg let assert_string str = if not (str = "") then assert_failure str let assert_equal ?(cmp = ( = )) ?printer ?pp_diff ?msg expected actual = let get_error_string () = (* let max_len = pp_get_margin fmt () in *) (* let ellipsis_text = "[...]" in *) let print_ellipsis p fmt s = (* TODO: find a way to do this let res = p s in let len = String.length res in if diff <> None && len > max_len then begin let len_with_ellipsis = (max_len - (String.length ellipsis_text)) / 2 in (* TODO: we should use %a here to print values *) fprintf fmt "@[%s[...]%s@]" (String.sub res 0 len_with_ellipsis) (String.sub res (len - len_with_ellipsis) len_with_ellipsis) end else begin (* TODO: we should use %a here to print values *) fprintf fmt "@[%s@]" res end *) pp_print_string fmt (p s) in let res = buff_printf (fun fmt -> pp_open_vbox fmt 0; begin match msg with | Some s -> pp_open_box fmt 0; pp_print_string fmt s; pp_close_box fmt (); pp_print_cut fmt () | None -> () end; begin match printer with | Some p -> let p_ellipsis = print_ellipsis p in fprintf fmt "@[expected: @[%a@]@ but got: @[%a@]@]@," p_ellipsis expected p_ellipsis actual | None -> fprintf fmt "@[not equal@]@," end; begin match pp_diff with | Some d -> fprintf fmt "@[differences: %a@]@," d (expected, actual) | None -> () end; pp_close_box fmt ()) in let len = String.length res in if len > 0 && res.[len - 1] = '\n' then String.sub res 0 (len - 1) else res in if not (cmp expected actual) then assert_failure (get_error_string ()) let assert_command ?(exit_code=Unix.WEXITED 0) - ?(sinput=Stream.of_list []) - ?(foutput=ignore) ?(use_stderr=true) ?env ?verbose prg args = let verbose = match verbose with | Some v -> v | None -> !global_verbose in bracket_tmpfile (fun (fn_out, chn_out) -> let cmd_print fmt = let () = match env with | Some e -> begin pp_print_string fmt "env"; Array.iter (fprintf fmt "@ %s") e; pp_print_space fmt () end | None -> () in pp_print_string fmt prg; List.iter (fprintf fmt "@ %s") args in (* Start the process *) let in_write = Unix.dup (Unix.descr_of_out_channel chn_out) in let (out_read, out_write) = Unix.pipe () in let err = if use_stderr then in_write else Unix.stderr in let args = Array.of_list (prg :: args) in let pid = Unix.set_close_on_exec out_write; if verbose then printf "@[Starting command '%t'@]\n" cmd_print; match env with | Some e -> Unix.create_process_env prg args e out_read in_write err | None -> Unix.create_process prg args out_read in_write err in let () = Unix.close out_read; Unix.close in_write in - let () = - (* Dump sinput into the process stdin *) - let buff = Bytes.make 1 ' ' in - Stream.iter - (fun c -> - let _i : int = - Bytes.set buff 0 c; - Unix.write out_write buff 0 1 - in - ()) - sinput; - Unix.close out_write - in let _, real_exit_code = let rec wait_intr () = try Unix.waitpid [] pid with Unix.Unix_error (Unix.EINTR, _, _) -> wait_intr () in wait_intr () in let exit_code_printer = function | Unix.WEXITED n -> Printf.sprintf "exit code %d" n | Unix.WSTOPPED n -> Printf.sprintf "stopped by signal %d" n | Unix.WSIGNALED n -> Printf.sprintf "killed by signal %d" n in (* Dump process output to stderr *) if verbose then begin let chn = open_in fn_out in let buff = Bytes.make 4096 'X' in let len = ref (-1) in while !len <> 0 do len := input chn buff 0 (Bytes.length buff); printf "%s" (Bytes.sub_string buff 0 !len); done; printf "@?"; close_in chn end; (* Check process status *) assert_equal ~msg:(buff_printf (fun fmt -> fprintf fmt "@[Exit status of command '%t'@]" cmd_print)) ~printer:exit_code_printer exit_code - real_exit_code; - - begin - let chn = - open_in fn_out - in - try - foutput (Stream.of_channel chn) - with e -> - close_in chn; - raise e - end) + real_exit_code) () let raises f = try f (); None with e -> Some e let assert_raises ?msg exn (f: unit -> 'a) = let pexn = Printexc.to_string in let get_error_string () = let str = Format.sprintf "expected exception %s, but no exception was raised." (pexn exn) in match msg with | None -> assert_failure str | Some s -> assert_failure (Format.sprintf "%s\n%s" s str) in match raises f with | None -> assert_failure (get_error_string ()) | Some e -> assert_equal ?msg ~printer:pexn exn e (* Compare floats up to a given relative error *) let cmp_float ?(epsilon = 0.00001) a b = abs_float (a -. b) <= epsilon *. (abs_float a) || abs_float (a -. b) <= epsilon *. (abs_float b) (* Now some handy shorthands *) let (@?) = assert_bool (* The type of test function *) type test_fun = unit -> unit (* The type of tests *) type test = | TestCase of test_fun | TestList of test list | TestLabel of string * test (* Some shorthands which allows easy test construction *) let (>:) s t = TestLabel(s, t) (* infix *) let (>::) s f = TestLabel(s, TestCase(f)) (* infix *) let (>:::) s l = TestLabel(s, TestList(l)) (* infix *) (* Utility function to manipulate test *) let rec test_decorate g = function | TestCase f -> TestCase (g f) | TestList tst_lst -> TestList (List.map (test_decorate g) tst_lst) | TestLabel (str, tst) -> TestLabel (str, test_decorate g tst) (* Return the number of available tests *) let rec test_case_count = function | TestCase _ -> 1 | TestLabel (_, t) -> test_case_count t | TestList l -> List.fold_left (fun c t -> c + test_case_count t) 0 l type node = | ListItem of int | Label of string type path = node list let string_of_node = function | ListItem n -> string_of_int n | Label s -> s let string_of_path path = String.concat ":" (List.rev_map string_of_node path) (* Some helper function, they are generally applicable *) (* Applies function f in turn to each element in list. Function f takes one element, and integer indicating its location in the list *) let mapi f l = let rec rmapi cnt l = match l with | [] -> [] | h :: t -> (f h cnt) :: (rmapi (cnt + 1) t) in rmapi 0 l let fold_lefti f accu l = let rec rfold_lefti cnt accup l = match l with | [] -> accup | h::t -> rfold_lefti (cnt + 1) (f accup h cnt) t in rfold_lefti 0 accu l (* Returns all possible paths in the test. The order is from test case to root *) let test_case_paths test = let rec tcps path test = match test with | TestCase _ -> [path] | TestList tests -> List.concat (mapi (fun t i -> tcps ((ListItem i)::path) t) tests) | TestLabel (l, t) -> tcps ((Label l)::path) t in tcps [] test (* Test filtering with their path *) module SetTestPath = Set.Make(String) let test_filter ?(skip=false) only test = let set_test = List.fold_left (fun st str -> SetTestPath.add str st) SetTestPath.empty only in let rec filter_test path tst = if SetTestPath.mem (string_of_path path) set_test then begin Some tst end else begin match tst with | TestCase f -> begin if skip then Some (TestCase (fun () -> skip_if true "Test disabled"; f ())) else None end | TestList tst_lst -> begin let ntst_lst = fold_lefti (fun ntst_lst tst i -> let nntst_lst = match filter_test ((ListItem i) :: path) tst with | Some tst -> tst :: ntst_lst | None -> ntst_lst in nntst_lst) [] tst_lst in if not skip && ntst_lst = [] then None else Some (TestList (List.rev ntst_lst)) end | TestLabel (lbl, tst) -> begin let ntst_opt = filter_test ((Label lbl) :: path) tst in match ntst_opt with | Some ntst -> Some (TestLabel (lbl, ntst)) | None -> if skip then Some (TestLabel (lbl, tst)) else None end end in filter_test [] test (* The possible test results *) type test_result = | RSuccess of path | RFailure of path * string | RError of path * string | RSkip of path * string | RTodo of path * string let is_success = function | RSuccess _ -> true | RFailure _ | RError _ | RSkip _ | RTodo _ -> false let is_failure = function | RFailure _ -> true | RSuccess _ | RError _ | RSkip _ | RTodo _ -> false let is_error = function | RError _ -> true | RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> false let is_skip = function | RSkip _ -> true | RSuccess _ | RFailure _ | RError _ | RTodo _ -> false let is_todo = function | RTodo _ -> true | RSuccess _ | RFailure _ | RError _ | RSkip _ -> false let result_flavour = function | RError _ -> "Error" | RFailure _ -> "Failure" | RSuccess _ -> "Success" | RSkip _ -> "Skip" | RTodo _ -> "Todo" let result_path = function | RSuccess path | RError (path, _) | RFailure (path, _) | RSkip (path, _) | RTodo (path, _) -> path let result_msg = function | RSuccess _ -> "Success" | RError (_, msg) | RFailure (_, msg) | RSkip (_, msg) | RTodo (_, msg) -> msg (* Returns true if the result list contains successes only *) let rec was_successful = function | [] -> true | RSuccess _::t | RSkip _::t -> was_successful t | RFailure _::_ | RError _::_ | RTodo _::_ -> false (* Events which can happen during testing *) type test_event = | EStart of path | EEnd of path | EResult of test_result let maybe_backtrace () = if Printexc.backtrace_status () then "\n" ^ Printexc.get_backtrace () else "" (* Run all tests, report starts, errors, failures, and return the results *) let perform_test report test = let run_test_case f path = try f (); RSuccess path with | Failure s -> RFailure (path, s ^ maybe_backtrace ()) | Skip s -> RSkip (path, s) | Todo s -> RTodo (path, s) | s -> RError (path, Printexc.to_string s ^ maybe_backtrace ()) in let rec run_test path results = function | TestCase(f) -> begin let result = report (EStart path); run_test_case f path in report (EResult result); report (EEnd path); result::results end | TestList (tests) -> begin fold_lefti (fun results t cnt -> run_test ((ListItem cnt)::path) results t) results tests end | TestLabel (label, t) -> begin run_test ((Label label)::path) results t end in run_test [] [] test (* Function which runs the given function and returns the running time of the function, and the original result in a tuple *) let time_fun f x y = let begin_time = Unix.gettimeofday () in (Unix.gettimeofday () -. begin_time, f x y) (* A simple (currently too simple) text based test runner *) let run_test_tt ?verbose test = let verbose = match verbose with | Some v -> v | None -> !global_verbose in let printf = Format.printf in let separator1 = String.make (get_margin ()) '=' in let separator2 = String.make (get_margin ()) '-' in let string_of_result = function | RSuccess _ -> if verbose then "ok\n" else "." | RFailure (_, _) -> if verbose then "FAIL\n" else "F" | RError (_, _) -> if verbose then "ERROR\n" else "E" | RSkip (_, _) -> if verbose then "SKIP\n" else "S" | RTodo (_, _) -> if verbose then "TODO\n" else "T" in let report_event = function | EStart p -> if verbose then printf "%s ...\n" (string_of_path p) | EEnd _ -> () | EResult result -> printf "%s@?" (string_of_result result) in let print_result_list results = List.iter (fun result -> printf "%s\n%s: %s\n\n%s\n%s\n" separator1 (result_flavour result) (string_of_path (result_path result)) (result_msg result) separator2) results in (* Now start the test *) let running_time, results = time_fun perform_test report_event test in let errors = List.filter is_error results in let failures = List.filter is_failure results in let skips = List.filter is_skip results in let todos = List.filter is_todo results in if not verbose then printf "\n"; (* Print test report *) print_result_list errors; print_result_list failures; printf "Ran: %d tests in: %.2f seconds.\n" (List.length results) running_time; (* Print final verdict *) if was_successful results then ( if skips = [] then printf "OK" else printf "OK: Cases: %d Skip: %d\n" (test_case_count test) (List.length skips) ) else printf "FAILED: Cases: %d Tried: %d Errors: %d \ Failures: %d Skip:%d Todo:%d\n" (test_case_count test) (List.length results) (List.length errors) (List.length failures) (List.length skips) (List.length todos); (* Return the results possibly for further processing *) results (* Call this one from you test suites *) let run_test_tt_main ?(arg_specs=[]) ?(set_verbose=ignore) suite = let only_test = ref [] in let () = Arg.parse (Arg.align [ "-verbose", Arg.Set global_verbose, " Run the test in verbose mode."; "-only-test", Arg.String (fun str -> only_test := str :: !only_test), "path Run only the selected test"; "-list-test", Arg.Unit (fun () -> List.iter (fun pth -> print_endline (string_of_path pth)) (test_case_paths suite); exit 0), " List tests"; ] @ arg_specs ) (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) ("usage: " ^ Sys.argv.(0) ^ " [-verbose] [-only-test path]*") in let nsuite = if !only_test = [] then suite else begin match test_filter ~skip:true !only_test suite with | Some test -> test | None -> failwith ("Filtering test "^ (String.concat ", " !only_test)^ " lead to no test") end in let result = set_verbose !global_verbose; run_test_tt ~verbose:!global_verbose nsuite in if not (was_successful result) then exit 1 else result Index: trunk/omega/src/OUnit.mli =================================================================== --- trunk/omega/src/OUnit.mli (revision 8806) +++ trunk/omega/src/OUnit.mli (revision 8807) @@ -1,283 +1,278 @@ (* oUnit.mli -- *) (***********************************************************************) (* The OUnit library *) (* *) (* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) (* Copyright (C) 2010 OCamlCore SARL *) (* *) (***********************************************************************) (* Version 1.1.2, with minor modifications by Thorsten Ohl *) (************************************************************************ The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL. Permission is hereby granted, free of charge, to any person obtaining a copy of this document and the OUnit software ("the Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. The Software is provided ``as is'', without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall Maas-Maarten Zeeman be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the Software or the use or other dealings in the software. ************************************************************************) (** Unit test building blocks @author Maas-Maarten Zeeman @author Sylvain Le Gall *) (** {2 Assertions} Assertions are the basic building blocks of unittests. *) (** Signals a failure. This will raise an exception with the specified string. @raise Failure signal a failure *) val assert_failure : string -> 'a (** Signals a failure when bool is false. The string identifies the failure. @raise Failure signal a failure *) val assert_bool : string -> bool -> unit (** Shorthand for assert_bool @raise Failure to signal a failure *) val ( @? ) : string -> bool -> unit (** Signals a failure when the string is non-empty. The string identifies the failure. @raise Failure signal a failure *) val assert_string : string -> unit (** [assert_command prg args] Run the command provided. @param exit_code expected exit code - @param sinput provide this [char Stream.t] as input of the process - @param foutput run this function on output, it can contains an - [assert_equal] to check it @param use_stderr redirect [stderr] to [stdout] @param env Unix environment @param verbose if a failure arise, dump stdout/stderr of the process to stderr @since 1.1.0 *) val assert_command : ?exit_code:Unix.process_status -> - ?sinput:char Stream.t -> - ?foutput:(char Stream.t -> unit) -> ?use_stderr:bool -> ?env:string array -> ?verbose:bool -> string -> string list -> unit (** [assert_equal expected real] Compares two values, when they are not equal a failure is signaled. @param cmp customize function to compare, default is [=] @param printer value printer, don't print value otherwise @param pp_diff if not equal, ask a custom display of the difference using [diff fmt exp real] where [fmt] is the formatter to use @param msg custom message to identify the failure @raise Failure signal a failure @version 1.1.0 *) val assert_equal : ?cmp:('a -> 'a -> bool) -> ?printer:('a -> string) -> ?pp_diff:(Format.formatter -> ('a * 'a) -> unit) -> ?msg:string -> 'a -> 'a -> unit (** Asserts if the expected exception was raised. @param msg identify the failure @raise Failure description *) val assert_raises : ?msg:string -> exn -> (unit -> 'a) -> unit (** {2 Skipping tests } In certain condition test can be written but there is no point running it, because they are not significant (missing OS features for example). In this case this is not a failure nor a success. Following functions allow you to escape test, just as assertion but without the same error status. A test skipped is counted as success. A test todo is counted as failure. *) (** [skip cond msg] If [cond] is true, skip the test for the reason explain in [msg]. For example [skip_if (Sys.os_type = "Win32") "Test a doesn't run on windows"]. @since 1.0.3 *) val skip_if : bool -> string -> unit (** The associated test is still to be done, for the reason given. @since 1.0.3 *) val todo : string -> unit (** {2 Compare Functions} *) (** Compare floats up to a given relative error. @param epsilon if the difference is smaller [epsilon] values are equal *) val cmp_float : ?epsilon:float -> float -> float -> bool (** {2 Bracket} A bracket is a functional implementation of the commonly used setUp and tearDown feature in unittests. It can be used like this: ["MyTestCase" >:: (bracket test_set_up test_fun test_tear_down)] *) (** [bracket set_up test tear_down] The [set_up] function runs first, then the [test] function runs and at the end [tear_down] runs. The [tear_down] function runs even if the [test] failed and help to clean the environment. *) val bracket: (unit -> 'a) -> ('a -> unit) -> ('a -> unit) -> unit -> unit (** [bracket_tmpfile test] The [test] function takes a temporary filename and matching output channel as arguments. The temporary file is created before the test and removed after the test. @param prefix see [Filename.open_temp_file] @param suffix see [Filename.open_temp_file] @param mode see [Filename.open_temp_file] @since 1.1.0 *) val bracket_tmpfile: ?prefix:string -> ?suffix:string -> ?mode:open_flag list -> ((string * out_channel) -> unit) -> unit -> unit (** {2 Constructing Tests} *) (** The type of test function *) type test_fun = unit -> unit (** The type of tests *) type test = TestCase of test_fun | TestList of test list | TestLabel of string * test (** Create a TestLabel for a test *) val (>:) : string -> test -> test (** Create a TestLabel for a TestCase *) val (>::) : string -> test_fun -> test (** Create a TestLabel for a TestList *) val (>:::) : string -> test list -> test (** Some shorthands which allows easy test construction. Examples: - ["test1" >: TestCase((fun _ -> ()))] => [TestLabel("test2", TestCase((fun _ -> ())))] - ["test2" >:: (fun _ -> ())] => [TestLabel("test2", TestCase((fun _ -> ())))] - ["test-suite" >::: ["test2" >:: (fun _ -> ());]] => [TestLabel("test-suite", TestSuite([TestLabel("test2", TestCase((fun _ -> ())))]))] *) (** [test_decorate g tst] Apply [g] to test function contains in [tst] tree. @since 1.0.3 *) val test_decorate : (test_fun -> test_fun) -> test -> test (** [test_filter paths tst] Filter test based on their path string representation. @param skip] if set, just use [skip_if] for the matching tests. @since 1.0.3 *) val test_filter : ?skip:bool -> string list -> test -> test option (** {2 Retrieve Information from Tests} *) (** Returns the number of available test cases *) val test_case_count : test -> int (** Types which represent the path of a test *) type node = ListItem of int | Label of string type path = node list (** The path to the test (in reverse order). *) (** Make a string from a node *) val string_of_node : node -> string (** Make a string from a path. The path will be reversed before it is tranlated into a string *) val string_of_path : path -> string (** Returns a list with paths of the test *) val test_case_paths : test -> path list (** {2 Performing Tests} *) (** The possible results of a test *) type test_result = RSuccess of path | RFailure of path * string | RError of path * string | RSkip of path * string | RTodo of path * string (** Events which occur during a test run *) type test_event = EStart of path | EEnd of path | EResult of test_result (** Perform the test, allows you to build your own test runner *) val perform_test : (test_event -> 'a) -> test -> test_result list (** A simple text based test runner. It prints out information during the test. @param verbose print verbose message *) val run_test_tt : ?verbose:bool -> test -> test_result list (** Main version of the text based test runner. It reads the supplied command line arguments to set the verbose level and limit the number of test to run. @param arg_specs add extra command line arguments @param set_verbose call a function to set verbosity @version 1.1.0 *) val run_test_tt_main : ?arg_specs:(Arg.key * Arg.spec * Arg.doc) list -> ?set_verbose:(bool -> unit) -> test -> test_result list Index: trunk/omega/src/format_Fortran.ml =================================================================== --- trunk/omega/src/format_Fortran.ml (revision 8806) +++ trunk/omega/src/format_Fortran.ml (revision 8807) @@ -1,289 +1,275 @@ (* format_Fortran.ml -- Fortran90+ continuation lines etc. Copyright (C) 2019-2022 by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let default_width = 80 let max_clines = ref (-1) (* 255 *) exception Continuation_Lines of int (* Fortran style line continuation: *) type formatter = { formatter : Format.formatter; mutable current_cline : int; mutable width : int } let formatter_of_formatter ?(width=default_width) ff = { formatter = ff; current_cline = 1; width = width } (* Default function to output new lines. *) let pp_output_function ff = fst (Format.pp_get_formatter_output_functions ff.formatter ()) (* Default function to output spaces (copied from \texttt{format.ml}). *) let blank_line = String.make 80 ' ' let rec pp_display_blanks ff n = if n > 0 then if n <= 80 then pp_output_function ff blank_line 0 n else begin pp_output_function ff blank_line 0 80; pp_display_blanks ff (n - 80) end let pp_display_newline ff = pp_output_function ff "\n" 0 1 (* [ff.current_cline] \begin{itemize} \item $\le0$: not continuing: print a straight newline, \item $>0$: continuing: append [" &"] until we run up to [!max_clines]. NB: [!max_clines < 0] means \emph{unlimited} continuation lines. \end{itemize} *) let pp_switch_line_continuation ff = function | false -> ff.current_cline <- 0 | true -> ff.current_cline <- 1 let pp_fortran_newline ff () = if ff.current_cline > 0 then begin if !max_clines >= 0 && ff.current_cline > !max_clines then raise (Continuation_Lines ff.current_cline) else begin pp_output_function ff " &" 0 2; ff.current_cline <- succ ff.current_cline end end; pp_display_newline ff let pp_newline ff () = pp_switch_line_continuation ff false; Format.pp_print_newline ff.formatter (); pp_switch_line_continuation ff true (* Make a formatter with default functions to output spaces and new lines. *) (*i let unsafe_output oc s i j = try output oc s i j with | _ -> Printf.eprintf "unsafe_output: '%s'\n" s i*) let pp_setup ff = - let out, flush = - Format.pp_get_formatter_output_functions ff.formatter () in - Format.pp_set_all_formatter_output_functions - ff.formatter ~out ~flush - ~newline:(pp_fortran_newline ff) ~spaces:(pp_display_blanks ff); + let formatter_out_functions = + Format.pp_get_formatter_out_functions ff.formatter () in + Format.pp_set_formatter_out_functions + ff.formatter + { formatter_out_functions with + out_newline = pp_fortran_newline ff; + out_spaces = pp_display_blanks ff }; Format.pp_set_margin ff.formatter (ff.width - 2) -(* This is bit of a headache, since [out_indent] was added to - [type formatter_out_functions] in version 4.06 in an incompatible - change. *) - -(*i - let setup width oc = - let formatter_out_functions = get_formatter_out_functions () in - set_formatter_out_functions - { formatter_out_functions with - out_string = output oc; - out_flush = (fun () -> flush oc); - out_newline = fortran_newline oc; - out_spaces = display_blanks oc }; - set_margin (width - 2) - i*) - let std_formatter = let ff = formatter_of_formatter Format.std_formatter in pp_setup ff; ff let formatter_of_out_channel ?(width=default_width) oc = let ff = formatter_of_formatter ~width (Format.formatter_of_out_channel oc) in pp_setup ff; ff let formatter_of_buffer ?(width=default_width) b = let ff = { formatter = Format.formatter_of_buffer b; current_cline = 1; width = width } in pp_setup ff; ff let pp_set_formatter_out_channel ff ?(width=default_width) oc = Format.pp_set_formatter_out_channel ff.formatter oc; ff.width <- width; pp_setup ff let set_formatter_out_channel ?(width=default_width) oc = Format.pp_set_formatter_out_channel std_formatter.formatter oc; std_formatter.width <- width; pp_setup std_formatter let fprintf ff fmt = Format.fprintf ff.formatter fmt let pp_flush ff = Format.pp_print_flush ff.formatter let printf fmt = fprintf std_formatter fmt let newline = pp_newline std_formatter let flush = pp_flush std_formatter let switch_line_continuation = pp_switch_line_continuation std_formatter module Test = struct open OUnit let input_line_opt ic = try Some (input_line ic) with | End_of_file -> None let read_lines ic = let rec read_lines' acc = match input_line_opt ic with | Some line -> read_lines' (line :: acc) | None -> List.rev acc in read_lines' [] let lines_of_file filename = let ic = open_in filename in let lines = read_lines ic in close_in ic; lines let equal_or_dump_lines lhs rhs = if lhs = rhs then true else begin Printf.printf "Unexpected output:\n"; List.iter (Printf.printf "< %s\n") lhs; List.iter (Printf.printf "> %s\n") rhs; false end let format_and_compare f expected () = bracket_tmpfile ~prefix:"omega-" ~suffix:".f90" (fun (name, oc) -> (* There can be something left in the queue from [OUnit]! *) Format.print_flush (); f oc; close_out oc; (* [OUnit] uses [Format.printf]! *) Format.set_formatter_out_channel stdout; assert_bool "" (equal_or_dump_lines expected (lines_of_file name))) () let suite = "Format_Fortran" >::: [ "formatter_of_out_channel" >:: format_and_compare (fun oc -> let ff = formatter_of_out_channel ~width:20 oc in let nl = pp_newline ff in List.iter (fprintf ff) ["@[<2>lhs = rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"]; nl ()) [ "lhs = rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs" ]; "formatter_of_buffer" >:: format_and_compare (fun oc -> let buffer = Buffer.create 1024 in let ff = formatter_of_buffer ~width:20 buffer in let nl = pp_newline ff in List.iter (fprintf ff) [" @[<2>lhs = rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"]; nl (); pp_flush ff (); let ff' = formatter_of_out_channel ~width:20 oc in fprintf ff' "do mu = 0, 3"; pp_newline ff' (); fprintf ff' "%s" (Buffer.contents buffer); fprintf ff' "end do"; pp_newline ff' ()) [ "do mu = 0, 3"; " lhs = rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs"; "end do" ]; "formatter_of_out_channel+indentation" >:: format_and_compare (fun oc -> let ff = formatter_of_out_channel ~width:20 oc in let nl = pp_newline ff in List.iter (fprintf ff) [" @[<4>lhs = rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"]; nl ()) [ " lhs = rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs" ]; "set_formatter_out_channel" >:: format_and_compare (fun oc -> let nl = newline in set_formatter_out_channel ~width:20 oc; List.iter printf ["@[<2>lhs = rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"]; nl ()) [ "lhs = rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs + rhs &"; " + rhs" ]; ] end