diff --git a/src/TODO.txt b/src/TODO.txt deleted file mode 100644 index 210cb0637..000000000 --- a/src/TODO.txt +++ /dev/null @@ -1,21 +0,0 @@ -# Main - -## Back-end - -- Replace Mini_c environments with stacks - + Compiler_environment : bad pack make first element deepest - + Add types to pack and unpack -- Think about Coq - -## Amendments - -- Bubble_n -- Partial application -- Type size limit (1.000 -> 10.000) - -# PPX - -## Deriving - -- Generate ADT helpers (this removes 90% of Combinators and a lot of maintenance when modifying ASTs) -- Generate option helpers (this makes writing main much easier, much like one would in an untyped language) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 86c5c9ea6..11777b504 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -1,41 +1,6 @@ open Cmdliner open Trace - -let error_pp out (e : error) = - let open JSON_string_utils in - let message = - let opt = e |> member "message" |> string in - let msg = Option.unopt ~default:"" opt in - if msg = "" - then "" - else ": " ^ msg in - let error_code = - let error_code = e |> member "error_code" in - match error_code with - | `Null -> "" - | _ -> " (" ^ (J.to_string error_code) ^ ")" in - let title = - let opt = e |> member "title" |> string in - Option.unopt ~default:"" opt in - let data = - let data = e |> member "data" in - match data with - | `Null -> "" - | _ -> " " ^ (J.to_string data) ^ "\n" in - let infos = - let infos = e |> member "infos" in - match infos with - | `Null -> "" - | _ -> " " ^ (J.to_string infos) ^ "\n" in - Format.fprintf out "%s%s%s.\n%s%s" title error_code message data infos - - -let toplevel x = - match x with - | Trace.Ok ((), annotations) -> ignore annotations; () - | Error ss -> ( - Format.printf "%a%!" error_pp (ss ()) - ) +open Cli_helpers let main = let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml new file mode 100644 index 000000000..068f2bf1d --- /dev/null +++ b/src/bin/cli_helpers.ml @@ -0,0 +1,9 @@ +open Trace + +let toplevel x = + match x with + | Trace.Ok ((), annotations) -> ignore annotations; () + | Error ss -> ( + Format.printf "%a%!" Ligo.Display.error_pp (ss ()) + ) + diff --git a/src/contracts/error_syntax.ligo b/src/contracts/error_syntax.ligo new file mode 100644 index 000000000..88deae01f --- /dev/null +++ b/src/contracts/error_syntax.ligo @@ -0,0 +1 @@ +type foo is bar - 42 \ No newline at end of file diff --git a/src/contracts/error_type.ligo b/src/contracts/error_type.ligo new file mode 100644 index 000000000..79e114388 --- /dev/null +++ b/src/contracts/error_type.ligo @@ -0,0 +1 @@ +const foo : nat = 42 + "bar" \ No newline at end of file diff --git a/src/dune b/src/dune index 19b622756..3fb9b193b 100644 --- a/src/dune +++ b/src/dune @@ -15,7 +15,7 @@ ) (alias -( name ligo-test) + (name ligo-test) (action (run test/test.exe)) (deps (glob_files contracts/*)) ) @@ -24,3 +24,9 @@ (name runtest) (deps (alias ligo-test)) ) + +(alias + (name manual-test) + (action (run test/manual_test.exe)) + (deps (glob_files contracts/*)) +) \ No newline at end of file diff --git a/src/main/display.ml b/src/main/display.ml new file mode 100644 index 000000000..a68999f28 --- /dev/null +++ b/src/main/display.ml @@ -0,0 +1,42 @@ +open Trace + +let error_pp out (e : error) = + let open JSON_string_utils in + let message = + let opt = e |> member "message" |> string in + match opt with + | Some msg -> ": " ^ msg + | None -> "" in + let error_code = + let error_code = e |> member "error_code" in + match error_code with + | `Null -> "" + | _ -> " (" ^ (J.to_string error_code) ^ ")" in + let title = + let opt = e |> member "title" |> string in + Option.unopt ~default:"" opt in + let data = + let data = e |> member "data" in + match data with + | `Null -> "" + | _ -> " " ^ (J.to_string data) ^ "\n" in + let infos = + let infos = e |> member "infos" in + match infos with + | `List lst -> lst + | `Null -> [] + | x -> [ x ] in + let location = + let opt = e |> member "data" |> member "location" |> string in + let aux prec cur = + match prec with + | None -> cur |> member "data" |> member "location" |> string + | Some s -> Some s + in + match List.fold_left aux opt infos with + | None -> "" + | Some s -> s ^ ". " + in + let print x = Format.fprintf out x in + print "%s%s%s%s%s" location title error_code message data + (* Format.fprintf out "%s%s%s.\n%s%s" title error_code message data infos *) diff --git a/src/main/main.ml b/src/main/main.ml index b24f522d4..1c4afcd58 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -16,6 +16,8 @@ module Run = struct include Run_mini_c end +module Display = Display + (* module Parser_multifix = Multifix * module Simplify_multifix = Simplify_multifix *) diff --git a/src/test/dune b/src/test/dune index 03a15c2e9..aebc6fad9 100644 --- a/src/test/dune +++ b/src/test/dune @@ -1,5 +1,5 @@ -(executable - (name test) +(executables + (names test manual_test) (libraries simple-utils ligo diff --git a/src/test/manual_test.ml b/src/test/manual_test.ml new file mode 100644 index 000000000..fdf8d4d8d --- /dev/null +++ b/src/test/manual_test.ml @@ -0,0 +1,17 @@ +open Trace +open Ligo.Run +open Test_helpers + +let syntax_error () : unit result = + let%bind _program = type_file `pascaligo "./contracts/error_syntax.ligo" in + ok () + +let type_error () : unit result = + let%bind _program = type_file `pascaligo "./contracts/error_type.ligo" in + ok () + +let () = + List.iter wrap_test_raw [ + type_error ; + syntax_error ; + ] diff --git a/src/test/test.ml b/src/test/test.ml index 05db3980f..a3709700e 100644 --- a/src/test/test.ml +++ b/src/test/test.ml @@ -2,45 +2,6 @@ open Test_helpers -let rec test_height : test -> int = fun t -> - match t with - | Test _ -> 1 - | Test_suite (_ , lst) -> (List.fold_left max 1 @@ List.map test_height lst) + 1 - -let extract_test : test -> test_case = fun t -> - match t with - | Test tc -> tc - | _ -> assert false - -let extract_param : test -> (string * (string * test_case list) list) = - let extract_element = extract_test in - let extract_group : test -> (string * test_case list) = fun t -> - match t with - | Test tc -> ("isolated" , [ tc ]) - | Test_suite (name , lst) -> (name , List.map extract_element lst) in - fun t -> - match t with - | Test tc -> ("" , [ ("isolated" , [ tc ] ) ]) - | Test_suite (name , lst) -> (name , List.map extract_group lst) - -let x : _ -> (unit Alcotest.test) = fun x -> x - -(* - Alcotest.run parameters: - string * (string * f list) list -*) - -let rec run_test ?(prefix = "") : test -> unit = fun t -> - match t with - | Test case -> Alcotest.run "isolated test" [ ("" , [ case ]) ] - | Test_suite (name , lst) -> ( - if (test_height t <= 3) then ( - let (name , tests) = extract_param t in - Alcotest.run (prefix ^ name) tests - ) else ( - List.iter (run_test ~prefix:(prefix ^ name ^ "_")) lst - ) - ) let () = (* Printexc.record_backtrace true ; *) diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 60da8f999..071f8b271 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -5,53 +5,61 @@ type test = | Test_suite of (string * test list) | Test of test_case -let rec error_pp out (e : error) = - let open JSON_string_utils in - let message = - let opt = e |> member "message" |> string in - let msg = Option.unopt ~default:"" opt in - if msg = "" - then "" - else ": " ^ msg in - let error_code = - let error_code = e |> member "error_code" in - match error_code with - | `Null -> "" - | _ -> " (" ^ (J.to_string error_code) ^ ")" in - let title = - let opt = e |> member "title" |> string in - Option.unopt ~default:"" opt in - let data = - let data = e |> member "data" in - match data with - | `Null -> "" - | _ -> " " ^ (J.to_string data) ^ "\n" in - let infos = - let infos = e |> member "infos" in - match infos with - | `Null -> "" - | `List lst -> Format.asprintf "@[%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst - | _ -> " " ^ (J.to_string infos) ^ "\n" in - let children = - let children = e |> member "children" in - match children with - | `Null -> "" - | `List lst -> Format.asprintf "@[%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst - | _ -> " " ^ (J.to_string children) ^ "\n" in - Format.fprintf out "%s%s%s.\n%s%s%s" title error_code message data infos children +let wrap_test name f = + let result = + trace (error (thunk "running test") (thunk name)) @@ + f () in + match result with + | Ok ((), annotations) -> ignore annotations; () + | Error err -> + Format.printf "%a\n%!" Ligo.Display.error_pp (err ()) ; + raise Alcotest.Test_error +let wrap_test_raw f = + match f () with + | Trace.Ok ((), annotations) -> ignore annotations; () + | Error err -> + Format.printf "%a\n%!" Ligo.Display.error_pp (err ()) + +(* let rec error_pp out (e : error) = + * let open JSON_string_utils in + * let message = + * let opt = e |> member "message" |> string in + * let msg = Option.unopt ~default:"" opt in + * if msg = "" + * then "" + * else ": " ^ msg in + * let error_code = + * let error_code = e |> member "error_code" in + * match error_code with + * | `Null -> "" + * | _ -> " (" ^ (J.to_string error_code) ^ ")" in + * let title = + * let opt = e |> member "title" |> string in + * Option.unopt ~default:"" opt in + * let data = + * let data = e |> member "data" in + * match data with + * | `Null -> "" + * | _ -> " " ^ (J.to_string data) ^ "\n" in + * let infos = + * let infos = e |> member "infos" in + * match infos with + * | `Null -> "" + * | `List lst -> Format.asprintf "@[%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst + * | _ -> " " ^ (J.to_string infos) ^ "\n" in + * let children = + * let children = e |> member "children" in + * match children with + * | `Null -> "" + * | `List lst -> Format.asprintf "@[%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst + * | _ -> " " ^ (J.to_string children) ^ "\n" in + * Format.fprintf out "%s%s%s.\n%s%s%s" title error_code message data infos children *) let test name f = Test ( Alcotest.test_case name `Quick @@ fun () -> - let result = - trace (fun () -> error (thunk "running test") (thunk name) ()) @@ - f () in - match result with - | Ok ((), annotations) -> ignore annotations; () - | Error err -> - Format.printf "Errors : {\n%a}\n%!" error_pp (err ()) ; - raise Alcotest.Test_error + wrap_test name f ) let test_suite name lst = Test_suite (name , lst) @@ -152,3 +160,44 @@ let expect_eq_n_int a b c = let expect_eq_b_bool a b c = let open Ast_simplified.Combinators in expect_eq_b a b (fun bool -> e_bool (c bool)) + + +let rec test_height : test -> int = fun t -> + match t with + | Test _ -> 1 + | Test_suite (_ , lst) -> (List.fold_left max 1 @@ List.map test_height lst) + 1 + +let extract_test : test -> test_case = fun t -> + match t with + | Test tc -> tc + | _ -> assert false + +let extract_param : test -> (string * (string * test_case list) list) = + let extract_element = extract_test in + let extract_group : test -> (string * test_case list) = fun t -> + match t with + | Test tc -> ("isolated" , [ tc ]) + | Test_suite (name , lst) -> (name , List.map extract_element lst) in + fun t -> + match t with + | Test tc -> ("" , [ ("isolated" , [ tc ] ) ]) + | Test_suite (name , lst) -> (name , List.map extract_group lst) + +let x : _ -> (unit Alcotest.test) = fun x -> x + +(* + Alcotest.run parameters: + string * (string * f list) list +*) + +let rec run_test ?(prefix = "") : test -> unit = fun t -> + match t with + | Test case -> Alcotest.run "isolated test" [ ("" , [ case ]) ] + | Test_suite (name , lst) -> ( + if (test_height t <= 3) then ( + let (name , tests) = extract_param t in + Alcotest.run (prefix ^ name) tests + ) else ( + List.iter (run_test ~prefix:(prefix ^ name ^ "_")) lst + ) + ) diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index bd6b598d7..d183f38d4 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -211,7 +211,10 @@ end (* end Trace_tutorial. *) module J = Yojson.Basic module JSON_string_utils = struct - let member = J.Util.member + let member = fun n x -> + match x with + | `Null -> `Null + | x -> J.Util.member n x let string = J.Util.to_string_option let to_list_option = fun x -> try ( Some (J.Util.to_list x))