simba-test/test.sml

(* * * * test.sml * * * *
 *
 * Small testing framework especially made for the Compiler course at Aarhus
 * University.
 *
 * Should work on must systems where the compiler itself works.  The VM should
 * work, so should macOS and Arch Linux. TODO investigate.
 *
 * * Instructions * *
 *
 *  0. Copy this file into the compiler source directory.
 *  1. Add any test files to the test directory.
 *  2. Compile the compiler using `make sa ia` or similar.
 *  3. Load the test framework with `use "test.sml";` in the interactive prompt.
 *  4. Run tests with `Testing.perform_all_tests();` in the interactive prompt.
 *
 *  Alternatively to `Testing.perform_all_tests: unit -> unit`, one can use
 *  `Testing.perform_tests: string -> unit`, which will only run tests with the
 *  given prefix.
 *
 * * Test types * *
 *
 * Must be located in the source directory of the relevant assignment. There
 * must be a subdirectory with the name of `tests`, with the relevant files.
 * The framework supports a large variety of test types:
 *
 * - *Basic Tiger tests*: Anything of the format `test_*.tig`. First line must
 *   indicate what the expected output is:
 *
 *   * `/* output: x */` will indicate that the status code returned by the
 *     Tiger program must be `x`. These values must be in the range [0, 255]!
 *   * `/* print: |x| */` will indicate that the program must return errno 0,
 *     and must print the string `x`. `x` must not contain `|`, newlines, or
 *     certain other characters.
 *   * `/* nothing */` will indicate that the program must compile and run.
 *   * Anything else will result in a test that only expects to be compilable.
 *     Such a file will never be run.
 *
 * - *Counterexample tests*: Sometimes you might want to test that something
 *   is caught by the compiler. Of the format `test_x_*.tig`. Useful for
 *   Lexing, Parsing and Semant stages.
 *
 * The framework ignores any file not matching any of the above requirements.
 * NOTE: All files must start with `test_`.
 *
 * Any slow tests can be renamed to `test_z_*`, and it'll be sorted last in the
 * list.
 *
 * Please note that tests without any specified status codes are assumed to
 * exit with a status of `0`.
 *
 * * Advanced usage * *
 *
 * TODO: Error numbers
 *
 * * Bugs * *
 *
 * Hard to escape SML once the testing has begun, as sigINT failes to trigger.
 *
 * * License * *
 *
 * Originally made by Jon Michael Aanes
 * You are free to do whatever you want with it.
 *
 *)

(* API *)

signature TESTING =
sig

  (* Running tests *)
  val perform_tests     : string -> unit;
  val perform_all_tests : unit   -> unit;

end

(* Structure *)

structure Testing :> TESTING =
struct

(* Option constants *)

val TEST_DIR       = "./tests/"
val TIGERC_PREFIX  = ""  (*TEST_DIR*)
val TIGERC_POSTFIX = ""  (*".tig"*)

(* Error constant *)

val num_errors  =  ref 0

(* General utility *)

infix ~>;

