(* $Id: blender.ml,v 1.6 2003/06/28 06:10:31 yori Exp $ *)
(* Copyright 2002 Yamagata Yoriyuki *)
(* Copyright (c) 2001 Patrick Doane. *)

open Printf

(* global settings *)

let input_root  = ref "../"
let output_root = ref (".")
let verbose     = ref 2
let repetition = ref 10
let data_size = ref 5000
let handle_exception = ref true

(* utilities *)

let bracket
    (before : 'a -> 'b)
    (init : 'a) 
    (f : 'b -> 'c)
    (after : 'b -> unit) =
  let x = before init in
  let res =
    try f x with exn -> after x; raise exn
  in
  after x;
  res

(* directory management *)

let input_filename s  = Filename.concat !input_root s
let output_filename s = Filename.concat !output_root s

let read_file s f  = bracket open_in s f close_in
let write_file s f = bracket open_out s f close_out

let foreach_file dir ?(filter=(fun _ -> true)) f =
  bracket Unix.opendir dir (fun h ->
      try
        while true do
          let basename = Unix.readdir h in
          match basename with
          | "." | ".." -> ()
          | _ -> if filter basename then f basename
        done
      with End_of_file -> ()
    ) 
    Unix.closedir

(* test result codes *)

type result = 
  | Pass
  | UPass
  | Fail of string
  | XFail
  | Unresolved
  | Untested
  | Unsupported of string

let is_expected = function
  | Pass | XFail -> true
  | _ -> false

let to_string = function
  | Pass           -> "Pass"
  | UPass          -> "Unexpected Pass"
  | Fail ""        -> "Fail"
  | Fail m         -> "Fail - " ^ m
  | XFail          -> "Expected Fail"
  | Unresolved     -> "Unresolved"
  | Untested       -> "Untested"
  | Unsupported "" -> "Unsupported"
  | Unsupported m  -> "Unsupported - " ^ m

let count_pass         = ref 0
let count_upass        = ref 0
let count_fail         = ref 0
let count_xfail        = ref 0
let count_unresolved   = ref 0
let count_untested     = ref 0
let count_unsupported  = ref 0

let count_var = function
  | Pass          -> count_pass
  | UPass         -> count_upass
  | Fail _        -> count_fail
  | XFail         -> count_xfail
  | Unresolved    -> count_unresolved
  | Untested      -> count_untested
  | Unsupported _ -> count_unsupported

(* Tests *)

let do_test ~desc ~rep ~body =
  for _ = 1 to rep do
    let result = 
      if !handle_exception then
        try
          body ()
        with exn ->
          printf "  uncaught exception: %s\n" (Printexc.to_string exn);
          Unresolved
      else
        body ()
    in
    incr (count_var result);
    if not (is_expected result) || !verbose > 2 then begin
      printf "  %s: %s\n" (to_string result) desc;
      flush stdout
    end
  done

let repeat_test ~desc ~body = do_test ~desc ~rep:!repetition ~body

let test ~desc ~body = do_test ~desc ~rep:1 ~body

let random_test ~desc ~log ~data ~body =
  let count = ref 0 in
  let result = ref Unresolved in
  repeat_test ~desc ~body:(fun () ->
      bracket 
        data
        !data_size
        (fun data -> result := body data; !result)
        (fun data ->
           match !result with
             UPass | Fail _ | Unresolved ->
             let logname = 
               if !repetition = 1 then 
                 log 
               else 
                 log ^ "." ^ (string_of_int !count)
             in
             let c = open_out_bin (output_filename logname) in
             output_value c data;
             close_out c
           | _ -> ()))


(* Expect based testing *)

exception EFail of string

let fail m = raise (EFail m)

let expect_equal ?msg ?printer x y =
  if x=y then ()
  else match printer with
    | None ->
      fail (match msg with
          | None -> "not equal"
          | Some msg -> Lazy.force msg)
    | Some p ->
      let test_msg = match msg with None -> "" 
                                  | Some msg -> (Lazy.force msg) ^ " " in
      fail (sprintf "expected %s\n          but got %s\n    in test %s"
              (p x) (p y) test_msg)

let expect_equal_app ?msg ?printer f x g y =
  let test_msg = match msg with None -> "" 
                              | Some msg -> (Lazy.force msg) ^ " " in
  try
    let x' = f x in
    (try
       let y' = g y in
       expect_equal ?msg ?printer x' y'
     with 
     | EFail _ as exn -> raise exn
     | exn2 ->
       let exn2 = "exception " ^ (Printexc.to_string exn2) in
       match printer with
       | None ->
         fail (sprintf "unexpected %s\n    in test %s"
                 exn2 test_msg)
       | Some p ->
         fail (sprintf
                 "expected %s\n          but got %s\n    in test %s"
                 (p x') exn2 test_msg))
  with
  | EFail _ as exn -> raise exn
  | exn1 ->
    let exn1 = "exception " ^ (Printexc.to_string exn1) in
    (try
       let y' = g y in
       match printer with
       | None ->
         fail (sprintf
                 "expected %s\n          but got no exception\n    in test %s"
                 exn1 test_msg)
       | Some p ->
         fail (sprintf
                 "expected %s\n          but got %s\n    in test %s"
                 exn1 (p y') test_msg)
     with 
     | EFail _ as exn -> raise exn
     | exn2 ->
       let exn2 = "exception " ^ (Printexc.to_string exn2) in
       expect_equal ?msg ~printer:(fun s -> s) exn1 exn2)

let expect_true ?msg test =
  if test then ()
  else fail (match msg with None -> "" | Some m -> Lazy.force  m)

let expect_pass ~(body : unit -> unit) = 
  try body (); Pass with EFail m -> Fail m

let expect_fail ~(body : unit -> unit) = 
  try body (); UPass with EFail _ -> XFail

(* Front end *)

let day =   [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
let month = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; 
               "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]

let date_time () =
  let t = Unix.time () in
  let lt = Unix.localtime t in

  (* Generate date string *)
  Printf.sprintf "%s, %02d %s %d %02d:%02d:%02d"
    day.(lt.Unix.tm_wday)
    lt.Unix.tm_mday
    month.(lt.Unix.tm_mon)
    (1900 + lt.Unix.tm_year)
    lt.Unix.tm_hour
    lt.Unix.tm_min
    lt.Unix.tm_sec

let user () =
  (* [getlogin] can be unreliable on some systems so try to access
   * the password database first. *)
  try
    (Unix.getpwuid (Unix.getuid ())).Unix.pw_name
  with Not_found ->
  try
    Unix.getlogin ()
  with _ -> "unknown"

let header () =
  if !verbose > 1 then
    printf "\n-------------------------------------------------------------\n";
  if !verbose > 0 then
    printf "%s\n" Sys.executable_name;
  if !verbose > 1 then begin
    printf "-------------------------------------------------------------\n";
    printf "        user:  %s\n" (user ());
    printf "        time:  %s\n" (date_time ());
    printf "          os:  %s\n" Sys.os_type;
    printf "  input root:  %s\n" !input_root;
    printf " output root:  %s\n" !output_root;
    printf "-------------------------------------------------------------\n\n";
  end;
  flush stdout

let t0 = ref 0.0

let summary () =
  let count_review =
    !count_upass + !count_fail + !count_unresolved + !count_untested
  in
  if !verbose > 0 then
    begin
      let result count desc =
        printf "%4d %s\n" count desc
      in
      let cond_result count desc =
        if count > 0 || !verbose > 2 then result count desc
      in
      if !verbose > 1 then
        printf
          "\n-------------------------------------------------------------\n";
      printf "Summary:\n";
      result      !count_pass        "passed";
      cond_result !count_upass       "unexpectedly passed";
      cond_result !count_fail        "failed";
      cond_result !count_xfail       "failed as expected";
      cond_result !count_unresolved  "unresolved";
      cond_result !count_untested    "untested";
      cond_result !count_unsupported "unsupported";
      if !verbose > 1 then begin
        print_char '\n';
        result      count_review       "testcase(s) to review";
      end;
      if !verbose > 1 then begin
        print_char '\n';
        Printf.printf "The tests take %f seconds\n" ((Sys.time ()) -. !t0);
      end;
      printf
        "-------------------------------------------------------------\n\n";
      flush stdout;
    end;
  count_review

let _ = Arg.parse 
    [("--input",
      Arg.String ((:=) input_root),
      "<dir>\t\tspecify input root");

     ("--output",
      Arg.String ((:=) output_root),
      "<dir>\t\tspecify output root");

     ("--verbose",
      Arg.Int ((:=) verbose),
      "<level>\tset verbosity");

     ("--repetition", 
      Arg.Int ((:=) repetition),
      "<count>\trepeats tests");

     ("--datasize",
      Arg.Int ((:=) data_size),
      "<number>\tstandard size of random data");

     ("--handle-exception",
      Arg.Set handle_exception,
      "catch the uncaught exception");

     ("--throw-exception",
      Arg.Clear handle_exception,
      "throw the uncaught exception")

    ]
    (fun s -> raise (Arg.Bad (sprintf "Unexpected Argument %s" s)))
    ""

let _ = header ()

let main () =
  let count_review = summary () in
  exit (if count_review > 0 then 1 else 0)

let _ = t0 := Sys.time ()
