First negative tests for the old typer & improvement of error messages

src/bin/cli.ml

@@ -128,7 +128,7 @@ let compile_file =
     Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format $ michelson_code_format) in
   let cmdname = "compile-contract" in
   let doc = "Subcommand: compile a contract." in
-  (term , Term.info ~doc cmdname)
+  (Term.ret term , Term.info ~doc cmdname)
 
 let measure_contract =
   let f source_file entry_point syntax display_format  =
@@ -145,7 +145,7 @@ let measure_contract =
     Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format) in
   let cmdname = "measure-contract" in
   let doc = "Subcommand: measure a contract's compiled size in bytes." in
-  (term , Term.info ~doc cmdname)
+  (Term.ret term , Term.info ~doc cmdname)
 
 let compile_parameter =
   let f source_file entry_point expression syntax display_format michelson_format =
@@ -176,7 +176,7 @@ let compile_parameter =
     Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ display_format $ michelson_code_format) in
   let cmdname = "compile-parameter" in
   let doc = "Subcommand: compile parameters to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which calls a contract." in
-  (term , Term.info ~doc cmdname)
+  (Term.ret term , Term.info ~doc cmdname)
 
 let interpret =
   let f expression init_file syntax amount sender source display_format =
@@ -204,7 +204,7 @@ let interpret =
     Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ sender $ source $ display_format ) in
   let cmdname = "interpret" in
   let doc = "Subcommand: interpret the expression in the context initialized by the provided source file." in
-  (term , Term.info ~doc cmdname)
+  (Term.ret term , Term.info ~doc cmdname)
 
 
 let compile_storage =
@@ -236,7 +236,7 @@ let compile_storage =
     Term.(const f $ source_file 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ display_format $ michelson_code_format) in
   let cmdname = "compile-storage" in
   let doc = "Subcommand: compile an initial storage in ligo syntax to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which originates a contract." in
-  (term , Term.info ~doc cmdname)
+  (Term.ret term , Term.info ~doc cmdname)
 
 let dry_run =
   let f source_file entry_point storage input amount sender source syntax display_format =
@@ -267,7 +267,7 @@ let dry_run =
     Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ sender $ source $ syntax $ display_format) in
   let cmdname = "dry-run" in
   let doc = "Subcommand: run a smart-contract with the given storage and input." in
-  (term , Term.info ~doc cmdname)
+  (Term.ret term , Term.info ~doc cmdname)
 
 let run_function =
   let f source_file entry_point parameter amount sender source syntax display_format =
@@ -293,7 +293,7 @@ let run_function =
     Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ sender $ source $ syntax $ display_format) in
   let cmdname = "run-function" in
   let doc = "Subcommand: run a function with the given parameter." in
-  (term , Term.info ~doc cmdname)
+  (Term.ret term , Term.info ~doc cmdname)
 
 let evaluate_value =
   let f source_file entry_point amount sender source syntax display_format =
@@ -312,7 +312,7 @@ let evaluate_value =
     Term.(const f $ source_file 0 $ entry_point 1 $ amount $ sender $ source $ syntax $ display_format) in
   let cmdname = "evaluate-value" in
   let doc = "Subcommand: evaluate a given definition." in
-  (term , Term.info ~doc cmdname)
+  (Term.ret term , Term.info ~doc cmdname)
 
 let compile_expression =
   let f expression syntax display_format michelson_format =
@@ -331,7 +331,7 @@ let compile_expression =
     Term.(const f $ expression "" 1 $ req_syntax 0 $ display_format $ michelson_code_format) in
   let cmdname = "compile-expression" in
   let doc = "Subcommand: compile to a michelson value." in
