Merge remote-tracking branch 'origin/dev' into rinderknecht-dev

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

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

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;

src/passes/1-parser/shared/SyntaxError.ml

@@ -0,0 +1,4 @@
+type error = 
+  | WrongFunctionArguments
+
+exception Error of error

src/passes/1-parser/shared/SyntaxError.mli

@@ -0,0 +1,4 @@
+type error = 
+  | WrongFunctionArguments
+
+exception Error of error

src/passes/1-parser/shared/dune

@@ -15,7 +15,10 @@
     Markup
     FQueue
     EvalOpt
-    Version))
+    Version
+    SyntaxError)
+  (modules_without_implementation Error))
+
 
 (rule
   (targets Version.ml)

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

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)

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

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