Merge branch 'feature/create-contract' into 'dev'

Feature/create contract

Closes #143

See merge request ligolang/ligo!459

CHANGELOG.md

@@ -2,6 +2,10 @@
 
 ## [Unreleased]
 
+## [Add crypto reference page to docs](https://gitlab.com/ligolang/ligo/-/merge_requests/459)
+### Added
+- support for `Tezos.create_contract` origination
+
 ## [9164206ef1fcf3e577820442b5afbad92d03ffa4] - 2020-02-09
 ### Changed
 - Mutation of variables inside lambdas passed to list_iter do not have effect anymore. Side-effects used to survive iterations of list_iter via a quirk in the Michelson list_iter. Now, either use a list_fold and explicitly pass through the updated variables (e.g. storage) to the next iteration, or use a `for` loop which automatically detects mutations within the loop body and lifts the affected variables to a record that is passed from iteration to iteration.

gitlab-pages/docs/language-basics/tezos-specific.md

@@ -154,3 +154,42 @@ let current_addr : address = Tezos.self_address;
 ```
 
 <!--END_DOCUSAURUS_CODE_TABS-->
+
+## Origination of a contract
+
+`Tezos.create_contract` allows you to originate a contract given its code, delegate (if any), initial balance and initial storage.
+The return value is a pair of type `(operation * address)`.
+
+> ⚠️ Due to limitations in Michelson, `Tezos.create_contract` first argument
+> must be inlined and must not contain references to free variables
+
+<!--DOCUSAURUS_CODE_TABS-->
+
+<!--PascaLIGO-->
+```pascaligo group=e
+const origination : operation * address = Tezos.create_contract (
+  function (const p : nat; const s : string): list(operation) * string is ((nil : list(operation)), s),
+  (None : option(key_hash)),
+  3tz,
+  "initial_storage")
+```
+
+<!--CameLIGO-->
+```cameligo group=e
+let origination : operation * address = Tezos.create_contract
+  (fun (p, s : nat * string) -> (([] : operation list), s))
+  (None: key_hash option) 
+  3tz 
+  "initial_storage"
+```
+
+<!--ReasonLIGO-->
+```reasonligo group=e
+let origination : (operation, address) = Tezos.create_contract (
+  ((p, s) : (nat,string)) : (list(operation),string) => (([] : list(operation)), s),
+  None: option(key_hash),
+  3tz,
+  "initial_storage")
+```
+
+<!--END_DOCUSAURUS_CODE_TABS-->

src/bin/expect_tests/contract_tests.ml

@@ -1144,4 +1144,65 @@ let%expect_test _ =
     * 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' |}]
+    * Check the changelog by running 'ligo changelog' |}]
+
+let%expect_test _ =
+  run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ;
+  [%expect {|
+    ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P : ( nat * string ):Some(( nat * string ))) : None return let rhs#752 = #P in let p = rhs#752.0 in let s = rhs#752.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
+
+
+     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' |}] ;
+
+  run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ;
+  [%expect {|
+    ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P : ( nat * int ):Some(( nat * int ))) : None return let rhs#755 = #P in let p = rhs#755.0 in let s = rhs#755.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
+
+
+     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' |}] ;
+
+  run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_no_inline.mligo" ; "main" ] ;
+  [%expect {|
+    ligo: in file "create_contract_no_inline.mligo", line 9, characters 19-89. CREATE_CONTRACT first argument must be inlined: contract code can be inlined using a lambda {"expression":"CREATE_CONTRACT(dummy_contract , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_no_inline.mligo\", line 9, characters 19-89"}
+
+
+     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' |}] ;
+
+  run_ligo_good [ "compile-contract" ; contract "create_contract.mligo" ; "main" ] ;
+  [%expect {|
+    { parameter string ;
+      storage string ;
+      code { PUSH string "un" ;
+             PUSH mutez 300000000 ;
+             NONE key_hash ;
+             CREATE_CONTRACT
+               { parameter nat ;
+                 storage string ;
+                 code { PUSH string "one" ; NIL operation ; PAIR ; DIP { DROP } } } ;
+             PAIR ;
+             DUP ;
+             CAR ;
+             NIL operation ;
+             SWAP ;
+             CONS ;
+             DIP { DIP { DUP } ; SWAP ; CDR } ;
+             PAIR ;
+             DIP { DROP 2 } } } |}]

src/passes/4-typer-old/typer.ml

@@ -154,6 +154,24 @@ module Errors = struct
     ] in
     error ~data title message ()
 
+  let fvs_in_create_contract_lambda (e : I.expression) (fvar : Ast_typed.expression_variable) () =
+    let title = (thunk "No free variable allowed in this lambda") in
+    let message () = Format.asprintf "variable '%a'" Var.pp fvar in
+    let data = [
+      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
+    ] in
+    error ~data title message ()
+
+  let create_contract_lambda (cst : I.constant') (e : I.expression) () =
+    let title () = Format.asprintf "%a first argument must be inlined" I.PP.constant cst in
+    let message () = Format.asprintf "contract code can be inlined using a lambda" in
+    let data = [
+      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
+    ] in
+    error ~data title message ()
+
   let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
     let title = (thunk "type error") in
     let message () = msg in
@@ -696,6 +714,20 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
       let%bind (opname',tv) = type_constant opname tv_lst tv_opt in
       Format.printf "Typed constant : %a \n%!" O.PP.type_expression tv;
       return (E_constant {cons_name=opname';arguments=lst'}) tv
+  | E_constant {cons_name=C_CREATE_CONTRACT as cons_name;arguments} ->
+      let%bind lst' = bind_list @@ List.map (type_expression' e) arguments in
+      let%bind () = match lst' with
+        | { expression_content = O.E_lambda l ; _ } :: _ ->
+          let open Ast_typed.Misc in
+          let fvs = Free_variables.lambda [] l in
+          if List.length fvs = 0 then ok ()
+          else fail @@ fvs_in_create_contract_lambda ae (List.hd fvs)
+        | _ -> fail @@ create_contract_lambda C_CREATE_CONTRACT ae
+      in
+      let tv_lst = List.map get_type_expression lst' in
+      let%bind (name', tv) =
+        type_constant cons_name tv_lst tv_opt in
+      return (E_constant {cons_name=name';arguments=lst'}) tv
   | E_constant {cons_name;arguments} ->
       let%bind lst' = bind_list @@ List.map (type_expression' e) arguments in
       let tv_lst = List.map get_type_expression lst' in

src/passes/8-compiler/compiler_program.ml

@@ -27,7 +27,7 @@ end
 open Errors
 
 (* This does not makes sense to me *)
-let get_operator : constant' -> type_value -> expression list -> predicate result = fun s ty lst ->
+let rec get_operator : constant' -> type_value -> expression list -> predicate result = fun s ty lst ->
   match Operators.Compiler.get_operators s with
   | Ok (x,_) -> ok x
   | Error _ -> (
@@ -114,10 +114,23 @@ let get_operator : constant' -> type_value -> expression list -> predicate resul
             i_drop ; (* drop the entrypoint... *)
             prim ~annot:[entry] ~children:[r_ty] I_CONTRACT ;
           ]
+      | C_CREATE_CONTRACT ->
+        let%bind ch = match lst with
+          | { content= E_closure {body;binder} ; type_value = T_function (T_pair ((_,p),(_,s)) as tin,_)} :: _ ->
+            let%bind closure = translate_function_body {body;binder} [] tin in
+            let%bind (p',s') = bind_map_pair Compiler_type.type_ (p,s) in
+            ok @@ contract p' s' closure
+          | _ -> fail @@ corner_case ~loc:__LOC__ "mini_c . CREATE_CONTRACT"
+        in
+        ok @@ simple_tetrary @@ seq [
+          i_drop ;
+          prim ~children:[ch] I_CREATE_CONTRACT ;
+          i_pair ;
+        ]
       | x -> simple_fail (Format.asprintf "predicate \"%a\" doesn't exist" PP.constant x)
     )
 
-let rec translate_value (v:value) ty : michelson result = match v with
+and translate_value (v:value) ty : michelson result = match v with
   | D_bool b -> ok @@ prim (if b then D_True else D_False)
   | D_int n -> ok @@ int (Z.of_int n)
   | D_nat n -> ok @@ int (Z.of_int n)
@@ -249,6 +262,10 @@ and translate_expression (expr:expression) (env:environment) : michelson result
             pre_code ;
             f ;
           ]
+        | Tetrary f, 4 -> ok @@ seq [
+            pre_code ;
+            f ;
+          ]
         | _ -> simple_fail (Format.asprintf "bad arity for %a" PP.constant str)
       in
       let error =

src/passes/operators/operators.ml

@@ -88,6 +88,7 @@ module Simplify = struct
     | "source"                     -> ok C_SOURCE              (* Deprecated *)
     | "Tezos.failwith"         -> ok C_FAILWITH
     | "failwith"                   -> ok C_FAILWITH
+    | "Tezos.create_contract"  -> ok C_CREATE_CONTRACT
 
     | "Tezos.transaction"  -> ok C_CALL
     | "transaction"            -> ok C_CALL                    (* Deprecated *)
@@ -287,6 +288,7 @@ module Simplify = struct
     | "Operation.get_entrypoint"   -> ok C_CONTRACT_ENTRYPOINT (* Deprecated *)
     | "Tezos.get_entrypoint_opt"     -> ok C_CONTRACT_ENTRYPOINT_OPT
     | "Operation.get_entrypoint_opt" -> ok C_CONTRACT_ENTRYPOINT_OPT (* Deprecated *)
+    | "Tezos.create_contract"        -> ok C_CREATE_CONTRACT
 
     | "Michelson.is_nat" -> ok C_IS_NAT  (* Deprecated *)
     | "is_nat"           -> ok C_IS_NAT
@@ -800,18 +802,17 @@ module Typer = struct
     let%bind () = assert_type_expression_eq (param , contract_param) in
     ok @@ t_operation ()
 
-  let originate = typer_6 "ORIGINATE" @@ fun manager delegate_opt spendable delegatable init_balance code ->
-    let%bind () = assert_eq_1 manager (t_key_hash ()) in
-    let%bind () = assert_eq_1 delegate_opt (t_option (t_key_hash ()) ()) in
-    let%bind () = assert_eq_1 spendable (t_bool ()) in
-    let%bind () = assert_eq_1 delegatable (t_bool ()) in
-    let%bind () = assert_t_mutez init_balance in
-    let%bind (arg , res) = get_t_function code in
-    let%bind (_param , storage) = get_t_pair arg in
-    let%bind (storage' , op_lst) = get_t_pair res in
-    let%bind () = assert_eq_1 storage storage' in
-    let%bind () = assert_eq_1 op_lst (t_list (t_operation ()) ()) in
-    ok @@ (t_pair (t_operation ()) (t_address ()) ())
+  let create_contract = typer_4 "CREATE_CONTRACT" @@ fun f kh_opt amount init_storage  ->
+    let%bind (args , ret) = get_t_function f in
+    let%bind (_,s) = get_t_pair args in
+    let%bind (oplist,s') = get_t_pair ret in
+    let%bind () = assert_t_mutez amount in
+    let%bind (delegate) = get_t_option kh_opt in
+    let%bind () = assert_type_expression_eq (s,s') in
+    let%bind () = assert_type_expression_eq (s,init_storage) in
+    let%bind () = assert_t_list_operation oplist in
+    let%bind () = assert_t_key_hash delegate in
+    ok @@ t_pair (t_operation ()) (t_address ()) ()
 
   let get_contract = typer_1_opt "CONTRACT" @@ fun addr_tv tv_opt ->
     if not (type_expression_eq (addr_tv, t_address ()))
@@ -1229,6 +1230,7 @@ module Typer = struct
     | C_SELF_ADDRESS        -> ok @@ self_address;
     | C_IMPLICIT_ACCOUNT    -> ok @@ implicit_account;
     | C_SET_DELEGATE        -> ok @@ set_delegate ;
+    | C_CREATE_CONTRACT     -> ok @@ create_contract ;
     | _                     -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" PP.constant c
 
 

src/passes/operators/operators.mli

@@ -140,7 +140,7 @@ module Typer : sig
   val now : typer
   val transaction : typer
   *)
-  val originate : typer
+  val create_contract : typer
   (*
   val get_contract : typer
   *)

src/stages/common/PP.ml

@@ -146,6 +146,7 @@ let constant ppf : constant' -> unit = function
   | C_SELF_ADDRESS          -> fprintf ppf "SELF_ADDRESS"
   | C_IMPLICIT_ACCOUNT      -> fprintf ppf "IMPLICIT_ACCOUNT"
   | C_SET_DELEGATE          -> fprintf ppf "SET_DELEGATE"
+  | C_CREATE_CONTRACT       -> fprintf ppf "CREATE_CONTRACT"
 
 let literal ppf (l : literal) =
   match l with

src/stages/common/types.ml

@@ -288,3 +288,4 @@ and constant' =
   | C_SELF_ADDRESS
   | C_IMPLICIT_ACCOUNT
   | C_SET_DELEGATE
+  | C_CREATE_CONTRACT

src/stages/mini_c/PP.ml

@@ -242,6 +242,7 @@ and constant ppf : constant' -> unit = function
   | C_SELF_ADDRESS          -> fprintf ppf "SELF_ADDRESS"
   | C_IMPLICIT_ACCOUNT      -> fprintf ppf "IMPLICIT_ACCOUNT"
   | C_SET_DELEGATE          -> fprintf ppf "SET_DELEGATE"
+  | C_CREATE_CONTRACT       -> fprintf ppf "CREATE_CONTRACT"
 
 let%expect_test _ =
   Format.printf "%a" value (D_bytes (Bytes.of_string "foo")) ;

src/stages/mini_c/combinators.ml

@@ -152,7 +152,7 @@ let get_t_contract t = match t with
   | _ -> fail @@ wrong_type "contract" t
 
 let get_t_operation t = match t with
-  | T_base TC_operation -> ok ()
+  | T_base TC_operation -> ok t
   | _ -> fail @@ wrong_type "operation" t
 
 let get_operation (v:value) = match v with

src/stages/mini_c/combinators.mli

@@ -49,7 +49,7 @@ val wrong_type : string -> type_value -> unit -> error
 val get_t_left : type_value -> type_value result
 val get_t_right : type_value -> type_value result
 val get_t_contract : type_value -> type_value result
-val get_t_operation : type_value -> unit result
+val get_t_operation : type_value -> type_value result
 val get_operation : value -> Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation result
 
 val t_int : type_value 

src/test/contracts/create_contract.mligo

@@ -0,0 +1,10 @@
+type return = operation list * string
+
+let main (action, store : string * string) : return =
+  let toto : operation * address = Tezos.create_contract
+    (fun (p, s : nat * string) -> (([] : operation list), "one")) 
+    (None: key_hash option) 
+    300tz 
+    "un"
+  in
+  ([toto.0], store)

src/test/contracts/negative/create_contract_no_inline.mligo

@@ -0,0 +1,11 @@
+let foo : int = 42
+
+let dummy_contract (p, s : nat * int) : return =
+ (([] : operation list), foo)
+
+type return = operation list * string
+
+let main (action, store : int * int) : return =
+  let (op, addr) = Tezos.create_contract dummy_contract ((None: key_hash option)) 300tz 1 in
+  let toto : operation list = [ op ] in
+  (toto, foo)

src/test/contracts/negative/create_contract_toplevel.mligo

@@ -0,0 +1,10 @@
+type return = operation list * string
+
+let main (action, store : string * string) : return =
+  let toto : operation * address = Tezos.create_contract
+    (fun (p, s : nat * string) -> (([] : operation list), store)) 
+    (None: key_hash option) 
+    300tz 
+    "un"
+  in
+  ([toto.0], store)

src/test/contracts/negative/create_contract_var.mligo

@@ -0,0 +1,12 @@
+type return = operation list * string
+
+let a : int = 2
+
+let main (action, store : string * string) : return =
+  let toto : operation * address = Tezos.create_contract
+    (fun (p, s : nat * int) -> (([] : operation list), a)) 
+    (None: key_hash option) 
+    300tz 
+    1 
+  in
+  ([toto.0], store)