diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 13cb7f761..6ab46b7f6 100644 --- a/src/bin/cli.ml +++ b/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 [ diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml index cb25dd084..34a4834a1 100644 --- a/src/bin/cli_helpers.ml +++ b/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) diff --git a/src/bin/cli_helpers.mli b/src/bin/cli_helpers.mli index e3e57f0a5..f19e281a9 100644 --- a/src/bin/cli_helpers.mli +++ b/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 diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml new file mode 100644 index 000000000..5a407316f --- /dev/null +++ b/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… ] ; *) diff --git a/src/passes/1-parser/dune b/src/passes/1-parser/dune index 9a4f86a94..8e478b392 100644 --- a/src/passes/1-parser/dune +++ b/src/passes/1-parser/dune @@ -12,5 +12,5 @@ (preprocess (pps ppx_let) ) - (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared )) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared)) ) diff --git a/src/passes/1-parser/reasonligo.ml b/src/passes/1-parser/reasonligo.ml index 8fafc5c95..a3b52b110 100644 --- a/src/passes/1-parser/reasonligo.ml +++ b/src/passes/1-parser/reasonligo.ml @@ -22,7 +22,18 @@ let parse_file (source: string) : AST.t result = let lexbuf = Lexing.from_channel channel in let Lexer.{read ; close ; _} = Lexer.open_token_stream None in - specific_try (function + specific_try (function + | SyntaxError.Error WrongFunctionArguments -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Incorrect function arguments at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str | Parser.Error -> ( let start = Lexing.lexeme_start_p lexbuf in let end_ = Lexing.lexeme_end_p lexbuf in diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly index c91cd352e..444d12212 100644 --- a/src/passes/1-parser/reasonligo/Parser.mly +++ b/src/passes/1-parser/reasonligo/Parser.mly @@ -388,30 +388,14 @@ type_expr_simple_args: par(nsepseq(type_expr_simple, ",")) { $1 } type_expr_simple: - core_expr_2 type_expr_simple_args? { + type_name type_expr_simple_args? { let args = $2 in - let constr = - match $1 with - EVar i -> i - | EProj {value={struct_name; field_path; _}; region} -> - let app a = function - FieldName v -> a ^ "." ^ v.value - | Component {value = c, _; _} -> a ^ "." ^ c in - let value = - Utils.nsepseq_foldl app struct_name.value field_path - in {region; value} - | EArith Mutez r | EArith Int r | EArith Nat r -> - {r with value = fst r.value} - | EString String s -> s - | ELogic BoolExpr (True t) -> {region=t; value="true"} - | ELogic BoolExpr (False f) -> {region=f; value="false"} - | _ -> failwith "Not supported" (* TODO: raise a proper exception *) - in match args with - Some {value; _} -> - let region = cover (expr_to_region $1) value.rpar in - let value = constr, {region; value} - in TApp {region; value} - | None -> TVar constr + match args with + Some {value; _} -> + let region = cover $1.region value.rpar in + let value = $1, {region; value} + in TApp {region; value} + | None -> TVar $1 } | "(" nsepseq(type_expr_simple, ",") ")" { TProd {region = cover $1 $3; value=$2} @@ -440,8 +424,8 @@ fun_expr: {p.value with inside = arg_to_pattern p.value.inside} in PPar {p with value} | EUnit u -> PUnit u - | _ -> failwith "Not supported" in (* TODO: raise a proper exception *) - + | _ -> raise (SyntaxError.Error WrongFunctionArguments) + in let fun_args_to_pattern = function EAnnot { value = { @@ -469,8 +453,8 @@ fun_expr: in arg_to_pattern (fst fun_args), bindings | EUnit e -> arg_to_pattern (EUnit e), [] - | _ -> failwith "Not supported" in (* TODO: raise a proper exception *) - + | _ -> raise (SyntaxError.Error WrongFunctionArguments) + in let binders = fun_args_to_pattern $1 in let f = {kwd_fun; binders; diff --git a/src/passes/1-parser/shared/SyntaxError.ml b/src/passes/1-parser/shared/SyntaxError.ml new file mode 100644 index 000000000..a0faa0bbb --- /dev/null +++ b/src/passes/1-parser/shared/SyntaxError.ml @@ -0,0 +1,4 @@ +type error = + | WrongFunctionArguments + +exception Error of error \ No newline at end of file diff --git a/src/passes/1-parser/shared/SyntaxError.mli b/src/passes/1-parser/shared/SyntaxError.mli new file mode 100644 index 000000000..a0faa0bbb --- /dev/null +++ b/src/passes/1-parser/shared/SyntaxError.mli @@ -0,0 +1,4 @@ +type error = + | WrongFunctionArguments + +exception Error of error \ No newline at end of file diff --git a/src/passes/1-parser/shared/dune b/src/passes/1-parser/shared/dune index 2dafdbd17..a59199862 100644 --- a/src/passes/1-parser/shared/dune +++ b/src/passes/1-parser/shared/dune @@ -15,7 +15,10 @@ Markup FQueue EvalOpt - Version)) + Version + SyntaxError) + (modules_without_implementation Error)) + (rule (targets Version.ml) diff --git a/src/passes/2-simplify/cameligo.ml b/src/passes/2-simplify/cameligo.ml index 054d7272c..530b46042 100644 --- a/src/passes/2-simplify/cameligo.ml +++ b/src/passes/2-simplify/cameligo.ml @@ -564,11 +564,11 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result let%bind (v, v_type) = pattern_to_typed_var par_var in let%bind v_type_expression = match v_type with - | Some v_type -> ok @@ (simpl_type_expression v_type) - | None -> fail @@ wrong_pattern "typed var tuple" par_var in - let%bind v_type_expression = v_type_expression in + | Some v_type -> ok (to_option (simpl_type_expression v_type)) + | None -> ok None + in let%bind simpl_rhs_expr = simpl_expression rhs_expr in - ok @@ loc x @@ Declaration_constant (Var.of_name v.value, Some v_type_expression, simpl_rhs_expr) ) + ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, simpl_rhs_expr) ) in let%bind variables = ok @@ npseq_to_list pt.value in let%bind expr_bind_lst = match let_rhs with diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 92b3d95b6..4303a6f1b 100644 --- a/src/stages/ast_typed/misc.ml +++ b/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" diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index e32e9dd52..411681a2a 100644 --- a/src/stages/common/PP.ml +++ b/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 = diff --git a/src/test/contracts/error_typer_1.mligo b/src/test/contracts/error_typer_1.mligo new file mode 100644 index 000000000..b39f46dd9 --- /dev/null +++ b/src/test/contracts/error_typer_1.mligo @@ -0,0 +1,3 @@ +type toto = int + +let foo : string = 42 + 127 diff --git a/src/test/contracts/error_typer_2.mligo b/src/test/contracts/error_typer_2.mligo new file mode 100644 index 000000000..77534fee2 --- /dev/null +++ b/src/test/contracts/error_typer_2.mligo @@ -0,0 +1,3 @@ +type toto = int option + +let foo : string list = Some (42 + 127) diff --git a/src/test/contracts/error_typer_3.mligo b/src/test/contracts/error_typer_3.mligo new file mode 100644 index 000000000..ce6e637ef --- /dev/null +++ b/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) diff --git a/src/test/contracts/type_tuple_destruct.mligo b/src/test/contracts/type_tuple_destruct.mligo new file mode 100644 index 000000000..05bcaea59 --- /dev/null +++ b/src/test/contracts/type_tuple_destruct.mligo @@ -0,0 +1,11 @@ +type foobar = int * int +let test_t: foobar = 10, 25 +let foo, bar = test_t + +let type_tuple_d (p: unit) = foo + bar + +type complex = string * int * string * nat +let test_t_2 = "hello", 10, "world", 50n +let hello, ten, world, fifty_n = test_t_2 + +let type_tuple_d_2 (p: unit) = hello ^ world diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 14cc41e23..35ffc05e0 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1765,6 +1765,12 @@ let key_hash () : unit result = let%bind () = expect_eq program "check_hash_key" make_input make_expected in ok () +let type_tuple_destruct () : unit result = + let%bind program = mtype_file "./contracts/type_tuple_destruct.mligo" in + let%bind () = expect_eq program "type_tuple_d" (e_unit ()) (e_int 35) in + let%bind () = expect_eq program "type_tuple_d_2" (e_unit ()) (e_string "helloworld") in + ok () + let main = test_suite "Integration (End to End)" [ test "key hash" key_hash ; test "chain id" chain_id ; @@ -1899,4 +1905,5 @@ let main = test_suite "Integration (End to End)" [ test "simple_access (ligo)" simple_access_ligo; test "deep_access (ligo)" deep_access_ligo; test "entrypoints (ligo)" entrypoints_ligo ; + test "type tuple destruct (mligo)" type_tuple_destruct ; ]