Merge branch 'feature/check-pass' into 'dev'

detect self in lambda

See merge request ligolang/ligo!343

src/bin/expect_tests/contract_tests.ml

@@ -2,6 +2,8 @@ open Cli_expect
 
 let contract basename =
   "../../test/contracts/" ^ basename
+let bad_contract basename =
+  "../../test/contracts/negative/" ^ basename
 
 let%expect_test _ =
   run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ;
@@ -1024,3 +1026,15 @@ let%expect_test _ =
   [%expect {|
     failwith("This contract always fails") |}]
 
+let%expect_test _ =
+  run_ligo_bad [ "compile-contract" ; bad_contract "self_in_lambda.mligo" ; "main" ] ;
+  [%expect {|
+    ligo: Wrong SELF_ADDRESS location: SELF_ADDRESS is only allowed at top-level
+
+     If you're not sure how to fix this error, you can
+     do one of the following:
+
+    * Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
+    * Ask a question on our Discord: https://discord.gg/9rhYaEt
+    * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
+    * Check the changelog by running 'ligo changelog' |}]

src/main/compile/of_michelson.ml

@@ -5,10 +5,9 @@ open Trace
 module Errors = struct
 (*
   TODO: those errors should have been caught in the earlier stages on the ligo pipeline
-        Here, in case of contract not typechecking, we should write a warning with a "please report"
+  build_contract is a kind of security net
-        on stderr and print the ill-typed michelson code;
 *)
-  let title_type_check_msg () = "Invalid contract (This might be a compiler bug, please report) "
+  let title_type_check_msg () = "generated Michelson contract failed to typecheck"
   let bad_parameter c () =
     let message () =
       let code = Format.asprintf "%a" Michelson.pp c in
@@ -22,7 +21,7 @@ module Errors = struct
   let bad_contract c () =
     let message () =
       let code = Format.asprintf "%a" Michelson.pp c in
-      "bad contract type (contract entry point is expected to be of the form \"parameter * storage -> list(operation) * storage\"):\n"^code in
+      "bad contract type\n"^code in
     error title_type_check_msg message
   let unknown () =
     let message () =

src/main/compile/of_mini_c.ml

@@ -3,6 +3,7 @@ open Proto_alpha_utils
 open Trace
 
 let compile_contract : expression -> Compiler.compiled_expression result = fun e ->
+  let%bind e = Self_mini_c.contract_check e in
   let%bind (input_ty , _) = get_t_function e.type_value in
   let%bind body = get_function e in
   let%bind body = Compiler.Program.translate_function_body body [] input_ty in

src/passes/3-self_ast_simplified/self_ast_simplified.ml

@@ -6,14 +6,6 @@ let all = [
   Literals.peephole_expression ;
 ]
 
-let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x ->
-  match fs with
-  | [] -> ok x
-  | hd :: tl -> (
-      let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in
-      bind aux (ok x)
-    )
-
 let all_program =
   let all_p = List.map Helpers.map_program all in
   bind_chain all_p

src/passes/7-self_mini_c/helpers.ml

@@ -163,3 +163,11 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
       let%bind updates = bind_map_list (fun (p,e) -> let%bind e = self e in ok(p,e)) updates in
       return @@ E_update(r,updates)
   )
+
+let map_sub_level_expression : mapper -> expression -> expression result = fun f e ->
+  match e.content with
+  | E_closure {binder ; body} ->
+    let%bind body = map_expression f body in
+    let content = E_closure {binder; body} in
+    ok @@ { e with content }
+  | _ -> ok e

src/passes/7-self_mini_c/michelson_restrictions.ml

@@ -0,0 +1,26 @@
+open Mini_c
+open Trace
+
+module Errors = struct
+
+  let bad_self_address cst () =
+    let title = thunk @@
+      Format.asprintf "Wrong %alocation" Mini_c.PP.expression' cst in
+    let message = thunk @@
+      Format.asprintf "%ais only allowed at top-level" Mini_c.PP.expression' cst in
+    error title message ()
+  
+end
+open Errors
+
+let self_in_lambdas : expression -> expression result = 
+  fun e ->
+    match e.content with
+    | E_closure {binder=_ ; body} ->
+      let%bind _self_in_lambdas = Helpers.map_expression
+        (fun e -> match e.content with
+        | E_constant (C_SELF_ADDRESS, _) as c -> fail (bad_self_address c)
+        | _ -> ok e)
+        body in
+      ok e
+    | _ -> ok e

src/passes/7-self_mini_c/self_mini_c.ml

@@ -250,6 +250,11 @@ let betas : bool ref -> expression -> expression =
   fun changed ->
   map_expression (beta changed)
 
+let contract_check =
+  let all = [Michelson_restrictions.self_in_lambdas] in
+  let all_e = List.map Helpers.map_sub_level_expression all in
+  bind_chain all_e
+
 let rec all_expression : expression -> expression =
   fun e ->
   let changed = ref false in

src/test/contracts/negative/self_in_lambda.mligo

@@ -0,0 +1,5 @@
+let foo (u: unit) : address =
+  Current.self_address
+
+let main (ps: unit * address): (operation list * address) =
+  ( ([] : operation list) , foo)

vendors/ligo-utils/simple-utils/trace.ml

@@ -718,6 +718,14 @@ let bind_fold_map_pair f acc (a, b) =
 let bind_map_triple f (a, b, c) =
   bind_and3 (f a, f b, f c)
 
+let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x ->
+  match fs with
+  | [] -> ok x
+  | hd :: tl -> (
+      let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in
+      bind aux (ok x)
+    )
+
 
 (**
    Wraps a call that might trigger an exception in a result.