add manual tests; change display of errors; minor refactorings

src/TODO.txt

@@ -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)

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

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 ())
+    )
+

src/contracts/error_syntax.ligo

@@ -0,0 +1 @@
+type foo is bar - 42

src/contracts/error_type.ligo

@@ -0,0 +1 @@
+const foo : nat = 42 + "bar"

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/*))  
+)

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 *)

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 *)
 

src/test/dune

@@ -1,5 +1,5 @@
-(executable
-  (name test)
+(executables
+  (names test manual_test)
   (libraries
     simple-utils
     ligo

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 ;
+  ]

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 ; *)

src/test/test_helpers.ml

@@ -5,47 +5,26 @@ 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 "@[<v2>%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst
-    | _ -> " " ^ (J.to_string infos) ^ "\n" in
-  Format.fprintf out "%s%s%s.\n%s%s" title error_code message data infos
-
+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 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)
@@ -135,3 +114,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
+      )
+    )

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))