fun (input: 'a) ~> (func : 'a -> 'b) =
  func input;

(* Test Types *)

datatype testType = IgnoreTest
                  | FailingTest
                  | CompileTest

                  (* Generic run test *)
                  | RunableTest     of int option * string option


(* I/O utility -------------------------------------------------------------- *)

fun escape_command command = command
                          ~> explode
                          ~> map (valOf o String.fromString o Char.toString)
                          ~> map (fn s => if s = "\"" then "\\\"" else s)
                          ~> String.concat

fun sys_run command  =  OS.Process.system ( "/bin/bash -c \""
                                          ^ escape_command command
                                          ^ "\"")

fun read_entire_file filename : string =
  let val ins         = TextIO.openIn filename
      val entire_str  = (String.toString o TextIO.inputAll) ins
  in
      (TextIO.closeIn ins; entire_str)
  end;

fun write_file filename (content : string) =
    let val fd  =  TextIO.openOut filename
        val _   =  TextIO.output (fd, content)
                   handle e => (TextIO.closeOut fd; raise e)
        val _   =  TextIO.closeOut fd
    in () end

fun compile_test (testname:string) (test_bin_file:string) (tmpfile:string) =
  let val compile_result  = sys_run ( "./tigerc "
                                    ^ TIGERC_PREFIX
                                    ^ testname
                                    ^ TIGERC_POSTFIX(*" --out "
                                    ^ test_bin_file*)
                                    ^ " &> "
                                    ^ tmpfile)

  (* Ensure file was actually compiled, clang is cheaty *)
  in if   compile_result <> 0
     then compile_result
     else if (not o OS.FileSys.access) (test_bin_file, [])
           then 8
           else 0
  end

fun run_test binfile tmpfile =
  sys_run ( "ulimit -v 1086373952; "
          ^ binfile
          ^ " &> "
          ^ tmpfile )

fun files_in_folder (foldername: string) : string list =
  let fun helper stream a  =
    let val filename = OS.FileSys.readDir stream
    in case filename
         of NONE    => ( OS.FileSys.closeDir
                       ; ListMergeSort.sort String.> a )
          | SOME(b) => helper stream (b::a)
    end
  in helper (OS.FileSys.openDir foldername) []
  end;


(* User "display" ----------------------------------------------------------- *)

fun repeat_str str amount =
  (String.concat (List.tabulate (amount, fn _ => str)))

fun displ_current_test (status:string) (testname:string) =
    let val whitespace = Int.max(0, 5 - String.size status)
    in  print ("\r["^status^"]"^repeat_str " " whitespace^"Test `" ^ testname ^ "`")
    end

fun displ_result (testname:string) (expect_gotten_type_ls: (string * string * string) list) : bool =
    case List.filter (fn (a, b, _) => a <> b) expect_gotten_type_ls
     of [] => ( print ("\r[\027[32;1mOK\027[0m]   Test `" ^ testname ^ "`\n")
              ; true )
      | ls => let fun display_error (expected, gotten, type_of_expect) =
                        type_of_expect
                      ^ " should be "
                      ^ (case expected of "" => "empty string" | _ => "\027[35m" ^ expected)
                      ^ "\027[0m but was "
                      ^ (case gotten of "" => "empty string" | _ => "\027[35m" ^ gotten)
                      ^ "\027[0m"
                  val test_prefix = "\r[\027[31;1mFAIL\027[0m] Test `"
                                  ^ testname
                                  ^ "` "
                  val indent_amount = 7+4+2+2+String.size testname
              in ( num_errors := !num_errors + 1
                 ; print ( test_prefix
                         ^ String.concatWith ("\n"^repeat_str " " indent_amount)
                                             (map display_error ls)
                         ^ "\n")
                 ; false )
              end


fun framework_error s =
    print ("[\027[31;1m[TESTING FRAMEWORK]: Error, "^s^"\027[0m\n");

(* Perform testing ---------------------------------------------------------- *)

fun runTest (testname:string) (IgnoreTest) : bool = false

   | runTest testname (testT as (RunableTest _ | FailingTest | CompileTest)) =
     let val _ = displ_current_test "comp" testname
         val tmpfile  = OS.FileSys.tmpName ()
         val binfile  = "./out/"^testname^".bin" (*OS.FileSys.tmpName ()*)
         val compiled = compile_test testname binfile tmpfile
         val _        = displ_current_test "test" testname

     in case (testT, compiled = 0, compiled = 7 orelse compiled = 0)
          of (_, _, false)               => ( num_errors := !num_errors + 1
                                            ; print ("\r[\027[31;1mFATA\027[0m] Test `" ^ testname ^ "` produced error code \027[35m"^Int.toString compiled^"\027[0m, which means that something terrible has happended:\n"^(valOf o String.fromString o read_entire_file) tmpfile^"\n")
                                            ; false )
           | (FailingTest, true, _)      => ( num_errors := !num_errors + 1
                                            ; print ("\r[\027[31;1mFAIL\027[0m] Test `" ^ testname ^ "`. \027[31mTest successedede when it should not have.\027[0m\n")
                                            ; false )
           | (FailingTest, false, _)     => displ_result testname [("","", "correct")]
           | (_, false, _)               => ( num_errors := !num_errors + 1
                                            ; print ("\r[\027[31;1mFAIL\027[0m] Test `" ^ testname ^ "`. \027[31mTest did not compile!\027[0m\n\n"^(valOf o String.fromString o read_entire_file) tmpfile^"\n")
                                            ; false )

           | (RunableTest(status_expected, output_expected), true, _) =>
               let val status = run_test binfile tmpfile

                   val expect_gotten_status  =
                      case status_expected
                        of NONE          => []
                         | SOME status_e => [(Int.toString status_e, Int.toString status, "status")]

                   val expect_gotten_output =
                      case output_expected
                        of NONE => []
                         | SOME output_e => [(output_e, read_entire_file tmpfile, "print output")]

               in displ_result testname (expect_gotten_status@expect_gotten_output)
               end

           | (CompileTest,      true, _) => displ_result testname [("","", "correct")]
           | _ =>
             ( num_errors := !num_errors + 1
             ; print ("\r[\027[31;1mFAIL\027[0m] Test `" ^ testname ^ "`. \027[31mTest had an unknown type!\n")
             ; false )
     end

(* File parsing util -------------------------------------------------------- *)

val is_tig_file          =  String.isSuffix ".tig"
val is_failing_test_file =  String.isPrefix (TEST_DIR^"test_x_")

fun skip_ws (SOME (#" " ::ls)) = skip_ws (SOME ls)
  | skip_ws (SOME (#"\n"::ls)) = skip_ws (SOME ls)
  | skip_ws (SOME (#"\t"::ls)) = skip_ws (SOME ls)
  | skip_ws no_matched         = no_matched

fun skip_chars (ac::als) (SOME (bc::bls)) =
    if ac = bc
    then skip_chars als (SOME bls)
    else NONE
  | skip_chars ls (SOME []) = NONE
  | skip_chars [] (SOME ls) = SOME ls
  | skip_chars skip_chars NONE = NONE

fun skip_string str chars =
  skip_chars (String.explode str) chars

fun parse_integer NONE: int option = NONE
  | parse_integer (SOME chars) =
    let fun recu (chars,rev_output) =
          case chars
           of (digit as ((#"0")|(#"1")|(#"2")|(#"3")|(#"4")|(#"5")|(#"6")|(#"7")|(#"8")|(#"9")))::chars =>
                recu (chars, digit::rev_output)
            | _            => List.rev rev_output
    in (Int.fromString o String.implode o recu) (chars, [])
    end;

fun parse_until_char c NONE: string option = NONE
  | parse_until_char c (SOME chars) =
    let fun recu (head::chars, rev_output) =
            if head = c
            then rev_output
            else recu(chars, head::rev_output)
          | recu ([], rev_output) = rev_output
    in (SOME o String.implode o List.rev o recu) (chars, [])
    end;

fun parse_test_info_comment filename (chars: char list) =
  case (chars
            ~> SOME
            ~> skip_ws
            ~> skip_string "/*"
            ~> skip_ws)

     of SOME ((#"o")::(#"u")::(#"t")::(#"p")::(#"u")::(#"t")::(#":")::chars) =>
          (case ( parse_integer
                o skip_ws
                o SOME) chars

            of SOME a => if 0 <= a andalso a < 256
                         then RunableTest(SOME a, NONE)
                         else ( framework_error ("Status test "^filename^" wanted status code "^Int.toString a^", but only integers from 0 to 255 are allowed; ignoring.")
                              ; IgnoreTest)
             | _      => ( framework_error ("Could not find expected status code for test "^filename^"; ignoring.")
                         ; IgnoreTest ))

      | SOME ((#"p")::(#"r")::(#"i")::(#"n")::(#"t")::(#":")::chars) =>
          (case (parse_until_char #"|"
               o skip_chars [#"|"]
               o skip_ws
               o SOME) chars
            of SOME s => RunableTest(SOME 0, SOME s)
             | NONE   => ( framework_error ("Could not determine expected string output for "^filename^"; ignoring.")
                         ; IgnoreTest))

      | SOME((#"n")::(#"o")::(#"t")::(#"h")::(#"i")::(#"n")::(#"g")::_) =>
          RunableTest (NONE, NONE)

      | _ => CompileTest

fun determine_expected_result filename : testType =
  let val ins       = TextIO.openIn filename
      val chars     = (String.explode o String.toString o TextIO.inputAll) ins before TextIO.closeIn ins
  in if is_failing_test_file filename
     then FailingTest
     else parse_test_info_comment filename chars
  end;

(* Application stuff -------------------------------------------------------- *)

fun stop_running_tests () =
    if !num_errors = 0 then
        (print "\n\n[\027[32;1mSuccess, well done!\027[0m]")
    else
        (print ("\n\n[\027[31;1mFound "^Int.toString (!num_errors)^" failing tests\027[0m]"))

fun sigint_handler (signal, times_signaled, continue) =
  ( print ("\n[TESTING FRAMEWORK]: Got SIGINT, will attempt exit!\n")
  ; stop_running_tests ()
  ; continue );

fun find_all_tests (required_prefix: string) =
  let
      (* Find all test files *)
      val files_in_test_folder  =  (files_in_folder TEST_DIR)
                               ~> List.filter (String.isPrefix "test_")

      (* Find .tig tests: `test_*.tig` *)
      val testlist_tig  = files_in_test_folder
                       ~> List.filter is_tig_file
                       ~> map (fn f => (substring (f, 0, (size f - 4))))

                       ~> map (fn f => (f, determine_expected_result (TEST_DIR ^ f ^ ".tig")))
                       ~> List.filter (fn (_, r) => r <> IgnoreTest)

  in List.filter (String.isPrefix required_prefix o #1)
                 testlist_tig
  end

fun perform_tests (required_prefix: string) =
  let fun run_test (filename, expected_result): unit =
          ( ErrorMsg.reset
          ; runTest filename expected_result
          ; () )

  in ( print "\n## Custom Tests ##\n\n"
     ; Signals.setHandler (Signals.sigINT, Signals.HANDLER sigint_handler)
     ; required_prefix ~> find_all_tests
                       ~> map run_test
     ; print "\n\n"
     ; stop_running_tests() )
  end;

fun perform_all_tests () = perform_tests ""

end