Stefan pushed to branch main at Stefan / Typer

Commits: 525e358e by Simon Génier at 2022-08-28T22:37:40-04:00 Add a test for type ascription.

Also improve how discrepancies in sexp tests are reported.

- - - - -

3 changed files:

- src/fmt.ml - tests/sexp_test.ml - tests/utest_lib.ml

Changes:

===================================== src/fmt.ml ===================================== @@ -67,12 +67,19 @@ let print_ct_tree i = loop 0

(* Colors *) -let red = "\x1b[31m" -let green = "\x1b[32m" -let yellow = "\x1b[33m" -let magenta = "\x1b[35m" -let cyan = "\x1b[36m" -let reset = "\x1b[0m" +let red_f : _ format6 = "\x1b[31m" +let green_f : _ format6 = "\x1b[32m" +let yellow_f : _ format6 = "\x1b[33m" +let magenta_f : _ format6 = "\x1b[35m" +let cyan_f : _ format6 = "\x1b[36m" +let reset_f : _ format6 = "\x1b[0m" + +let red = string_of_format red_f +let green = string_of_format green_f +let yellow = string_of_format yellow_f +let magenta = string_of_format magenta_f +let cyan = string_of_format cyan_f +let reset = string_of_format reset_f

let color_string color str = color ^ str ^ reset

===================================== tests/sexp_test.ml ===================================== @@ -1,3 +1,32 @@ +(* + * Typer Compiler + * + * --------------------------------------------------------------------------- + * + * Copyright (C) 2016-2022 Free Software Foundation, Inc. + * + * This file is part of Typer. + * + * Typer 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 3 of the License, or (at your option) any + * later version. + * + * Typer 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, see http://www.gnu.org/licenses/. + * + * --------------------------------------------------------------------------- + * + * Description: + * utest library utility. Tests register themselves + * + * --------------------------------------------------------------------------- *) + open Typerlib

open Sexp @@ -30,16 +59,14 @@ let _ = test_sexp_add "x * x * x" (fun ret -> | _ -> failure )

-let test_sexp_eqv dcode1 dcode2 = - add_test "SEXP" dcode1 - (fun () -> - let s1 = sexp_parse_str dcode1 in - let s2 = sexp_parse_str dcode2 in - if sexp_eq_list s1 s2 - then success - else (sexp_print (List.hd s1); - sexp_print (List.hd s2); - failure)) +let test_sexp_eqv ?name actual_source expected_source = + let test () = + let actual = sexp_parse_str actual_source in + let expected = sexp_parse_str expected_source in + expect_equal_sexps ~actual ~expected + in + let name = Option.value ~default:actual_source name in + add_test "SEXP" name test

let _ = test_sexp_eqv "((a) ((1.00)))" "a 1.0" let _ = test_sexp_eqv "(x + y)" "_+_ x y" @@ -52,5 +79,11 @@ let _ = test_sexp_eqv "a\b\c" "abc" let _ = test_sexp_eqv "(a;b)" "(_\;_ a b)" let _ = test_sexp_eqv "a.b.c . (.)" "(__\.__ (__\.__ a b) c) \. \."

+let _ = + test_sexp_eqv + ~name:"Type ascription in declaration" + "x = 4 : Int" + "(_=_ x (_:_ 4 Int))" + (* run all tests *) let _ = run_all ()

===================================== tests/utest_lib.ml ===================================== @@ -3,7 +3,7 @@ * * --------------------------------------------------------------------------- * - * Copyright (C) 2011-2018 Free Software Foundation, Inc. + * Copyright (C) 2011-2022 Free Software Foundation, Inc. * * Author: Pierre Delaunay pierre.delaunay@hec.ca * Keywords: languages, lisp, dependent types. @@ -138,6 +138,50 @@ let expect_equal_values = _expect_equal_t Env.value_eq_list print_value_list let expect_equal_lexp = _expect_equal_t Lexp.eq Lexp.lexp_string let expect_conv_lexp ctx = _expect_equal_t (Opslexp.conv_p ctx) Lexp.lexp_string

+let expect_equal_sexps ~expected ~actual = + let print_sexp_ok s = + Printf.printf (green_f ^^ "%s" ^^ reset_f ^^ "\n") (Sexp.sexp_string s) + in + + let print_sexp_err expected actual = + Printf.printf + ("Expected:\n" ^^ red_f ^^ "%s\n" ^^ reset_f) + (Sexp.sexp_string expected); + Printf.printf + ("Actual:\n" ^^ red_f ^^ "%s\n" ^^ reset_f) + (Sexp.sexp_string actual) + in + + let rec loop failed fine expected actual = + match expected, actual with + | l :: ll, r :: rr -> + if Sexp.sexp_equal l r + then loop failed (l :: fine) ll rr + else + (List.iter print_sexp_ok fine; + print_sexp_err l r; + loop true [] ll rr) + | _ :: _, [] -> + List.iter print_sexp_ok fine; + Printf.printf ("Missing sexps:\n" ^^ red_f); + List.iter (fun s -> s |> Sexp.sexp_string |> Printf.printf "%s\n") expected; + Printf.printf reset_f; + true + | [], _ :: _ -> + List.iter print_sexp_ok fine; + Printf.printf ("Unexpected sexps:\n" ^^ red_f); + List.iter (fun s -> s |> Sexp.sexp_string |> Printf.printf "%s\n") actual; + Printf.printf reset_f; + true + | [], [] -> + if failed + then List.iter print_sexp_ok fine; + failed + in + if loop false [] expected actual + then failure + else success + let expect_equal_lexps = let rec lexp_list_eq l r = match l, r with

View it on GitLab: https://gitlab.com/monnier/typer/-/commit/525e358e957c39ca1acdd429cd978d3618...