Alpha: simplify handling of Unit parameter in Apply

src/proto_alpha/lib_client/michelson_v1_error_reporter.ml

@@ -245,29 +245,17 @@ let report_errors ~details ~show_source ?parsed ppf errs =
           "@[<v 0>Storage limit exceeded during typechecking or execution.@,Try again with a higher storage limit.@]" ;
         if rest <> [] then Format.fprintf ppf "@," ;
         print_trace locations rest
+    | [ Alpha_environment.Ecoproto_error (Script_interpreter.Bad_contract_parameter c) ] ->
+        Format.fprintf ppf
+          "@[<v 0>Account %a is not a smart contract, it does not take arguments.@,\
+           The `-arg' flag should not be used when transferring to an account.@]"
+          Contract.pp c
     | Alpha_environment.Ecoproto_error err :: rest ->
         begin match err with
-          | Apply.Bad_contract_parameter (c, None, _) ->
+          | Script_interpreter.Bad_contract_parameter c ->
               Format.fprintf ppf
-                "@[<v 0>Account %a is not a smart contract, it does not take arguments.@,\
-                 The `-arg' flag cannot be used when transferring to an account.@]"
+                "Invalid argument passed to contract %a."
                 Contract.pp c
-          | Apply.Bad_contract_parameter (c, Some expected, None) ->
-              Format.fprintf ppf
-                "@[<v 0>Contract %a expected an argument of type@,  %a@,but no argument was provided.@,\
-                 The `-arg' flag can be used when transferring to a smart contract.@]"
-                Contract.pp c
-                print_expr expected
-          | Apply.Bad_contract_parameter (c, Some expected, Some argument) ->
-              let argument =
-                Option.unopt_exn
-                  (Failure "ill-serialized argument")
-                  (Data_encoding.force_decode argument) in
-              Format.fprintf ppf
-                "@[<v 0>Contract %a expected an argument of type@,  %a@,but received@,  %a@]"
-                Contract.pp c
-                print_expr expected
-                print_expr argument
           | Invalid_arity (loc, name, exp, got) ->
               Format.fprintf ppf
                 "%aprimitive %s expects %d arguments but is given %d."

src/proto_alpha/lib_protocol/src/apply.ml

@@ -14,7 +14,6 @@ open Alpha_context
 type error += Wrong_voting_period of Voting_period.t * Voting_period.t (* `Temporary *)
 type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t (* `Temporary *)
 type error += Duplicate_endorsement of int (* `Branch *)
-type error += Bad_contract_parameter of Contract.t * Script.expr option * Script.lazy_expr option (* `Permanent *)
 type error += Invalid_endorsement_level
 type error += Invalid_commitment of { expected: bool }
 type error += Internal_operation_replay of packed_internal_operation
@@ -69,20 +68,6 @@ let () =
                      (req "provided" Voting_period.encoding))
     (function Wrong_voting_period (e, p) -> Some (e, p) | _ -> None)
     (fun (e, p) -> Wrong_voting_period (e, p));
-  register_error_kind
-    `Permanent
-    ~id:"badContractParameter"
-    ~title:"Contract supplied an invalid parameter"
-    ~description:"Either no parameter was supplied to a contract, \
-                  a parameter was passed to an account, \
-                  or a parameter was supplied of the wrong type"
-    Data_encoding.(obj3
-                     (req "contract" Contract.encoding)
-                     (opt "expectedType" Script.expr_encoding)
-                     (opt "providedArgument" Script.lazy_expr_encoding))
-    (function Bad_contract_parameter (c, expected, supplied) ->
-       Some (c, expected, supplied) | _ -> None)
-    (fun (c, expected, supplied) -> Bad_contract_parameter (c, expected, supplied)) ;
   register_error_kind
     `Branch
     ~id:"operation.duplicate_endorsement"
@@ -357,7 +342,7 @@ let apply_manager_operation_content :
                 match Micheline.root arg with
                 | Prim (_, D_Unit, [], _) ->
                     return ()
-                | _ -> fail (Bad_contract_parameter (destination, None, parameters))
+                | _ -> fail (Script_interpreter.Bad_contract_parameter destination)
           end >>=? fun () ->
             let result =
               Transaction_result
@@ -371,19 +356,13 @@ let apply_manager_operation_content :
                   storage_size_diff = 0L } in
             return (ctxt, result, [])
         | Some script ->
-            Lwt.return (Script.force_decode script.code) >>=? fun code ->
-            Lwt.return @@ Script_ir_translator.parse_toplevel code >>=? fun (arg_type, _, _) ->
-            let arg_type = Micheline.strip_locations arg_type in
-            begin match parameters, Micheline.root arg_type with
-              | None, Prim (_, T_unit, _, _) ->
-                  return (ctxt, (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))))
-              | Some parameters, _ ->
+            begin match parameters with
+              | None ->
+                  let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], None)) in
+                  return (ctxt, unit)
+              | Some parameters ->
                   Lwt.return (Script.force_decode parameters) >>=? fun arg ->
-                  trace
-                    (Bad_contract_parameter (destination, Some arg_type, Some parameters))
-                    (Script_ir_translator.typecheck_data ctxt (arg, arg_type)) >>=? fun ctxt ->
                   return (ctxt, arg)
-              | None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None))
             end >>=? fun (ctxt, parameter) ->
             Script_interpreter.execute
               ctxt mode

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -17,6 +17,7 @@ open Script_ir_translator
 type error += Reject of Script.location
 type error += Overflow of Script.location
 type error += Runtime_contract_error : Contract.t * Script.expr -> error
+type error += Bad_contract_parameter of Contract.t (* `Permanent *)
 
 let () =
   let open Data_encoding in
@@ -52,7 +53,19 @@ let () =
           Some (contract, expr)
       | _ -> None)
     (fun (contract, expr) ->
-       Runtime_contract_error (contract, expr))
+       Runtime_contract_error (contract, expr)) ;
+  (* Bad contract parameter *)
+  register_error_kind
+    `Permanent
+    ~id:"badContractParameter"
+    ~title:"Contract supplied an invalid parameter"
+    ~description:"Either no parameter was supplied to a contract with \
+                  a non-unit parameter type, a non-unit parameter was \
+                  passed to an account, or a parameter was supplied of \
+                  the wrong type"
+    Data_encoding.(obj1 (req "contract" Contract.encoding))
+    (function Bad_contract_parameter c -> Some c | _ -> None)
+    (fun c -> Bad_contract_parameter c)
 
 (* ---- interpreter ---------------------------------------------------------*)
 
@@ -697,7 +710,9 @@ and execute ?log ctxt mode ~source ~payer ~self script amount arg :
    Script_typed_ir.ex_big_map option) tzresult Lwt.t =
   parse_script ctxt script
   >>=? fun ((Ex_script { code ; arg_type ; storage ; storage_type }), ctxt) ->
-  parse_data ctxt arg_type arg >>=? fun (arg, ctxt) ->
+  trace
+    (Bad_contract_parameter self)
+    (parse_data ctxt arg_type arg) >>=? fun (arg, ctxt) ->
   Lwt.return (Script.force_decode script.code) >>=? fun script_code ->
   trace
     (Runtime_contract_error (self, script_code))

src/proto_alpha/lib_protocol/src/script_interpreter.mli

@@ -12,6 +12,7 @@ open Alpha_context
 type error += Overflow of Script.location
 type error += Reject of Script.location
 type error += Runtime_contract_error : Contract.t * Script.expr -> error
+type error += Bad_contract_parameter of Contract.t (* `Permanent *)
 
 type execution_result =
   { ctxt : context ;