Merge branch 'dev' of https://gitlab.com/ligolang/ligo into reasonligo-improvemtns

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 ;
+     `Error (false, Format.asprintf "%a%!" (formatted_string_result_pp display_format) x)
-     exit 1

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/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)
+              | Some v_type -> ok (to_option (simpl_type_expression v_type))
-              | None -> fail @@ wrong_pattern "typed var tuple" par_var in
+              | None -> ok None
-            let%bind v_type_expression = v_type_expression in
+            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 title = (thunk "different type constructors") in
-    let message () = "" 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 title = (thunk "different type constructors") in
-    let message () = "" 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/replaceable_id.ligo

@@ -0,0 +1,35 @@
+// storage type
+type storage_t is address;
+
+// entry points parameter types
+type change_addr_pt is address
+
+type message_t is list (operation) ;
+type pass_message_pt is (unit -> message_t)
+
+type contract_return_t is (list(operation) * storage_t)
+
+type entry_point_t is
+| Change_address of change_addr_pt
+| Pass_message of pass_message_pt
+
+function change_address (const param : change_addr_pt;
+                         const s : storage_t) : contract_return_t is
+  begin
+    if sender =/= s then failwith("Unauthorized sender")
+    else skip
+end with ((nil : list(operation)), param)
+
+function pass_message ( const param: pass_message_pt;
+                        const s : storage_t ) : contract_return_t is
+  begin
+    if sender =/= s then failwith("Unauthorized sender") else skip ;
+  var message : pass_message_pt := param ;
+end with (param(unit),s)
+
+function main(const param : entry_point_t; const s : storage_t) : contract_return_t is 
+block {skip} with 
+  case param of
+  | Change_address (p) -> change_address(p,s)
+  | Pass_message (p) -> pass_message(p,s)
+end

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

src/test/replaceable_id_tests.ml

@@ -0,0 +1,90 @@
+open Trace
+open Test_helpers
+
+let type_file f = 
+  let%bind simplified  = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in
+  let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in
+  ok @@ (typed,state)
+
+let get_program =
+  let s = ref None in
+  fun () -> match !s with
+    | Some s -> ok s
+    | None -> (
+        let%bind program = type_file "./contracts/replaceable_id.ligo" in
+        s := Some program ;
+        ok program
+      )
+
+let compile_main () = 
+  let%bind simplified      = Ligo.Compile.Of_source.compile "./contracts/replaceable_id.ligo" (Syntax_name "pascaligo") in
+  let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in
+  let%bind mini_c_prg      = Ligo.Compile.Of_typed.compile typed_prg in
+  let%bind michelson_prg   = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
+  let%bind (_contract: Tezos_utils.Michelson.michelson) =
+    (* fails if the given entry point is not a valid contract *)
+    Ligo.Compile.Of_mini_c.build_contract michelson_prg in
+  ok ()
+open Ast_simplified
+
+let empty_op_list = 
+  (e_typed_list [] t_operation)
+let empty_message = e_lambda (Var.of_name "arguments")
+  (Some t_unit) (Some (t_list t_operation))
+  empty_op_list
+
+let storage id = e_address @@ addr id 
+let entry_change_addr id = e_constructor "Change_address"
+  @@ e_address @@ addr @@ id
+let entry_pass_message = e_constructor "Pass_message"
+  @@ empty_message
+
+let change_addr_success () =
+  let%bind program,_ = get_program () in
+  let init_storage = storage 1 in
+  let param = entry_change_addr 2 in
+  let options =
+    let source = contract 1 in
+    Proto_alpha_utils.Memory_proto_alpha.make_options ~source () in
+  expect_eq ~options program "main"
+    (e_pair param init_storage) (e_pair empty_op_list (storage 2))
+
+let change_addr_fail () =
+  let%bind program,_ = get_program () in
+  let init_storage = storage 1 in
+  let param = entry_change_addr 2 in
+  let options =
+    let source = contract 3 in
+    Proto_alpha_utils.Memory_proto_alpha.make_options ~source () in
+  let exp_failwith = "Unauthorized sender" in
+  expect_string_failwith ~options program "main"
+    (e_pair param init_storage) exp_failwith
+
+let pass_message_success () =
+  let%bind program,_ = get_program () in
+  let init_storage = storage 1 in
+  let param = entry_pass_message in
+  let options =
+    let source = contract 1 in
+    Proto_alpha_utils.Memory_proto_alpha.make_options ~source () in
+  expect_eq ~options program "main"
+    (e_pair param init_storage) (e_pair empty_op_list init_storage)
+
+let pass_message_fail () =
+  let%bind program,_ = get_program () in
+  let init_storage = storage 1 in
+  let param = entry_pass_message in
+  let options =
+    let source = contract 2 in
+    Proto_alpha_utils.Memory_proto_alpha.make_options ~source () in
+  let exp_failwith = "Unauthorized sender" in
+  expect_string_failwith ~options program "main"
+    (e_pair param init_storage) exp_failwith
+
+let main = test_suite "Replaceable ID" [
+    test "compile"              compile_main         ;
+    test "change_addr_success"  change_addr_success  ;
+    test "change_addr_fail"     change_addr_fail     ;
+    test "pass_message_success" pass_message_success ;
+    test "pass_message_fail"    pass_message_fail    ;
+  ]

src/test/test.ml

@@ -12,5 +12,6 @@ let () =
     Vote_tests.main ;
     Multisig_tests.main ;
     Multisig_v2_tests.main ;
+    Replaceable_id_tests.main ;
   ] ;
   ()