-  (term , Term.info ~doc cmdname)
+  (Term.ret term , Term.info ~doc cmdname)
 
 let run ?argv () =
   Term.eval_choice ?argv main [

src/bin/cli_helpers.ml

@@ -1,9 +1,10 @@
+open Cmdliner
 open Trace
 open Main.Display
 
-let toplevel ~(display_format : display_format) (x : string result) =
+let toplevel ~(display_format : display_format) (x : string result) : unit Term.ret =
   match x with
-  | Ok _ -> Format.printf "%a%!" (formatted_string_result_pp display_format) x
+  | Ok _ -> Format.printf "%a%!" (formatted_string_result_pp display_format) x;
+            `Ok ()
   | Error _ ->
-     Format.eprintf "%a%!" (formatted_string_result_pp display_format) x ;
-     exit 1
+     `Error (false, Format.asprintf "%a%!" (formatted_string_result_pp display_format) x)

src/bin/cli_helpers.mli

@@ -1,3 +1,4 @@
+open Cmdliner
 open Trace
 
-val toplevel : display_format : Main.Display.display_format -> string result -> unit
+val toplevel : display_format : Main.Display.display_format -> string result -> unit Term.ret

src/bin/expect_tests/typer_error_tests.ml

@@ -0,0 +1,11 @@
+open Cli_expect
+
+let%expect_test _ =
+  run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_1.mligo" ; "foo" ] ;
+  [%expect {| ligo: in file "error_typer_1.mligo", line 3, characters 19-27. different type constructors: Expected these two constant type constructors to be the same, but they're different {"a":"string","b":"int"} |} ] ;
+
+  run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_2.mligo" ; "foo" ] ;
+  [%expect {| ligo: in file "error_typer_2.mligo", line 3, characters 24-39. different type constructors: Expected these two n-ary type constructors to be the same, but they're different {"a":"(TO_list(string))","b":"(TO_option(int))"} |} ] ;
+
+  (* run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_3.mligo" ; "foo" ] ;
+   * [%expect …some type error… ] ; *)

src/stages/ast_typed/misc.ml

@@ -12,16 +12,16 @@ module Errors = struct
     error ~data title message ()
 
   let different_constants a b () =
-    let title = (thunk "different type constants") in
-    let message () = "" in
+    let title = (thunk "different type constructors") in
+    let message () = "Expected these two constant type constructors to be the same, but they're different" in
     let data = [
       ("a" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant a) ;
       ("b" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant b )
     ] in
     error ~data title message ()
   let different_operators a b () =
-    let title = (thunk "different type operators") in
-    let message () = "" in
+    let title = (thunk "different type constructors") in
+    let message () = "Expected these two n-ary type constructors to be the same, but they're different" in
     let data = [
       ("a" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) a) ;
       ("b" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) b)
@@ -30,7 +30,7 @@ module Errors = struct
 
   let different_size_type name a b () =
     let title () = name ^ " have different sizes" in
-    let message () = "" in
+    let message () = "Expected these two types to be the same, but they're different (both are " ^ name ^ ", but with a different number of arguments)" in
     let data = [
       ("a" , fun () -> Format.asprintf "%a" PP.type_value a) ;
       ("b" , fun () -> Format.asprintf "%a" PP.type_value b )
@@ -46,7 +46,7 @@ module Errors = struct
     ] in
     error ~data title message ()
 
-  let _different_size_constants = different_size_type "constants"
+  let _different_size_constants = different_size_type "type constructors"
 
   let different_size_tuples = different_size_type "tuples"
 

src/stages/common/PP.ml

@@ -149,7 +149,7 @@ let rec type_expression' : type a . (formatter -> a -> unit) -> formatter -> a t
     | T_operator to_ -> type_operator f ppf to_
 
 and type_constant ppf (tc:type_constant) : unit =
-  let s = match tc with 
+  let s = match tc with
     | TC_unit      -> "unit"
     | TC_string    -> "string"
     | TC_bytes     -> "bytes"
@@ -165,7 +165,7 @@ and type_constant ppf (tc:type_constant) : unit =
     | TC_timestamp -> "timestamp"
     | TC_chain_id  -> "chain_id"
     in
-  fprintf ppf "(TC %s)" s
+  fprintf ppf "%s" s
 
 
 and type_operator : type a . (formatter -> a -> unit) -> formatter -> a type_operator -> unit =

src/test/contracts/error_typer_1.mligo

@@ -0,0 +1,3 @@
+type toto = int
+
+let foo : string = 42 + 127

src/test/contracts/error_typer_2.mligo

@@ -0,0 +1,3 @@
+type toto = int option
+
+let foo : string list = Some (42 + 127)

src/test/contracts/error_typer_3.mligo

@@ -0,0 +1,6 @@
+type toto = (int * string)
+
+let foo : (int * string * bool) = ((1, "foo") : toto)
+
+let main (p:int) (storage : int) =
+  (([] : operation list) , p + foo.0)