Michelson: Contract creation from literal

lib_embedded_protocol_alpha/src/script_interpreter.ml

@@ -156,6 +156,35 @@ let rec interp
             let gas = Gas.consume gas (cost x1 x2) in
             Gas.check gas >>=? fun () ->
             logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), gas, ctxt) in
+        let create_contract :
+          type param return rest storage.
+          (_, (param, return) typed_contract * rest) descr ->
+          manager:public_key_hash -> delegate:public_key_hash option -> spendable:bool ->
+          delegatable:bool -> credit:Tez.t -> code:prim Micheline.canonical ->
+          init:storage -> param_type:param ty -> storage_type:storage ty ->
+          return_type:return ty ->
+          rest:rest stack ->
+          (((param, return) typed_contract * rest) stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t =
+          fun descr ~manager ~delegate ~spendable ~delegatable
+            ~credit ~code ~init ~param_type ~storage_type ~return_type ~rest ->
+            let gas = Gas.consume gas Gas.Cost_of.create_contract in
+            Gas.check gas >>=? fun () ->
+            let code =
+              Micheline.strip_locations
+                (Seq (0, [ Prim (0, K_parameter, [ unparse_ty None param_type ], None) ;
+                           Prim (0, K_return, [ unparse_ty None return_type ], None) ;
+                           Prim (0, K_storage, [ unparse_ty None storage_type ], None) ;
+                           Prim (0, K_code, [ Micheline.root code ], None) ], None)) in
+            let storage = Micheline.strip_locations (unparse_data storage_type init) in
+            Contract.spend_from_script ctxt source credit >>=? fun ctxt ->
+            Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance ->
+            Contract.originate ctxt
+              origination
+              ~manager ~delegate ~balance
+              ~script:({ code ; storage }, (dummy_code_fee, dummy_storage_fee))
+              ~spendable ~delegatable
+            >>=? fun (ctxt, contract, origination) ->
+            logged_return descr ~origination (Item ((param_type, return_type, contract), rest), gas, ctxt) in
         let logged_return : ?origination:Contract.origination_nonce ->
           a stack * Gas.t * context ->
           (a stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t =
@@ -674,7 +703,7 @@ let rec interp
             Gas.check gas >>=? fun () ->
             let contract = Contract.default_contract key in
             logged_return (Item ((Unit_t, Unit_t, contract), rest), gas, ctxt)
-        | Create_contract (g, p, r),
+        | Create_contract (storage_type, param_type, return_type),
           Item (manager, Item
                   (delegate, Item
                      (spendable, Item
@@ -682,24 +711,17 @@ let rec interp
                            (credit, Item
                               (Lam (_, code), Item
                                  (init, rest))))))) ->
-            let gas = Gas.consume gas Gas.Cost_of.create_contract in
+            create_contract descr ~manager ~delegate ~spendable ~delegatable ~credit ~code ~init
-            Gas.check gas >>=? fun () ->
+              ~param_type ~return_type ~storage_type ~rest
-            let code =
+        | Create_contract_literal (storage_type, param_type, return_type, Lam (_, code)),
-              Micheline.strip_locations
+          Item (manager, Item
-                (Seq (0, [ Prim (0, K_parameter, [ unparse_ty None p ], None) ;
+                  (delegate, Item
-                           Prim (0, K_return, [ unparse_ty None r ], None) ;
+                     (spendable, Item
-                           Prim (0, K_storage, [ unparse_ty None g ], None) ;
+                        (delegatable, Item
-                           Prim (0, K_code, [ Micheline.root code ], None) ], None)) in
+                           (credit, Item
-            let storage = Micheline.strip_locations (unparse_data g init) in
+                              (init, rest)))))) ->
-            Contract.spend_from_script ctxt source credit >>=? fun ctxt ->
+            create_contract descr ~manager ~delegate ~spendable ~delegatable ~credit ~code ~init
-            Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance ->
+              ~param_type ~return_type ~storage_type ~rest
-            Contract.originate ctxt
-              origination
-              ~manager ~delegate ~balance
-              ~script:({ code ; storage }, (dummy_code_fee, dummy_storage_fee))
-              ~spendable ~delegatable
-            >>=? fun (ctxt, contract, origination) ->
-            logged_return ~origination (Item ((p, r, contract), rest), gas, ctxt)
         | Balance, rest ->
             let gas = Gas.consume gas Gas.Cost_of.balance in
             Gas.check gas >>=? fun () ->
@@ -733,8 +755,7 @@ let rec interp
         | Amount, rest ->
             let gas = Gas.consume gas Gas.Cost_of.amount in
             Gas.check gas >>=? fun () ->
-            logged_return (Item (amount, rest), gas, ctxt)
+            logged_return (Item (amount, rest), gas, ctxt) in
-    in
     let stack = (Item (arg, Empty)) in
     begin match log with
       | None -> ()

lib_embedded_protocol_alpha/src/script_ir_translator.ml

@@ -236,6 +236,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
   | Create_account -> 0
   | Default_account -> 0
   | Create_contract _ -> 1
+  | Create_contract_literal _ -> 1
   | Now -> 0
   | Balance -> 0
   | Check_signature -> 0
@@ -980,6 +981,8 @@ let rec unparse_stack
     | Empty_t -> []
     | Item_t (ty, rest, annot) -> strip_locations (unparse_ty annot ty) :: unparse_stack rest
 
+type ex_script = Ex_script : ('a, 'b, 'c) script -> ex_script
+
 let rec parse_data
   : type a.
     ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
@@ -1814,6 +1817,39 @@ and parse_instr
         check_item_ty ginit gp loc I_CREATE_CONTRACT 6 7 >>=? fun (Eq _) ->
         return (typed loc (Create_contract (gp, p, r),
                            Item_t (Contract_t (p, r), rest, instr_annot)))
+    | Prim (loc, I_CREATE_CONTRACT, [ (Seq (seq_loc, _, annot) as code)], instr_annot),
+      Item_t
+        (Key_hash_t, Item_t
+           (Option_t Key_hash_t, Item_t
+              (Bool_t, Item_t
+                 (Bool_t, Item_t
+                    (Tez_t, Item_t
+                       (ginit, rest, _), _), _), _), _), _) ->
+        fail_unexpected_annot seq_loc annot >>=? fun () ->
+        let cannonical_code = fst @@ Micheline.extract_locations code in
+        Lwt.return (parse_toplevel cannonical_code) >>=? fun (arg_type, ret_type, storage_type, code_field) ->
+        trace
+          (Ill_formed_type (Some "parameter", cannonical_code, location arg_type))
+          (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type, param_annot) ->
+        trace
+          (Ill_formed_type (Some "return", cannonical_code, location ret_type))
+          (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type, _) ->
+        trace
+          (Ill_formed_type (Some "storage", cannonical_code, location storage_type))
+          (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) ->
+        let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot),
+                                    (storage_type, default_annot ~default:default_storage_annot storage_annot)) in
+        let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in
+        trace
+          (Ill_typed_contract (cannonical_code, []))
+          (parse_returning (Toplevel { storage_type }) ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=?
+        fun (Lam ({ bef = Item_t (arg, Empty_t, _) ;
+                    aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda) ->
+        Lwt.return @@ ty_eq arg arg_type_full >>=? fun (Eq _) ->
+        Lwt.return @@ ty_eq ret ret_type_full >>=? fun (Eq _) ->
+        Lwt.return @@ ty_eq storage_type ginit >>=? fun (Eq _) ->
+        return (typed loc (Create_contract_literal (storage_type, arg_type, ret_type, lambda),
+                           Item_t (Contract_t (arg_type, ret_type), rest, instr_annot)))
     | Prim (loc, I_NOW, [], instr_annot),
       stack ->
         return (typed loc (Now, Item_t (Timestamp_t, stack, instr_annot)))
@@ -1947,7 +1983,7 @@ and parse_contract
                let contract : (arg, ret) typed_contract =
                  (arg, ret, contract) in
                ok contract)
-        | Some { code } ->
+        | Some { code ; _ } ->
             Lwt.return
               (parse_toplevel code >>? fun (arg_type, ret_type, _, _) ->
                parse_ty arg_type >>? fun (Ex_ty targ, _) ->
@@ -2004,8 +2040,6 @@ and parse_toplevel
         | (Some _, Some _, Some _, None) -> error (Missing_field K_code)
         | (Some p, Some r, Some s, Some c) -> ok (p, r, s, c)
 
-type ex_script = Ex_script : ('a, 'b, 'c) script -> ex_script
-
 let parse_script
   : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
     context -> Script.t -> ex_script tzresult Lwt.t

lib_embedded_protocol_alpha/src/script_typed_ir.ml

@@ -318,6 +318,9 @@ and ('bef, 'aft) instr =
     (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t *
                                                                   (('p * 'g, 'r * 'g) lambda * ('g * 'rest)))))),
      ('p, 'r) typed_contract * 'rest) instr
+  | Create_contract_literal : 'g ty * 'p ty * 'r ty * ('p * 'g, 'r * 'g) lambda  ->
+    (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))),
+     ('p, 'r) typed_contract * 'rest) instr
   | Now :
       ('rest, Script_timestamp.t * 'rest) instr
   | Balance :

test/contracts/create_contract_literal.tz

@@ -0,0 +1,14 @@
+parameter key_hash;
+storage string;
+return unit;
+code { CAR;
+       DIP { UNIT;
+             PUSH tez "100.00"; PUSH bool False;
+             PUSH bool False; NONE key_hash };
+       CREATE_CONTRACT { parameter string ;
+                         storage unit ;
+                         return string ;
+                         code {CAR; UNIT; SWAP; PAIR } } ;
+       DIP{PUSH string ""}; PUSH tez "0.00";
+       PUSH string "abcdefg"; TRANSFER_TOKENS;
+       DIP{DROP}; UNIT; PAIR};