diff --git a/src/client/embedded/alpha/client_proto_context.ml b/src/client/embedded/alpha/client_proto_context.ml index 495b417f5..e2fb2fa57 100644 --- a/src/client/embedded/alpha/client_proto_context.ml +++ b/src/client/embedded/alpha/client_proto_context.ml @@ -46,8 +46,8 @@ let transfer rpc_config get_branch rpc_config block branch >>=? fun (net_id, branch) -> begin match arg with | Some arg -> - Client_proto_programs.parse_data arg >>=? fun arg -> - return (Some arg.ast) + Lwt.return (Michelson_v1_parser.parse_expression arg) >>=? fun { expanded = arg } -> + return (Some arg) | None -> return None end >>=? fun parameters -> Client_proto_rpcs.Context.Contract.counter @@ -105,9 +105,8 @@ let originate_account rpc_config let originate_contract rpc_config block ?force ?branch ~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey - ~(code:Script.code) ~init ~fee ~spendable () = - Client_proto_programs.parse_data init >>=? fun storage -> - let storage = Script.{ storage=storage.ast ; storage_type = code.storage_type } in + ~code ~init ~fee ~spendable () = + Lwt.return (Michelson_v1_parser.parse_expression init) >>=? fun { expanded = storage } -> Client_proto_rpcs.Context.Contract.counter rpc_config block source >>=? fun pcounter -> let counter = Int32.succ pcounter in @@ -279,7 +278,7 @@ let commands () = | None -> cctxt.error "This is not a smart contract." | Some storage -> - cctxt.answer "%a" Client_proto_programs.print_storage storage >>= fun () -> + cctxt.answer "%a" Michelson_v1_printer.print_expr_unwrapped storage >>= fun () -> return () end ; @@ -384,7 +383,7 @@ let commands () = combine with -init if the storage type is not unit" @@ stop) begin fun (fee, delegate, force, delegatable, spendable, init) - neu (_, manager) balance (_, source) { ast = code } cctxt -> + neu (_, manager) balance (_, source) { expanded = code } cctxt -> check_contract cctxt neu >>=? fun () -> get_delegate_pkh cctxt delegate >>=? fun delegate -> get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) -> @@ -395,7 +394,11 @@ let commands () = ~spendable:spendable () >>=function | Error errs -> - Client_proto_programs.report_errors cctxt errs >>= fun () -> + cctxt.warning "%a" + (Michelson_v1_error_reporter.report_errors + ~details: true + ~show_source: true + ?parsed:None) errs >>= fun () -> cctxt.error "origination simulation failed" | Ok (oph, contract) -> message_injection cctxt @@ -443,7 +446,11 @@ let commands () = ~source ~src_pk ~src_sk ~destination ~arg ~amount ~fee () >>= function | Error errs -> - Client_proto_programs.report_errors cctxt errs >>= fun () -> + cctxt.warning "%a" + (Michelson_v1_error_reporter.report_errors + ~details: false + ~show_source: true + ?parsed:None) errs >>= fun () -> cctxt.error "transfer simulation failed" | Ok (oph, contracts) -> message_injection cctxt ~force:force ~contracts oph >>= fun () -> diff --git a/src/client/embedded/alpha/client_proto_context.mli b/src/client/embedded/alpha/client_proto_context.mli index fa967002e..077a221f2 100644 --- a/src/client/embedded/alpha/client_proto_context.mli +++ b/src/client/embedded/alpha/client_proto_context.mli @@ -57,7 +57,7 @@ val originate_contract: balance:Tez.t -> ?delegatable:bool -> ?delegatePubKey:public_key_hash -> - code:Script.code -> + code:Script.expr -> init:string -> fee:Tez.t -> spendable:bool -> diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index 02de8a2e1..a9fc2ed4f 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -9,691 +9,21 @@ module Ed25519 = Environment.Ed25519 open Client_proto_args - -let report_parse_error prefix exn = - let open Lexing in - let open Script_located_ir in - let print_point ppf { line ; column } = - Format.fprintf ppf - "at line %d character %d" - line column in - let print_token ppf = function - | Michelson_parser.Open_paren - | Michelson_parser.Close_paren -> - Format.fprintf ppf "parenthesis" - | Michelson_parser.Open_brace - | Michelson_parser.Close_brace -> - Format.fprintf ppf "curly brace" - | Michelson_parser.String _ -> - Format.fprintf ppf "string constant" - | Michelson_parser.Int _ -> - Format.fprintf ppf "integer constant" - | Michelson_parser.Ident _ -> - Format.fprintf ppf "identifier" - | Michelson_parser.Annot _ -> - Format.fprintf ppf "annotation" - | Michelson_parser.Comment _ - | Michelson_parser.Eol_comment _ -> - Format.fprintf ppf "comment" - | Michelson_parser.Semi -> - Format.fprintf ppf "semi colon" in - let print_loc ppf loc = - Format.fprintf ppf "in %s, " prefix ; - if loc.start.line = loc.stop.line then - if loc.start.column = loc.stop.column then - Format.fprintf ppf - "at line %d character %d" - loc.start.line loc.start.column - else - Format.fprintf ppf - "at line %d characters %d to %d" - loc.start.line loc.start.column loc.stop.column - else - Format.fprintf ppf - "from line %d character %d to line %d character %d" - loc.start.line loc.start.column loc.stop.line loc.stop.column in - match exn with - | Script_located_ir.Missing_program_field n -> - failwith "missing script %s" n - | Michelson_parser.Invalid_utf8_sequence (point, str) -> - failwith "%a, invalid UTF-8 sequence %S" print_point point str - | Michelson_parser.Unexpected_character (point, str) -> - failwith "%a, unexpected character %s" print_point point str - | Michelson_parser.Undefined_escape_character (point, str) -> - failwith "%a, undefined escape character \"%s\"" print_point point str - | Michelson_parser.Missing_break_after_number point -> - failwith "%a, missing break" print_point point - | Michelson_parser.Unterminated_string loc -> - failwith "%a, unterminated string" print_loc loc - | Michelson_parser.Unterminated_integer loc -> - failwith "%a, unterminated integer" print_loc loc - | Michelson_parser.Unterminated_comment loc -> - failwith "%a, unterminated comment" print_loc loc - | Michelson_parser.Unclosed { loc ; token } -> - failwith "%a, unclosed %a" print_loc loc print_token token - | Michelson_parser.Unexpected { loc ; token } -> - failwith "%a, unexpected %a" print_loc loc print_token token - | Michelson_parser.Extra { loc ; token } -> - failwith "%a, extra %a" print_loc loc print_token token - | Michelson_parser.Misaligned node -> - failwith "%a, misaligned expression" print_loc (node_location node) - | Michelson_parser.Empty -> - failwith "empty expression" - | Failure s -> - failwith "%s" s - | exn -> - failwith "%s" @@ Printexc.to_string exn - -let print_location_mark ppf = function - | None -> () - | Some l -> Format.fprintf ppf " /* %d */" l - -let no_locations _ = None - -let print_annotation ppf = function - | None -> () - | Some a -> Format.fprintf ppf " %s@," a - -let rec print_expr_unwrapped_help emacs locations ppf = function - | Script.Prim (loc, name, [], None) -> - begin match locations loc with - | None -> Format.fprintf ppf "%s" name - | Some _ as l -> Format.fprintf ppf "%s%a" name print_location_mark l - end - | Script.Prim (loc, name, _, (Some _ as annot)) -> - Format.fprintf ppf (if emacs then "%s%a %a" else "@[%s%a@ %a]") - name print_location_mark (locations loc) print_annotation annot - | Script.Prim (loc, name, args, annot) -> - Format.fprintf ppf "@[%s%a%a@ %a@]" - name - print_location_mark (locations loc) - print_annotation annot - (Format.pp_print_list - ~pp_sep: Format.pp_print_space - (print_expr_help emacs locations)) - args - | Script.Seq (loc, [], None) -> - begin match locations loc with - | None -> Format.fprintf ppf "{}" - | Some _ as l -> Format.fprintf ppf "{%a }" print_location_mark l - end - | Script.Seq (loc, exprs, annot) -> - begin match locations loc with - | None -> Format.fprintf ppf "@[{ " - | Some _ as l -> Format.fprintf ppf "@[{%a@ " print_location_mark l - end ; - Format.fprintf ppf "%a%a@] }" - (Format.pp_print_list - ~pp_sep: (fun ppf () -> Format.fprintf ppf " ;@ ") - (print_expr_unwrapped_help emacs locations)) - exprs - print_annotation annot - | Script.Int (loc, n) -> - Format.fprintf ppf "%s%a" n print_location_mark (locations loc) - | Script.String (loc, s) -> - Format.fprintf ppf "%S%a" s print_location_mark (locations loc) - -and print_expr_help emacs locations ppf = function - | Script.Prim (_, _, _ :: _, _) - | Script.Prim (_, _, [], Some _) as expr -> - Format.fprintf ppf "(%a)" (print_expr_unwrapped_help emacs locations) expr - | Script.Prim (loc, _, [], None) as expr when locations loc <> None -> - Format.fprintf ppf "(%a)" (print_expr_unwrapped_help emacs locations) expr - | expr -> print_expr_unwrapped_help emacs locations ppf expr - -let print_expr_unwrapped = print_expr_unwrapped_help false -let print_expr = print_expr_help false - -let print_storage ppf ({ storage } : Script.storage) = - print_expr no_locations ppf storage - -let print_stack_help emacs ppf = function - | [] -> Format.fprintf ppf (if emacs then "()" else "[]") - | more -> - Format.fprintf ppf (if emacs then "(%a)" else "@[[ %a ]@]") - (Format.pp_print_list - ~pp_sep: (fun ppf () -> Format.fprintf ppf (if emacs then "@ " else " :@ ")) - ((if emacs then print_expr else print_expr_unwrapped) no_locations)) - more - -let print_stack = print_stack_help false - -let print_emacs_stack = print_stack_help true - -let print_typed_code locations ppf (expr, type_map) = - let print_stack ppf = function - | [] -> Format.fprintf ppf "[]" - | more -> - Format.fprintf ppf "@[[ %a ]@]" - (Format.pp_print_list - ~pp_sep: (fun ppf () -> Format.fprintf ppf " :@ ") - (print_expr_unwrapped no_locations)) - more in - let print_annot ppf = function - | None -> () - | Some annot -> Format.fprintf ppf " %s@," annot in - let rec print_typed_code_unwrapped ppf expr = - match expr with - | Script.Prim (loc, name, [], None) -> - Format.fprintf ppf "%s%a" - name print_location_mark (locations loc) - | Script.Prim (loc, name, [], Some annot) -> - Format.fprintf ppf "(%s %s%a)" - name annot print_location_mark (locations loc) - | Script.Prim (loc, name, args, annot) -> - Format.fprintf ppf "@[%s%a%a@ %a@]" - name print_annot annot print_location_mark (locations loc) - (Format.pp_print_list - ~pp_sep: Format.pp_print_space - print_typed_code) - args - | Script.Seq (loc, [], None) -> - begin match List.assoc loc type_map with - | exception Not_found -> Format.fprintf ppf "{}" - | (first, _) -> - match locations loc with - | None -> - Format.fprintf ppf "{} /* %a */" - print_stack first - | Some _ as l -> - Format.fprintf ppf "{%a %a }" - print_location_mark l print_stack first - end - | Script.Seq (loc, [], Some annot) -> - begin match List.assoc loc type_map with - | exception Not_found -> Format.fprintf ppf "{ %@%s }" annot - | (first, _) -> - match locations loc with - | None -> - Format.fprintf ppf "{ %@%s } /* %a */" - annot - print_stack first - | Some _ as l -> - Format.fprintf ppf "{ %@%s%a %a }" - annot print_location_mark l print_stack first - end - | Script.Seq (loc, exprs, annot) -> - begin match locations loc, annot with - | None, None -> - Format.fprintf ppf "@[{ " - | None, Some annot -> - Format.fprintf ppf "@[{ %@%s@," annot - | Some _ as l, _ -> - Format.fprintf ppf "@[{%a%a@," - print_annot annot - print_location_mark l - end ; - let rec loop = function - | [] -> assert false - | [ Script.Int (loc, _) | String (loc, _) | Prim (loc, _, _, _) as expr ] -> - begin match List.assoc loc type_map with - | exception Not_found -> - Format.fprintf ppf "%a }@]" - print_typed_code_unwrapped expr - | (before, after) -> - Format.fprintf ppf "/* %a */@,%a@,/* %a */ }@]" - print_stack before - print_typed_code_unwrapped expr - print_stack after - end ; - | Script.Int (loc, _) | String (loc, _) | Prim (loc, _, _, _) as expr :: rest -> - begin match List.assoc loc type_map with - | exception Not_found -> - Format.fprintf ppf "%a ;@," - print_typed_code_unwrapped expr ; - loop rest - | (before, _) -> - Format.fprintf ppf "/* %a */@,%a ;@," - print_stack before - print_typed_code_unwrapped expr ; - loop rest - end ; - | [ Seq (_, _, _) as expr ] -> - Format.fprintf ppf "%a }@]" - print_typed_code_unwrapped expr - | Seq (_, _, _) as expr :: rest -> - Format.fprintf ppf "%a@," - print_typed_code_unwrapped expr ; - loop rest in - loop exprs ; - | Script.Int (loc, n) -> - Format.fprintf ppf "%s%a" n print_location_mark (locations loc) - | Script.String (loc, s) -> - Format.fprintf ppf "%S%a" s print_location_mark (locations loc) - and print_typed_code ppf = function - | Script.Prim (_, _, _ :: _, _) as expr -> - Format.fprintf ppf "(%a)" print_typed_code_unwrapped expr - | expr -> print_typed_code_unwrapped ppf expr in - print_typed_code_unwrapped ppf expr - -let print_program locations ppf ((c : Script.code), type_map) = - Format.fprintf ppf - "@[%a ;@,%a ;@,%a ;@,\ - @[code@ %a@]@]" - (print_expr_unwrapped no_locations) (Script.Prim (-1, "storage", [ c.storage_type ], None)) - (print_expr_unwrapped no_locations) (Script.Prim (-1, "parameter", [ c.arg_type ], None)) - (print_expr_unwrapped no_locations) (Script.Prim (-1, "return", [ c.ret_type ], None)) - (print_typed_code locations) (c.code, type_map) - -let collect_error_locations errs = - let open Script_typed_ir in - let open Script_ir_translator in - let open Script_interpreter in - let rec collect acc = function - | (Ill_typed_data (_, _, _) - | Ill_formed_type (_, _) - | Ill_typed_contract (_, _, _, _, _)) :: _ - | [] -> acc - | (Invalid_arity (loc, _, _, _) - | Invalid_namespace (loc, _, _, _) - | Invalid_primitive (loc, _, _) - | Invalid_case (loc, _) - | Invalid_kind (loc, _, _) - | Fail_not_in_tail_position loc - | Undefined_binop (loc, _, _, _) - | Undefined_unop (loc, _, _) - | Bad_return (loc, _, _) - | Bad_stack (loc, _, _, _) - | Unmatched_branches (loc, _, _) - | Transfer_in_lambda loc - | Transfer_in_dip loc - | Invalid_constant (loc, _, _) - | Invalid_contract (loc, _) - | Comparable_type_expected (loc, _) - | Overflow loc - | Reject loc) :: rest -> - collect (loc :: acc) rest - | _ :: rest -> collect acc rest in - collect [] errs - -let report_errors cctxt errs = - let open Client_commands in - let open Script_typed_ir in - let open Script_ir_translator in - let open Script_interpreter in - let rec print_ty (type t) ppf (ty : t ty) = - let expr = unparse_ty ty in - print_expr no_locations ppf expr in - let rec print_stack_ty (type t) ?(depth = max_int) ppf (s : t stack_ty) = - let rec loop - : type t. int -> Format.formatter -> t stack_ty -> unit - = fun depth ppf -> function - | Empty_t -> () - | _ when depth <= 0 -> - Format.fprintf ppf "..." - | Item_t (last, Empty_t) -> - Format.fprintf ppf "%a" - print_ty last - | Item_t (last, rest) -> - Format.fprintf ppf "%a :@ %a" - print_ty last (loop (depth - 1)) rest in - match s with - | Empty_t -> - Format.fprintf ppf "[]" - | sty -> - Format.fprintf ppf "@[[ %a ]@]" (loop depth) sty in - let rec print_enumeration ppf = function - | [ single ] -> - Format.fprintf ppf "%a" - Format.pp_print_text single - | [ prev ; last ] -> - Format.fprintf ppf "%a@ or@ %a" - Format.pp_print_text prev Format.pp_print_text last - | first :: rest -> - Format.fprintf ppf "%a,@ %a" - Format.pp_print_text first print_enumeration rest - | [] -> assert false in - let print_error locations err = - let print_loc ppf loc = - match locations loc with - | None -> - Format.fprintf ppf "At (unmarked) location %d, " loc - | Some loc -> - Format.fprintf ppf "At mark /* %d */, " loc in - match err with - | Ill_typed_data (name, expr, ty) -> - cctxt.warning - "@[@[Ill typed %adata:@ %a@]@ \ - @[is not an expression of type@ %a@]@]" - (fun ppf -> function - | None -> () - | Some s -> Format.fprintf ppf "%s " s) - name - (print_expr locations) expr - print_ty ty - | Ill_formed_type (name, expr) -> - cctxt.warning - "@[Ill formed type %aexpression@ %a@]" - (fun ppf -> function - | None -> () - | Some s -> Format.fprintf ppf "%s " s) - name - (print_expr locations) expr - | Apply.Bad_contract_parameter (c, None, _) -> - cctxt.warning - "@[Account %a is not a smart contract, it does not take arguments.@,\ - The `-arg' flag cannot be used when transferring to an account.@]" - Contract.pp c - | Apply.Bad_contract_parameter (c, Some expected, None) -> - cctxt.warning - "@[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_unwrapped no_locations) expected - | Apply.Bad_contract_parameter (c, Some expected, Some argument) -> - cctxt.warning - "@[Contract %a expected an argument of type@, %a@but received@, %a@]" - Contract.pp c - (print_expr_unwrapped no_locations) expected - (print_expr_unwrapped no_locations) argument - | Ill_typed_contract (expr, arg_ty, ret_ty, storage_ty, type_map) -> - cctxt.warning - "@[Ill typed contract:@ %a@]" - (print_program locations) - ({ Script.storage_type = unparse_ty storage_ty ; - arg_type = unparse_ty arg_ty ; - ret_type = unparse_ty ret_ty ; - code = expr }, type_map) - | Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty) -> - cctxt.warning - "@[Runtime error in contract %a:@ %a@]" - Contract.pp contract - (print_program locations) - ({ Script.storage_type = unparse_ty storage_ty ; - arg_type = unparse_ty arg_ty ; - ret_type = unparse_ty ret_ty ; - code = expr }, []) - | Invalid_arity (loc, name, exp, got) -> - cctxt.warning - "%aprimitive %s expects %d arguments but is given %d." - print_loc loc name exp got - | Invalid_namespace (loc, name, exp, got) -> - let human_namespace = function - | Instr_namespace -> ("an", "instruction") - | Type_namespace -> ("a", "type name") - | Constant_namespace -> ("a", "constant constructor") in - cctxt.warning - "@[%aunexpected %s %s, only@ %s@ %s@ can@ be@ used@ here." - print_loc loc - (snd (human_namespace got)) - name - (fst (human_namespace exp)) (snd (human_namespace exp)) - | Invalid_primitive (loc, exp, got) -> - cctxt.warning - "@[%ainvalid primitive %s, only@ %a@ can@ be@ used@ here." - print_loc loc - got - print_enumeration exp - | Invalid_case (loc, name) -> - cctxt.warning - "%a%s is not a valid primitive name." - print_loc loc - name - | Invalid_kind (loc, exp, got) -> - let human_kind = function - | Seq_kind -> ("a", "sequence") - | Prim_kind -> ("a", "primitive") - | Int_kind -> ("an", "int") - | String_kind -> ("a", "string") in - cctxt.warning - "@[%aunexpected %s, only@ %a@ can@ be@ used@ here." - print_loc loc - (snd (human_kind got)) - print_enumeration - (List.map (fun k -> let (a, n) = human_kind k in a ^ " " ^ n) exp) - | Duplicate_map_keys (_, expr) -> - cctxt.warning - "@[Map literals cannot contain duplicate keys, \ - however a duplicate key was found:@ \ - @[%a@]" - (print_expr no_locations) expr - | Unordered_map_keys (_, expr) -> - cctxt.warning - "@[Keys in a map literal must be in strictly ascending order, \ - but they were unordered in literal:@ \ - @[%a@]" - (print_expr no_locations) expr - | Duplicate_set_values (_, expr) -> - cctxt.warning - "@[Set literals cannot contain duplicate values, \ - however a duplicate value was found:@ \ - @[%a@]" - (print_expr no_locations) expr - | Unordered_set_values (_, expr) -> - cctxt.warning - "@[Values in a set literal must be in strictly ascending order, \ - but they were unordered in literal:@ \ - @[%a@]" - (print_expr no_locations) expr - | Fail_not_in_tail_position loc -> - cctxt.warning - "%aThe FAIL instruction must appear in a tail position." - print_loc loc - | Undefined_binop (loc, name, tya, tyb) -> - cctxt.warning - "@[@[%aoperator %s is undefined between@ %a@]@ \ - @[and@ %a.@]@]" - print_loc loc - name - print_ty tya - print_ty tyb - | Undefined_unop (loc, name, ty) -> - cctxt.warning - "@[@[%aoperator %s is undefined on@ %a@]@]" - print_loc loc - name - print_ty ty - | Bad_return (loc, got, exp) -> - cctxt.warning - "@[%awrong stack type at end of body:@,\ - - @[expected return stack type:@ %a,@]@,\ - - @[actual stack type:@ %a.@]@]" - print_loc loc - (fun ppf -> print_stack_ty ppf) (Item_t (exp, Empty_t)) - (fun ppf -> print_stack_ty ppf) got - | Bad_stack (loc, name, depth, sty) -> - cctxt.warning - "@[%awrong stack type for instruction %s:@ %a.@]" - print_loc loc name (print_stack_ty ~depth) sty - | Unmatched_branches (loc, sta, stb) -> - cctxt.warning - "@[%atwo branches don't end with the same stack type:@,\ - - @[first stack type:@ %a,@]@,\ - - @[other stack type:@ %a.@]@]" - print_loc loc - (fun ppf -> print_stack_ty ppf) sta - (fun ppf -> print_stack_ty ppf) stb - | Transfer_in_lambda loc -> - cctxt.warning - "%aThe TRANSFER_TOKENS instruction cannot appear in a lambda." - print_loc loc - | Transfer_in_dip loc -> - cctxt.warning - "%aThe TRANSFER_TOKENS instruction cannot appear within a DIP." - print_loc loc - | Bad_stack_length -> - cctxt.warning - "Bad stack length." - | Bad_stack_item lvl -> - cctxt.warning - "Bad stack item %d ." - lvl - | Invalid_constant (loc, got, exp) -> - cctxt.warning - "@[@[%avalue@ %a@]@ \ - @[is invalid for type@ %a.@]@]" - print_loc loc - (fun ppf -> print_expr no_locations ppf) got - print_ty exp - | Invalid_contract (loc, contract) -> - cctxt.warning - "%ainvalid contract %a." - print_loc loc Contract.pp contract - | Comparable_type_expected (loc, ty) -> - cctxt.warning "%acomparable type expected." - print_loc loc >>= fun () -> - cctxt.warning "@[@[Type@ %a@]@ is not comparable.@]" - print_ty ty - | Inconsistent_types (tya, tyb) -> - cctxt.warning - "@[@[Type@ %a@]@ \ - @[is not compatible with type@ %a.@]@]" - print_ty tya print_ty tyb - | Reject _ -> cctxt.warning "Script reached FAIL instruction" - | Overflow _ -> cctxt.warning "Unexpected arithmetic overflow" - | err -> - cctxt.warning "%a" - Environment.Error_monad.pp_print_error [ err ] in - let rec print_error_trace locations errs = - let locations = match errs with - | (Ill_typed_data (_, _, _) - | Ill_formed_type (_, _) - | Ill_typed_contract (_, _, _, _, _) - | Runtime_contract_error (_, _, _, _, _)) :: rest -> - let collected = - collect_error_locations rest in - let assoc, _ = - List.fold_left - (fun (acc, i) l -> - if List.mem_assoc l acc then - (acc, i) - else - ((l, i) :: acc, i + 1)) - ([], 1) collected in - (fun l -> try Some (List.assoc l assoc) with Not_found -> None) - | _ -> locations in - match errs with - | [] -> Lwt.return () - | err :: errs -> - print_error locations err >>= fun () -> - print_error_trace locations errs in - Lwt_list.iter_s - (function - | Environment.Ecoproto_error errs -> - print_error_trace no_locations errs - | err -> cctxt.warning "%a" pp_print_error [ err ]) - errs - -type 'a parsed = - { ast : 'a ; - source : string ; - loc_table : (string * (int * Script_located_ir.location) list) list } - -let parse_program source = - try - let fields = Michelson_parser.parse_toplevel (Michelson_parser.tokenize source) in - let fields = List.map Script_located_ir.strip_locations fields in - let rec get_field n = function - | (Script.Prim (_, pn, [ ctns ], _), locs) :: _ when n = pn -> ctns, locs - | _ :: rest -> get_field n rest - | [] -> raise (Script_located_ir.Missing_program_field n) in - let code, code_loc_table = get_field "code" fields in - let arg_type, parameter_loc_table = get_field "parameter" fields in - let ret_type, return_loc_table = get_field "return" fields in - let storage_type, storage_loc_table = get_field "storage" fields in - let ast = Script.{ code ; arg_type ; ret_type ; storage_type } in - let loc_table = - [ "code", code_loc_table ; - "parameter", parameter_loc_table ; - "return", return_loc_table ; - "storage", storage_loc_table ] in - return { ast ; source ; loc_table } - with - | exn -> report_parse_error "program" exn - -let parse_data source = - try - let node = Michelson_parser.parse_expression (Michelson_parser.tokenize source) in - let ast, loc_table = Script_located_ir.strip_locations node in - let loc_table = [ "data", loc_table ] in - return { ast ; source ; loc_table } - with - | exn -> report_parse_error "data" exn - -let parse_data_type source = - try - let node = Michelson_parser.parse_expression (Michelson_parser.tokenize source) in - let ast, loc_table = Script_located_ir.strip_locations node in - let loc_table = [ "data", loc_table ] in - return { ast ; source ; loc_table } - with - | exn -> report_parse_error "type" exn - -let unexpand_macros type_map (program : Script.code) = - let open Script in - let rec first_prim_in_sequence = function - | Int _ | String _ -> None - | Prim (loc, _, _, _) -> Some loc - | Seq (_, children, _) -> - let rec loop = function - | [] -> None - | child :: children -> - match first_prim_in_sequence child with - | None -> loop children - | Some loc -> Some loc in - loop children in - let rec last_prim_in_sequence = function - | Int _ | String _ -> None - | Prim (loc, _, _, _) -> Some loc - | Seq (_, children, _) -> - let rec reversed = function - | [] -> None - | child :: children -> - match last_prim_in_sequence child with - | None -> reversed children - | Some loc -> Some loc in - reversed (List.rev children) in - let rec unexpand type_map original = - match Michelson_macros.unexpand original with - | Seq (loc, children, annot) -> - let type_map, children = - List.fold_left - (fun (type_map, acc) node -> - let type_map, node = unexpand type_map node in - type_map, node :: acc) - (type_map, []) children in - type_map, Seq (loc, List.rev children, annot) - | Prim (loc, name, children, annot) -> - let type_map = - match original with - | Seq _ -> - if List.mem_assoc loc type_map then - type_map - else - begin match first_prim_in_sequence original, last_prim_in_sequence original with - | None, _ | _, None -> type_map - | Some floc, Some lloc -> - let fty, _ = List.assoc floc type_map in - let _, lty = List.assoc lloc type_map in - (loc, (fty, lty)) :: type_map - end - | _ -> type_map in - let type_map, children = - List.fold_left - (fun (type_map, acc) node -> - let type_map, node = unexpand type_map node in - type_map, node :: acc) - (type_map, []) children in - type_map, Prim (loc, name, List.rev children, annot) - | oth -> type_map, oth in - let type_map, code = unexpand type_map program.code in - type_map, { program with code } +open Michelson_v1_printer module Program = Client_aliases.Alias (struct - type t = Script.code parsed + type t = Michelson_v1_parser.parsed let encoding = - let open Data_encoding in - let loc_table_encoding = - assoc (list (tup2 uint16 Script_located_ir.location_encoding)) in - conv - (fun { ast ; source ; loc_table } -> (ast, source, loc_table)) - (fun (ast, source, loc_table) -> { ast ; source ; loc_table }) - (obj3 - (req "ast" Script.code_encoding) - (req "source" string) - (req "loc_table" loc_table_encoding)) - let of_source _cctxt s = parse_program s - let to_source _ { source } = return source + Data_encoding.conv + (fun { Michelson_v1_parser.source } -> source) + (fun source -> + match Michelson_v1_parser.parse_toplevel source with + | Ok parsed -> parsed + | Error _ -> Pervasives.failwith "could not decode Michelson program alias") + Data_encoding.string + let of_source _cctxt source = + Lwt.return (Michelson_v1_parser.parse_toplevel source) + let to_source _ { Michelson_v1_parser.source } = return source let name = "program" end) @@ -702,7 +32,7 @@ let group = title = "Commands for managing the record of known programs" } let data_parameter = - Cli_entries.parameter (fun _ -> parse_data) + Cli_entries.parameter (fun _ data -> Lwt.return (Michelson_v1_parser.parse_expression data)) let commands () = let open Cli_entries in @@ -772,36 +102,40 @@ let commands () = (fun (trace_stack, amount) program storage input cctxt -> let open Data_encoding in let print_errors errs = - report_errors cctxt errs >>= fun () -> + cctxt.warning "%a" + (Michelson_v1_error_reporter.report_errors + ~details:false + ~show_source: true + ~parsed:program) errs >>= fun () -> cctxt.error "error running program" >>= fun () -> return () in if trace_stack then Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config - cctxt.config.block program.ast (storage.ast, input.ast, amount) >>= function + cctxt.config.block program.expanded (storage.expanded, input.expanded, amount) >>= function | Ok (storage, output, trace) -> cctxt.message "@[@[storage@,%a@]@,\ @[output@,%a@]@,@[trace@,%a@]@]@." - (print_expr no_locations) storage - (print_expr no_locations) output + print_expr storage + print_expr output (Format.pp_print_list (fun ppf (loc, gas, stack) -> Format.fprintf ppf "- @[location: %d (remaining gas: %d)@,\ [ @[%a ]@]@]" loc gas - (Format.pp_print_list (print_expr no_locations)) + (Format.pp_print_list print_expr) stack)) trace >>= fun () -> return () | Error errs -> print_errors errs else Client_proto_rpcs.Helpers.run_code cctxt.rpc_config - cctxt.config.block program.ast (storage.ast, input.ast, amount) >>= function + cctxt.config.block program.expanded (storage.expanded, input.expanded, amount) >>= function | Ok (storage, output) -> cctxt.message "@[@[storage@,%a@]@,@[output@,%a@]@]@." - (print_expr no_locations) storage - (print_expr no_locations) output >>= fun () -> + print_expr storage + print_expr output >>= fun () -> return () | Error errs -> print_errors errs); @@ -814,64 +148,36 @@ let commands () = (fun (show_types, emacs_mode) program cctxt -> let open Data_encoding in Client_proto_rpcs.Helpers.typecheck_code - cctxt.rpc_config cctxt.config.block program.ast >>= fun res -> + cctxt.rpc_config cctxt.config.block program.expanded >>= fun res -> if emacs_mode then - let emacs_type_map type_map = - (Utils.filter_map - (fun (n, loc) -> - try - let bef, aft = List.assoc n type_map in - Some (loc, bef, aft) - with - Not_found -> None) - (List.assoc "code" program.loc_table), - []) in - begin match res with - | Ok type_map -> - Lwt.return (emacs_type_map type_map) + let type_map, errs = match res with + | Ok type_map -> type_map, [] + | Error (Environment.Ecoproto_error + (Script_ir_translator.Ill_typed_contract (_, type_map ) :: _) + :: _ as errs) -> + type_map, errs | Error errs -> - let msg = Buffer.create 5000 in - let cctxt = Client_commands.make_context - (fun _ t -> Buffer.add_string msg t ; Buffer.add_char msg '\n' ; Lwt.return ()) in - match errs with - | Environment.Ecoproto_error (Script_ir_translator.Ill_formed_type - (Some ("return" | "parameter" | "storage" as field), _) :: errs) :: _ -> - report_errors cctxt [ Environment.Ecoproto_error errs ] >>= fun () -> - Lwt.return ([], [ List.assoc 0 (List.assoc field program.loc_table), Buffer.contents msg ]) - | Environment.Ecoproto_error (Script_ir_translator.Ill_typed_contract (_, _, _, _, type_map) :: errs) :: _ -> - (report_errors cctxt [ Environment.Ecoproto_error errs ] >>= fun () -> - let (types, _) = emacs_type_map type_map in - let loc = match collect_error_locations errs with - | hd :: _ -> hd - | [] -> 0 in - Lwt.return (types, [ List.assoc loc (List.assoc "code" program.loc_table), Buffer.contents msg ])) - | _ -> Lwt.return ([], []) - end >>= fun (types, errors) -> + [], errs in cctxt.message - "((types . (%a)) (errors . (%a)))" - (Format.pp_print_list - (fun ppf ({ Script_located_ir.start = { point = s } ; stop = { point = e } }, - bef, aft) -> - Format.fprintf ppf "(%d %d %a %a)" (s + 1) (e + 1) - print_emacs_stack bef print_emacs_stack aft)) - types - (Format.pp_print_list - (fun ppf ({ Script_located_ir.start = { point = s } ; stop = { point = e } }, - err) -> - Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) err)) - errors >>= fun () -> + "(@[(types . %a)@ (errors . %a)@])" + Michelson_v1_emacs.print_type_map (program, type_map) + Michelson_v1_emacs.report_errors (program, errs) >>= fun () -> return () else match res with | Ok type_map -> - let type_map, program = unexpand_macros type_map program.ast in + let program = inject_types type_map program in cctxt.message "Well typed" >>= fun () -> if show_types then - cctxt.message "%a" (print_program no_locations) (program, type_map) >>= fun () -> + cctxt.message "%a" Micheline_printer.print_expr program >>= fun () -> return () else return () | Error errs -> - report_errors cctxt errs >>= fun () -> + cctxt.warning "%a" + (Michelson_v1_error_reporter.report_errors + ~details: show_types + ~show_source: true + ~parsed:program) errs >>= fun () -> cctxt.error "ill-typed program") ; command ~group ~desc: "ask the node to typecheck a data expression" @@ -886,12 +192,16 @@ let commands () = (fun () data exp_ty cctxt -> let open Data_encoding in Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config - cctxt.config.block (data.ast, exp_ty.ast) >>= function + cctxt.config.block (data.expanded, exp_ty.expanded) >>= function | Ok () -> cctxt.message "Well typed" >>= fun () -> return () | Error errs -> - report_errors cctxt errs >>= fun () -> + cctxt.warning "%a" + (Michelson_v1_error_reporter.report_errors + ~details:false + ~show_source: true + ?parsed:None) errs >>= fun () -> cctxt.error "ill-typed data") ; command ~group @@ -905,7 +215,7 @@ let commands () = (fun () data cctxt -> let open Data_encoding in Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config - cctxt.config.block (data.ast) >>= function + cctxt.config.block (data.expanded) >>= function | Ok hash -> cctxt.message "%S" hash >>= fun () -> return () @@ -928,7 +238,7 @@ let commands () = (fun () data (_, key) cctxt -> let open Data_encoding in Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config - cctxt.config.block (data.ast) >>= function + cctxt.config.block (data.expanded) >>= function | Ok hash -> let signature = Ed25519.sign key (MBytes.of_string hash) in cctxt.message "Hash: %S@.Signature: %S" diff --git a/src/client/embedded/alpha/client_proto_programs.mli b/src/client/embedded/alpha/client_proto_programs.mli index 2ff6d1df9..2a1bf9c71 100644 --- a/src/client/embedded/alpha/client_proto_programs.mli +++ b/src/client/embedded/alpha/client_proto_programs.mli @@ -7,19 +7,6 @@ (* *) (**************************************************************************) -type 'a parsed = - { ast : 'a ; - source : string ; - loc_table : (string * (int * Script_located_ir.location) list) list } - -val parse_program: string -> Script.code parsed tzresult Lwt.t -val parse_data: string -> Script.expr parsed tzresult Lwt.t -val parse_data_type: string -> Script.expr parsed tzresult Lwt.t - -val print_storage: Format.formatter -> Script.storage -> unit - -val report_errors: Client_commands.context -> error list -> unit Lwt.t - -module Program : Client_aliases.Alias with type t = Script.code parsed +module Program : Client_aliases.Alias with type t = Michelson_v1_parser.parsed val commands: unit -> Client_commands.command list diff --git a/src/client/embedded/alpha/client_proto_rpcs.mli b/src/client/embedded/alpha/client_proto_rpcs.mli index 63c8b0993..43999f42f 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.mli +++ b/src/client/embedded/alpha/client_proto_rpcs.mli @@ -137,7 +137,7 @@ module Context : sig block -> Contract.t -> Script.t option tzresult Lwt.t val storage: Client_rpcs.config -> - block -> Contract.t -> Script.storage option tzresult Lwt.t + block -> Contract.t -> Script.expr option tzresult Lwt.t end end @@ -155,18 +155,18 @@ module Helpers : sig (Contract.t list) tzresult Lwt.t val run_code: Client_rpcs.config -> - block -> Script.code -> + block -> Script.expr -> (Script.expr * Script.expr * Tez.t) -> (Script.expr * Script.expr) tzresult Lwt.t val trace_code: Client_rpcs.config -> - block -> Script.code -> + block -> Script.expr -> (Script.expr * Script.expr * Tez.t) -> (Script.expr * Script.expr * (Script.location * int * Script.expr list) list) tzresult Lwt.t val typecheck_code: Client_rpcs.config -> - block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t + block -> Script.expr -> Script_ir_translator.type_map tzresult Lwt.t val typecheck_data: Client_rpcs.config -> block -> Script.expr * Script.expr -> unit tzresult Lwt.t diff --git a/src/client/embedded/alpha/michelson_macros.ml b/src/client/embedded/alpha/michelson_macros.ml index dec790b11..cc164f8db 100644 --- a/src/client/embedded/alpha/michelson_macros.ml +++ b/src/client/embedded/alpha/michelson_macros.ml @@ -7,7 +7,9 @@ (* *) (**************************************************************************) -open Script_located_ir +open Micheline + +type 'l node = ('l, string) Micheline.node let expand_caddadr original = match original with @@ -427,8 +429,6 @@ let expand original = expand_if_some ; expand_if_right ] -open Script - let unexpand_caddadr expanded = let rec rsteps acc = function | [] -> Some acc diff --git a/src/client/embedded/alpha/michelson_macros.mli b/src/client/embedded/alpha/michelson_macros.mli index 21802f306..2d2efef04 100644 --- a/src/client/embedded/alpha/michelson_macros.mli +++ b/src/client/embedded/alpha/michelson_macros.mli @@ -7,34 +7,34 @@ (* *) (**************************************************************************) -open Script_located_ir +open Micheline -val expand : node -> node +type 'l node = ('l, string) Micheline.node -val expand_caddadr : node -> node option -val expand_set_caddadr : node -> node option -val expand_map_caddadr : node -> node option -val expand_dxiiivp : node -> node option -val expand_paaiair : node -> node option -val expand_duuuuup : node -> node option -val expand_compare : node -> node option -val expand_asserts : node -> node option -val expand_unpaaiair : node -> node option -val expand_if_some : node -> node option -val expand_if_right : node -> node option +val expand : 'l node -> 'l node -open Script +val expand_caddadr : 'l node -> 'l node option +val expand_set_caddadr : 'l node -> 'l node option +val expand_map_caddadr : 'l node -> 'l node option +val expand_dxiiivp : 'l node -> 'l node option +val expand_paaiair : 'l node -> 'l node option +val expand_duuuuup : 'l node -> 'l node option +val expand_compare : 'l node -> 'l node option +val expand_asserts : 'l node -> 'l node option +val expand_unpaaiair : 'l node -> 'l node option +val expand_if_some : 'l node -> 'l node option +val expand_if_right : 'l node -> 'l node option -val unexpand : expr -> expr +val unexpand : 'l node -> 'l node -val unexpand_caddadr : expr -> expr option -val unexpand_set_caddadr : expr -> expr option -val unexpand_map_caddadr : expr -> expr option -val unexpand_dxiiivp : expr -> expr option -val unexpand_paaiair : expr -> expr option -val unexpand_duuuuup : expr -> expr option -val unexpand_compare : expr -> expr option -val unexpand_asserts : expr -> expr option -val unexpand_unpaaiair : expr -> expr option -val unexpand_if_some : expr -> expr option -val unexpand_if_right : expr -> expr option +val unexpand_caddadr : 'l node -> 'l node option +val unexpand_set_caddadr : 'l node -> 'l node option +val unexpand_map_caddadr : 'l node -> 'l node option +val unexpand_dxiiivp : 'l node -> 'l node option +val unexpand_paaiair : 'l node -> 'l node option +val unexpand_duuuuup : 'l node -> 'l node option +val unexpand_compare : 'l node -> 'l node option +val unexpand_asserts : 'l node -> 'l node option +val unexpand_unpaaiair : 'l node -> 'l node option +val unexpand_if_some : 'l node -> 'l node option +val unexpand_if_right : 'l node -> 'l node option diff --git a/src/client/embedded/alpha/michelson_parser.ml b/src/client/embedded/alpha/michelson_parser.ml deleted file mode 100644 index a38831391..000000000 --- a/src/client/embedded/alpha/michelson_parser.ml +++ /dev/null @@ -1,521 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2016. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -open Script_located_ir - -exception Invalid_utf8_sequence of point * string -exception Unexpected_character of point * string -exception Undefined_escape_character of point * string -exception Missing_break_after_number of point -exception Unterminated_string of location -exception Unterminated_integer of location -exception Unterminated_comment of location - -type token_value = - | String of string - | Int of string - | Ident of string - | Annot of string - | Comment of string - | Eol_comment of string - | Semi - | Open_paren | Close_paren - | Open_brace | Close_brace - -type token = - { token : token_value ; - loc : location } - -let tokenize source = - let decoder = Uutf.decoder ~encoding:`UTF_8 (`String source) in - let here () = - { point = Uutf.decoder_count decoder ; - byte = Uutf.decoder_byte_count decoder ; - line = Uutf.decoder_line decoder ; - column = Uutf.decoder_col decoder } in - let tok start stop token = - { loc = { start ; stop } ; token } in - let stack = ref [] in - let next () = - match !stack with - | charloc :: charlocs -> - stack := charlocs ; - charloc - | [] -> - let loc = here () in - match Uutf.decode decoder with - | `Await -> assert false - | `Malformed s -> raise (Invalid_utf8_sequence (loc, s)) - | `Uchar _ | `End as other -> other, loc in - let back charloc = - stack := charloc :: !stack in - let uchar_to_char c = - if Uchar.is_char c then - Some (Uchar.to_char c) - else - None in - let rec skip acc = - match next () with - | `End, _ -> List.rev acc - | `Uchar c, start -> - begin match uchar_to_char c with - | Some ('a'..'z' | 'A'..'Z') -> ident acc start (fun s -> Ident s) - | Some '@' -> ident acc start (fun s -> Annot s) - | Some '-' -> - begin match next () with - | `End, stop -> - raise (Unterminated_integer { start ; stop }) - | `Uchar c, stop -> - begin match uchar_to_char c with - | Some '0' -> base acc start - | Some ('1'..'9') -> integer `dec acc start false - | Some _ | None -> - raise (Unterminated_integer { start ; stop }) - end - end - | Some '0' -> base acc start - | Some ('1'..'9') -> integer `dec acc start false - | Some (' ' | '\n') -> skip acc - | Some ';' -> skip (tok start (here ()) Semi :: acc) - | Some '{' -> skip (tok start (here ()) Open_brace :: acc) - | Some '}' -> skip (tok start (here ()) Close_brace :: acc) - | Some '(' -> skip (tok start (here ()) Open_paren :: acc) - | Some ')' -> skip (tok start (here ()) Close_paren :: acc) - | Some '"' -> string acc [] start - | Some '#' -> eol_comment acc start - | Some '/' -> - begin match next () with - | `Uchar c, _ when Uchar.equal c (Uchar.of_char '*') -> - comment acc start 0 - | (`Uchar _ | `End), _ -> - raise (Unexpected_character (start, "/")) - end - | Some _ | None -> - let byte = Uutf.decoder_byte_count decoder in - let s = String.sub source start.byte (byte - start.byte) in - raise (Unexpected_character (start, s)) - end - and base acc start = - match next () with - | (`Uchar c, stop) as charloc -> - begin match uchar_to_char c with - | Some ('0'.. '9') -> integer `dec acc start false - | Some 'x' -> integer `hex acc start true - | Some 'b' -> integer `bin acc start true - | Some ('a' | 'c'..'w' | 'y' | 'z' | 'A'..'Z') -> - raise (Missing_break_after_number stop) - | Some _ | None -> - back charloc ; - skip (tok start (here ()) (Int "0") :: acc) - end - | (_, stop) as other -> - back other ; - skip (tok start stop (Int "0") :: acc) - and integer base acc start first = - let tok stop = - let value = - String.sub source start.byte (stop.byte - start.byte) in - tok start stop (Int value) in - match next () with - | (`Uchar c, stop) as charloc -> - begin match base, Uchar.to_char c with - | `dec, ('0'.. '9') -> - integer `dec acc start false - | `dec, ('a'..'z' | 'A'..'Z') -> - raise (Missing_break_after_number stop) - | `hex, ('0'..'9' | 'a'..'f' | 'A'..'F') -> - integer `hex acc start false - | `hex, ('g'..'z' | 'G'..'Z') -> - raise (Missing_break_after_number stop) - | `bin, ('0' | '1') -> - integer `bin acc start false - | `bin, ('2'..'9' | 'a'..'z' | 'A'..'Z') -> - raise (Missing_break_after_number stop) - | (`bin | `hex), _ when first -> - raise (Unterminated_integer { start ; stop }) - | _ -> - back charloc ; - skip (tok stop :: acc) - end - | (`End, stop) as other -> - if first && base = `bin || base = `hex then - raise (Unterminated_integer { start ; stop }) ; - back other ; - skip (tok stop :: acc) - and string acc sacc start = - let tok () = - tok start (here ()) (String (String.concat "" (List.rev sacc))) in - match next () with - | `End, stop -> raise (Unterminated_string { start ; stop }) - | `Uchar c, stop -> - match uchar_to_char c with - | Some '"' -> skip (tok () :: acc) - | Some '\n' -> raise (Unterminated_string { start ; stop }) - | Some '\\' -> - begin match next () with - | `End, stop -> raise (Unterminated_string { start ; stop }) - | `Uchar c, loc -> - match uchar_to_char c with - | Some '"' -> string acc ("\"" :: sacc) start - | Some 'r' -> string acc ("\r" :: sacc) start - | Some 'n' -> string acc ("\n" :: sacc) start - | Some 't' -> string acc ("\t" :: sacc) start - | Some 'b' -> string acc ("\b" :: sacc) start - | Some '\\' -> string acc ("\\" :: sacc) start - | Some _ | None -> - let byte = Uutf.decoder_byte_count decoder in - let s = String.sub source loc.byte (byte - loc.byte) in - raise (Undefined_escape_character (loc, s)) - end - | Some _ | None -> - let byte = Uutf.decoder_byte_count decoder in - let s = String.sub source stop.byte (byte - stop.byte) in - string acc (s :: sacc) start - and ident acc start ret = - let tok stop = - let name = - String.sub source start.byte (stop.byte - start.byte) in - tok start stop (ret name) in - match next () with - | (`Uchar c, stop) as charloc -> - begin match uchar_to_char c with - | Some ('a'..'z' | 'A'..'Z' | '_' | '0'..'9') -> - ident acc start ret - | Some _ | None -> - back charloc ; - skip (tok stop :: acc) - end - | (_, stop) as other -> - back other ; - skip (tok stop :: acc) - and comment acc start lvl = - match next () with - | `End, stop -> raise (Unterminated_comment { start ; stop }) - | `Uchar c, _ -> - begin match uchar_to_char c with - | Some '*' -> - begin match next () with - | `Uchar c, _ when Uchar.equal c (Uchar.of_char '/') -> - if lvl = 0 then - let stop = here () in - let text = - String.sub source start.byte (stop.byte - start.byte) in - skip (tok start stop (Comment text) :: acc) - else - comment acc start (lvl - 1) - | other -> - back other ; - comment acc start lvl - end - | Some '/' -> - begin match next () with - | `Uchar c, _ when Uchar.equal c (Uchar.of_char '*') -> - comment acc start (lvl + 1) - | other -> - back other ; - comment acc start lvl - end - | Some _ | None -> comment acc start lvl - end - and eol_comment acc start = - let tok stop = - let text = String.sub source start.byte (stop.byte - start.byte) in - tok start stop (Eol_comment text) in - match next () with - | `Uchar c, stop -> - begin match uchar_to_char c with - | Some '\n' -> skip (tok stop :: acc) - | Some _ | None -> eol_comment acc start - end - | (_, stop) as other -> - back other ; - skip (tok stop :: acc) in - skip [] - -(* Beginning of a sequence of consecutive primitives *) -let min_point : node list -> point = function - | [] -> point_zero - | Int ({ start }, _) :: _ - | String ({ start }, _) :: _ - | Prim ({ start }, _, _, _) :: _ - | Seq ({ start }, _, _) :: _ -> start - -(* End of a sequence of consecutive primitives *) -let rec max_point : node list -> point = function - | [] -> point_zero - | _ :: (_ :: _ as rest) -> max_point rest - | Int ({ stop }, _) :: [] - | String ({ stop }, _) :: [] - | Prim ({ stop }, _, _, _) :: [] - | Seq ({ stop }, _, _) :: [] -> stop - -(* An item in the parser's state stack. - Not every value of type [mode list] is a valid parsing context. - It must respect the following additional invariants. - - a state stack always ends in [Toplevel _], - - [Toplevel _] does not appear anywhere else, - - [Unwrapped _] cannot appear directly on top of [Wrapped _], - - [Wrapped _] cannot appear directly on top of [Sequence _], - - [Wrapped _] cannot appear directly on top of [Sequence _]. *) -type mode = - | Toplevel of node list - | Expression of node option - | Sequence of token * node list * string option - | Unwrapped of location * string * node list * string option - | Wrapped of token * string * node list * string option - -(* Enter a new parsing state. *) -let push_mode mode stack = - mode :: stack - -(* Leave a parsing state. *) -let pop_mode = function - | [] -> assert false - | _ :: rest -> rest - -(* Usually after a [pop_mode], jump back into the previous parsing - state, injecting the current reduction (insert the just parsed item - of a sequence or argument of a primitive application). *) -let fill_mode result = function - | [] -> assert false - | Expression _ :: _ :: _ -> assert false - | Expression (Some _) :: [] -> assert false - | Toplevel _ :: _ :: _ -> assert false - | Expression None :: [] -> - Expression (Some result) :: [] - | Toplevel exprs :: [] -> - Toplevel (result :: exprs) :: [] - | Sequence (token, exprs, annot) :: rest -> - Sequence (token, result :: exprs, annot) :: rest - | Wrapped (token, name, exprs, annot) :: rest -> - Wrapped (token, name, result :: exprs, annot) :: rest - | Unwrapped (start, name, exprs, annot) :: rest -> - Unwrapped (start, name, result :: exprs, annot) :: rest - -exception Unclosed of token -exception Unexpected of token -exception Extra of token -exception Misaligned of node -exception Empty - -let rec parse - ?expand:(do_expand = true) - ?check:(do_check = true) - tokens stack = - (* Two steps: - - 1. parse without checking indentation [parse] - - 2. check indentation [check] (inlined in 1) - - 3. expand macros (inlined in 1, after 2) *) - match stack, tokens with - (* Start by preventing all absurd cases, so now the pattern - matching exhaustivity can tell us that we treater all - possible tokens for all possible valid states. *) - | [], _ - | [ Wrapped _ ], _ - | [ Unwrapped _ ], _ - | Unwrapped _ :: Unwrapped _ :: _, _ - | Unwrapped _ :: Wrapped _ :: _, _ - | Toplevel _ :: _ :: _, _ - | Expression _ :: _ :: _, _ -> - assert false - (* Return *) - | Expression (Some result) :: _, [] -> - [ result ] - | Expression (Some _) :: _, token :: _ -> - raise (Unexpected token) - | Expression None :: _, [] -> - raise Empty - | Toplevel [ Seq (_, exprs, _) as expr ] :: [], - [] -> - if do_check then check ~toplevel: false expr ; - let exprs = - if do_expand then - List.map Michelson_macros.expand exprs - else exprs in - exprs - | Toplevel exprs :: [], - [] -> - let exprs = List.rev exprs in - let loc = { start = min_point exprs ; stop = max_point exprs } in - let expr = Seq (loc, exprs, None) in - if do_check then check ~toplevel: true expr ; - let exprs = - if do_expand then - List.map Michelson_macros.expand exprs - else exprs in - exprs - (* Ignore comments *) - | _, - { token = Eol_comment _ | Comment _ } :: rest -> - parse rest stack - | (Wrapped _ | Unwrapped _) :: _, - ({ token = Open_paren } as token) - :: { token = Eol_comment _ | Comment _ } :: rest -> - parse (token :: rest) stack - (* Erroneous states *) - | (Wrapped _ | Unwrapped _) :: _ , - ({ token = Open_paren } as token) - :: { token = Open_paren | Open_brace } :: _ - | Unwrapped _ :: Expression _ :: _ , - ({ token = Semi | Close_brace | Close_paren } as token) :: _ - | Expression None :: _ , - ({ token = Semi | Close_brace | Close_paren | Open_brace | Open_paren } as token) :: _ -> - raise (Unexpected token) - | (Sequence _ | Toplevel _) :: _ , - { token = Semi } :: ({ token = Semi } as token) :: _ -> - raise (Extra token) - | (Wrapped _ | Unwrapped _) :: _ , - { token = Open_paren } - :: ({ token = Int _ | String _ | Annot _ | Close_paren } as token) :: _ - | Unwrapped (_, _, _, _) :: Toplevel _ :: _, - ({ token = Close_brace } as token) :: _ - | Unwrapped (_, _, _, _) :: _, - ({ token = Close_paren } as token) :: _ - | Toplevel _ :: [], - ({ token = Close_paren } as token) :: _ - | Toplevel _ :: [], - ({ token = Close_brace } as token) :: _ - | _, - ({ token = Annot _ } as token) :: _ -> - raise (Unexpected token) - | Wrapped (token, _, _, _) :: _, - ({ token = Close_brace | Semi } :: _ | []) - | (Sequence _ | Toplevel _) :: _, - ({ token = Open_paren } as token) :: _ - | (Wrapped _ | Unwrapped _) :: _, - ({ token = Open_paren } as token) :: ({ token = Close_brace | Semi } :: _ | []) - | (Sequence (token, _, _) :: _ | Unwrapped _ :: Sequence (token, _, _) :: _), - ({ token = Close_paren } :: _ | [])-> - raise (Unclosed token) - (* Valid states *) - | (Toplevel _ | Sequence (_, _, _)) :: _ , - { token = Ident name ; loc } :: { token = Annot annot } :: rest -> - let mode = Unwrapped (loc, name, [], Some annot) in - parse rest (push_mode mode stack) - | (Expression None | Toplevel _ | Sequence (_, _, _)) :: _ , - { token = Ident name ; loc } :: rest -> - let mode = Unwrapped (loc, name, [], None) in - parse rest (push_mode mode stack) - | (Expression None | Sequence _ | Toplevel _ | Unwrapped _ | Wrapped _) :: _, - { token = Int value ; loc } :: rest -> - let expr : node = Int (loc, value) in - if do_check then check ~toplevel: false expr ; - let expr = - if do_expand then - Michelson_macros.expand expr - else expr in - parse rest (fill_mode expr stack) - | (Expression None | Sequence _ | Toplevel _ | Unwrapped _ | Wrapped _) :: _, - { token = String contents ; loc } :: rest -> - let expr : node = String (loc, contents) in - if do_check then check ~toplevel: false expr ; - let expr = - if do_expand then - Michelson_macros.expand expr - else expr in - parse rest (fill_mode expr stack) - | Sequence ({ loc = { start } }, exprs, annot) :: _ , - { token = Close_brace ; loc = { stop } } :: rest -> - let exprs = List.rev exprs in - let expr = Seq ({ start ; stop }, exprs, annot) in - if do_check then check ~toplevel: false expr ; - let expr = - if do_expand then - Michelson_macros.expand expr - else expr in - parse rest (fill_mode expr (pop_mode stack)) - | (Sequence _ | Toplevel _) :: _ , - { token = Semi } :: rest -> - parse rest stack - | Unwrapped ({ start ; stop }, name, exprs, annot) :: Expression _ :: _, - ([] as rest) - | Unwrapped ({ start ; stop }, name, exprs, annot) :: Toplevel _ :: _, - ({ token = Semi } :: _ | [] as rest) - | Unwrapped ({ start ; stop }, name, exprs, annot) :: Sequence _ :: _ , - ({ token = Close_brace | Semi } :: _ as rest) - | Wrapped ({ loc = { start ; stop } }, name, exprs, annot) :: _ , - { token = Close_paren } :: rest -> - let exprs = List.rev exprs in - let stop = if exprs = [] then stop else max_point exprs in - let expr = Prim ({ start ; stop }, name, exprs, annot) in - if do_check then check ~toplevel: false expr ; - let expr = - if do_expand then - Michelson_macros.expand expr - else expr in - parse rest (fill_mode expr (pop_mode stack)) - | (Wrapped _ | Unwrapped _) :: _ , - ({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot annot } :: rest -> - let mode = Wrapped (token, name, [], Some annot) in - parse rest (push_mode mode stack) - | (Wrapped _ | Unwrapped _) :: _ , - ({ token = Open_paren } as token) :: { token = Ident name } :: rest -> - let mode = Wrapped (token, name, [], None) in - parse rest (push_mode mode stack) - | (Wrapped _ | Unwrapped _) :: _ , - { token = Ident name ; loc } :: rest -> - let expr = Prim (loc, name, [], None) in - if do_check then check ~toplevel: false expr ; - let expr = - if do_expand then - Michelson_macros.expand expr - else expr in - parse rest (fill_mode expr stack) - | (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _) :: _ , - ({ token = Open_brace } as token) :: { token = Annot annot } :: rest -> - let mode = Sequence (token, [], Some annot) in - parse rest (push_mode mode stack) - | (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _) :: _ , - ({ token = Open_brace } as token) :: rest -> - let mode = Sequence (token, [], None) in - parse rest (push_mode mode stack) -(* indentation checker *) -and check ?(toplevel = false) = function - | Seq ({ start ; stop }, [], _) as expr -> - if start.column >= stop.column then - raise (Misaligned expr) - | Prim ({ start ; stop }, _, first :: rest, _) - | Seq ({ start ; stop }, first :: rest, _) as expr -> - let { column = first_column ; line = first_line } = - min_point [ first ] in - if start.column >= stop.column then - raise (Misaligned expr) ; - if not toplevel && start.column >= first_column then - raise (Misaligned expr) ; - (* In a sequence or in the arguments of a primitive, we - require all items to be aligned, but we relax the rule to - allow consecutive items to be writtem on the same line. *) - let rec in_line_or_aligned prev_start_line = function - | [] -> () - | expr :: rest -> - let { column ; line = start_line } = min_point [ expr ] in - let { line = stop_line } = max_point [ expr ] in - if stop_line <> prev_start_line - && column <> first_column then - raise (Misaligned expr) ; - in_line_or_aligned start_line rest in - in_line_or_aligned first_line rest - | Prim (_, _, [], _) | String _ | Int _ -> () - -let parse_expression ?expand ?check tokens = - let result = match tokens with - | ({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot annot } :: rest -> - let mode = Wrapped (token, name, [], Some annot) in - parse ?expand ?check rest [ mode ; Expression None ] - | ({ token = Open_paren } as token) :: { token = Ident name } :: rest -> - let mode = Wrapped (token, name, [], None) in - parse ?expand ?check rest [ mode ; Expression None ] - | _ -> - parse ?expand ?check tokens [ Expression None ] in - match result with - | [ single ] -> single - | _ -> assert false - -let parse_toplevel ?expand ?check tokens = - parse ?expand ?check tokens [ Toplevel [] ] diff --git a/src/client/embedded/alpha/michelson_parser.mli b/src/client/embedded/alpha/michelson_parser.mli deleted file mode 100644 index 5b972aa20..000000000 --- a/src/client/embedded/alpha/michelson_parser.mli +++ /dev/null @@ -1,44 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2016. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -open Script_located_ir - -exception Invalid_utf8_sequence of point * string -exception Unexpected_character of point * string -exception Undefined_escape_character of point * string -exception Missing_break_after_number of point -exception Unterminated_string of location -exception Unterminated_integer of location -exception Unterminated_comment of location - -type token_value = - | String of string - | Int of string - | Ident of string - | Annot of string - | Comment of string - | Eol_comment of string - | Semi - | Open_paren | Close_paren - | Open_brace | Close_brace - -type token = - { token : token_value ; - loc : location } - -val tokenize : string -> token list - -exception Unclosed of token -exception Unexpected of token -exception Extra of token -exception Misaligned of node -exception Empty - -val parse_toplevel : ?expand:bool -> ?check:bool -> token list -> node list -val parse_expression : ?expand:bool -> ?check:bool -> token list -> node diff --git a/src/client/embedded/alpha/michelson_v1_emacs.ml b/src/client/embedded/alpha/michelson_v1_emacs.ml new file mode 100644 index 000000000..2b5a7f932 --- /dev/null +++ b/src/client/embedded/alpha/michelson_v1_emacs.ml @@ -0,0 +1,107 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Micheline + +let print_expr ppf expr = + let rec print_expr ppf = function + | Int (_, value) -> Format.fprintf ppf "%s" value + | String (_, value) -> Micheline_printer.print_string ppf value + | Seq (_, items, _) -> + Format.fprintf ppf "(seq %a)" + (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr) + items + | Prim (_, name, [], _) -> + Format.fprintf ppf "%s" name + | Prim (_, name, items, _) -> + Format.fprintf ppf "(%s %a)" name + (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr) items in + let root = root (Michelson_v1_primitives.strings_of_prims expr) in + Format.fprintf ppf "@[%a@]" print_expr root + +open Micheline_parser +open Script_ir_translator + +let print_type_map ppf (parsed, type_map) = + let rec print_expr_types ppf = function + | Seq (loc, [], _) + | Prim (loc, _, [], _) + | Int (loc, _) + | String (loc, _) -> + print_item ppf loc + | Seq (loc, items, _) + | Prim (loc, _, items, _) -> + print_item ppf loc ; + List.iter (print_expr_types ppf) items + and print_stack ppf items = + Format.fprintf ppf "(%a)" + (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr) + items + and print_item ppf loc = try + let { start = { point = s } ; stop = { point = e } }, locs = + List.assoc loc parsed.Michelson_v1_parser.expansion_table in + let locs = List.sort compare locs in + let (bef, aft) = List.assoc (List.hd locs) type_map in + Format.fprintf ppf "(@[%d %d %a %a@])@," + s e + print_stack bef + print_stack aft + with Not_found -> () in + Format.fprintf ppf "(@[%a@])" + print_expr_types (root parsed.unexpanded) + +let first_error_location errs = + let rec find = function + | [] -> 0 + | Ill_formed_type (_, _, loc) :: _ + | Invalid_arity (loc, _, _, _) :: _ + | Invalid_namespace (loc, _, _, _) :: _ + | Invalid_primitive (loc, _, _) :: _ + | Invalid_kind (loc, _, _) :: _ + | Fail_not_in_tail_position loc :: _ + | Undefined_binop (loc, _, _, _) :: _ + | Undefined_unop (loc, _, _) :: _ + | Bad_return (loc, _, _) :: _ + | Bad_stack (loc, _, _, _) :: _ + | Unmatched_branches (loc, _, _) :: _ + | Transfer_in_lambda loc :: _ + | Transfer_in_dip loc :: _ + | Invalid_constant (loc, _, _) :: _ + | Invalid_contract (loc, _) :: _ + | Comparable_type_expected (loc, _) :: _ -> loc + | _ :: rest -> find rest in + find errs + +let report_errors ppf (parsed, errs) = + Format.fprintf ppf "(@[%a@])" + (Format.pp_print_list + (fun ppf err -> + let errs, loc = + match err with + | Environment.Ecoproto_error (top :: errs) -> + [ Environment.Ecoproto_error (top :: errs) ], + begin match top with + | Ill_typed_contract (expr, _) + | Ill_typed_data (_, expr, _) -> + if expr = parsed.Michelson_v1_parser.expanded then + first_error_location (top :: errs) + else 0 + | _ -> 0 + end + | err -> [ err ], 0 in + let message = + Format.asprintf "%a" + (Michelson_v1_error_reporter.report_errors + ~details: false ~show_source: false ~parsed) + errs in + let { start = { point = s } ; stop = { point = e } } = + let oloc = List.assoc loc parsed.unexpansion_table in + fst (List.assoc oloc parsed.expansion_table) in + Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message)) + errs diff --git a/src/client/embedded/alpha/michelson_v1_emacs.mli b/src/client/embedded/alpha/michelson_v1_emacs.mli new file mode 100644 index 000000000..44d70ad2b --- /dev/null +++ b/src/client/embedded/alpha/michelson_v1_emacs.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val print_expr : + Format.formatter -> + Script.expr -> + unit +val print_type_map : + Format.formatter -> + Michelson_v1_parser.parsed * Script_ir_translator.type_map -> + unit +val report_errors : + Format.formatter -> + Michelson_v1_parser.parsed * Error_monad.error list -> + unit diff --git a/src/client/embedded/alpha/michelson_v1_error_reporter.ml b/src/client/embedded/alpha/michelson_v1_error_reporter.ml new file mode 100644 index 000000000..3f247a76f --- /dev/null +++ b/src/client/embedded/alpha/michelson_v1_error_reporter.ml @@ -0,0 +1,338 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Script_typed_ir +open Script_ir_translator +open Script_interpreter +open Michelson_v1_printer + +let print_ty (type t) ppf (ty : t ty) = + unparse_ty ty + |> Micheline.strip_locations + |> Michelson_v1_printer.print_expr ppf + +let rec print_stack_ty (type t) ?(depth = max_int) ppf (s : t stack_ty) = + let print_ty (type t) ppf (ty : t ty) = + unparse_ty ty + |> Micheline.strip_locations + |> Michelson_v1_printer.print_expr_unwrapped ppf in + let rec loop + : type t. int -> Format.formatter -> t stack_ty -> unit + = fun depth ppf -> function + | Empty_t -> () + | _ when depth <= 0 -> + Format.fprintf ppf "..." + | Item_t (last, Empty_t) -> + Format.fprintf ppf "%a" + print_ty last + | Item_t (last, rest) -> + Format.fprintf ppf "%a :@ %a" + print_ty last (loop (depth - 1)) rest in + match s with + | Empty_t -> + Format.fprintf ppf "[]" + | sty -> + Format.fprintf ppf "@[[ %a ]@]" (loop depth) sty + +let rec print_enumeration ppf = function + | [ single ] -> + Format.fprintf ppf "%a" + Format.pp_print_text single + | [ prev ; last ] -> + Format.fprintf ppf "%a@ or@ %a" + Format.pp_print_text prev Format.pp_print_text last + | first :: rest -> + Format.fprintf ppf "%a,@ %a" + Format.pp_print_text first print_enumeration rest + | [] -> assert false + +let collect_error_locations errs = + let rec collect acc = function + | Ill_formed_type (_, _, loc) :: _ -> loc :: acc + | (Ill_typed_data (_, _, _) + | Ill_typed_contract (_, _)) :: _ + | [] -> acc + | (Invalid_arity (loc, _, _, _) + | Invalid_namespace (loc, _, _, _) + | Invalid_primitive (loc, _, _) + | Invalid_kind (loc, _, _) + | Fail_not_in_tail_position loc + | Undefined_binop (loc, _, _, _) + | Undefined_unop (loc, _, _) + | Bad_return (loc, _, _) + | Bad_stack (loc, _, _, _) + | Unmatched_branches (loc, _, _) + | Transfer_in_lambda loc + | Transfer_in_dip loc + | Invalid_constant (loc, _, _) + | Invalid_contract (loc, _) + | Comparable_type_expected (loc, _) + | Overflow loc + | Reject loc) :: rest -> + collect (loc :: acc) rest + | _ :: rest -> collect acc rest in + collect [] errs + +let report_errors ~details ~show_source ?parsed ppf errs = + let rec print_trace locations errs = + let print_loc ppf loc = + match locations loc with + | None -> + Format.fprintf ppf "At (unshown) location %d, " loc + | Some loc -> + Format.fprintf ppf "%s,@ " + (String.capitalize_ascii + (Format.asprintf "%a" Micheline_parser.print_location loc)) in + let parsed_locations parsed loc = try + let oloc = List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in + let ploc, _ = List.assoc oloc parsed.expansion_table in + Some ploc + with Not_found -> None in + let print_source ppf (parsed, _hilights (* TODO *)) = + let lines = + String.split_on_char '\n' parsed.Michelson_v1_parser.source in + let cols = + String.length (string_of_int (List.length lines)) in + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list + (fun ppf (i, l) -> + Format.fprintf ppf "%0*d: %s" cols i l)) + (List.mapi (fun i l -> (i + 1, l)) lines) in + match errs with + | [] -> () + | Ill_typed_data (name, expr, ty) :: rest -> + let parsed = + match parsed with + | Some parsed when expr = parsed.Michelson_v1_parser.expanded -> parsed + | Some _ | None -> Michelson_v1_printer.unparse_expression expr in + let hilights = collect_error_locations rest in + Format.fprintf ppf + "@[@[Ill typed %adata:@ %a@]@ \ + @[is not an expression of type@ %a@]@]" + (fun ppf -> function + | None -> () + | Some s -> Format.fprintf ppf "%s " s) + name + print_source (parsed, hilights) + print_ty ty ; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace (parsed_locations parsed) rest + | Ill_formed_type (_, expr, loc) :: rest -> + let parsed = + match parsed with + | Some parsed when expr = parsed.Michelson_v1_parser.expanded -> parsed + | Some _ | None -> Michelson_v1_printer.unparse_expression expr in + let hilights = collect_error_locations errs in + if show_source then + Format.fprintf ppf + "@[%aill formed type:@ %a@]" + print_loc loc print_source (parsed, hilights) + else + Format.fprintf ppf + "Ill formed type." ; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace (parsed_locations parsed) rest + | Ill_typed_contract (expr, type_map) :: rest -> + let parsed = + match parsed with + | Some parsed when not details && expr = parsed.Michelson_v1_parser.expanded -> parsed + | Some _ | None -> Michelson_v1_printer.unparse_toplevel ~type_map expr in + let hilights = collect_error_locations rest in + if show_source then + Format.fprintf ppf + "@[Ill typed contract:@, %a@]" + print_source (parsed, hilights) + else + Format.fprintf ppf "Ill typed contract."; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace (parsed_locations parsed) rest + | Missing_field prim :: rest -> + Format.fprintf ppf "@[Missing contract field: %s@]" + (Michelson_v1_primitives.string_of_prim prim) ; + print_trace locations rest + | Runtime_contract_error (contract, expr) :: rest -> + let parsed = + match parsed with + | Some parsed when expr = parsed.Michelson_v1_parser.expanded -> parsed + | Some _ | None -> Michelson_v1_printer.unparse_toplevel expr in + let hilights = collect_error_locations rest in + Format.fprintf ppf + "@[Runtime error in contract %a:@ %a@]" + Contract.pp contract + print_source (parsed, hilights) ; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace (parsed_locations parsed) rest + | err :: rest -> + begin match err with + | Apply.Bad_contract_parameter (c, None, _) -> + Format.fprintf ppf + "@[Account %a is not a smart contract, it does not take arguments.@,\ + The `-arg' flag cannot be used when transferring to an account.@]" + Contract.pp c + | Apply.Bad_contract_parameter (c, Some expected, None) -> + Format.fprintf ppf + "@[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) -> + Format.fprintf ppf + "@[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." + print_loc loc (Michelson_v1_primitives.string_of_prim name) exp got + | Invalid_namespace (loc, name, exp, got) -> + let human_namespace = function + | Instr_namespace -> ("an", "instruction") + | Type_namespace -> ("a", "type name") + | Constant_namespace -> ("a", "constant constructor") + | Keyword_namespace -> ("a", "keyword") in + Format.fprintf ppf + "@[%aunexpected %s %s, only %s %s can be used here." + print_loc loc + (snd (human_namespace got)) + (Michelson_v1_primitives.string_of_prim name) + (fst (human_namespace exp)) (snd (human_namespace exp)) + | Invalid_primitive (loc, exp, got) -> + Format.fprintf ppf + "@[%ainvalid primitive %s, only %a can be used here." + print_loc loc + (Michelson_v1_primitives.string_of_prim got) + print_enumeration + (List.map Michelson_v1_primitives.string_of_prim exp) + | Invalid_kind (loc, exp, got) -> + let human_kind = function + | Seq_kind -> ("a", "sequence") + | Prim_kind -> ("a", "primitive") + | Int_kind -> ("an", "int") + | String_kind -> ("a", "string") in + Format.fprintf ppf + "@[%aunexpected %s, only@ %a@ can be used here." + print_loc loc + (snd (human_kind got)) + print_enumeration + (List.map (fun k -> let (a, n) = human_kind k in a ^ " " ^ n) exp) + | Duplicate_map_keys (_, expr) -> + Format.fprintf ppf + "@[Map literals cannot contain duplicate keys, \ + however a duplicate key was found:@ \ + @[%a@]" + print_expr expr + | Unordered_map_keys (_, expr) -> + Format.fprintf ppf + "@[Keys in a map literal must be in strictly ascending order, \ + but they were unordered in literal:@ \ + @[%a@]" + print_expr expr + | Duplicate_set_values (_, expr) -> + Format.fprintf ppf + "@[Set literals cannot contain duplicate values, \ + however a duplicate value was found:@ \ + @[%a@]" + print_expr expr + | Unordered_set_values (_, expr) -> + Format.fprintf ppf + "@[Values in a set literal must be in strictly ascending order, \ + but they were unordered in literal:@ \ + @[%a@]" + print_expr expr + | Fail_not_in_tail_position loc -> + Format.fprintf ppf + "%aThe FAIL instruction must appear in a tail position." + print_loc loc + | Undefined_binop (loc, name, tya, tyb) -> + Format.fprintf ppf + "@[@[%aoperator %s is undefined between@ %a@]@ \ + @[and@ %a.@]@]" + print_loc loc + (Michelson_v1_primitives.string_of_prim name) + print_ty tya + print_ty tyb + | Undefined_unop (loc, name, ty) -> + Format.fprintf ppf + "@[@[%aoperator %s is undefined on@ %a@]@]" + print_loc loc + (Michelson_v1_primitives.string_of_prim name) + print_ty ty + | Bad_return (loc, got, exp) -> + Format.fprintf ppf + "@[%awrong stack type at end of body:@,\ + - @[expected return stack type:@ %a,@]@,\ + - @[actual stack type:@ %a.@]@]" + print_loc loc + (fun ppf -> print_stack_ty ppf) (Item_t (exp, Empty_t)) + (fun ppf -> print_stack_ty ppf) got + | Bad_stack (loc, name, depth, sty) -> + Format.fprintf ppf + "@[%awrong stack type for instruction %s:@ %a.@]" + print_loc loc + (Michelson_v1_primitives.string_of_prim name) + (print_stack_ty ~depth) sty + | Unmatched_branches (loc, sta, stb) -> + Format.fprintf ppf + "@[%atwo branches don't end with the same stack type:@,\ + - @[first stack type:@ %a,@]@,\ + - @[other stack type:@ %a.@]@]" + print_loc loc + (fun ppf -> print_stack_ty ppf) sta + (fun ppf -> print_stack_ty ppf) stb + | Transfer_in_lambda loc -> + Format.fprintf ppf + "%aThe TRANSFER_TOKENS instruction cannot appear in a lambda." + print_loc loc + | Transfer_in_dip loc -> + Format.fprintf ppf + "%aThe TRANSFER_TOKENS instruction cannot appear within a DIP." + print_loc loc + | Bad_stack_length -> + Format.fprintf ppf + "Bad stack length." + | Bad_stack_item lvl -> + Format.fprintf ppf + "Bad stack item %d." + lvl + | Invalid_constant (loc, got, exp) -> + Format.fprintf ppf + "@[@[%avalue@ %a@]@ \ + @[is invalid for type@ %a.@]@]" + print_loc loc + print_expr got + print_ty exp + | Invalid_contract (loc, contract) -> + Format.fprintf ppf + "%ainvalid contract %a." + print_loc loc Contract.pp contract + | Comparable_type_expected (loc, ty) -> + Format.fprintf ppf "%acomparable type expected." + print_loc loc ; + Format.fprintf ppf "@[@[Type@ %a@]@ is not comparable.@]" + print_ty ty + | Inconsistent_types (tya, tyb) -> + Format.fprintf ppf + "@[@[Type@ %a@]@ \ + @[is not compatible with type@ %a.@]@]" + print_ty tya print_ty tyb + | Reject _ -> Format.fprintf ppf "Script reached FAIL instruction" + | Overflow _ -> Format.fprintf ppf "Unexpected arithmetic overflow" + | err -> + Format.fprintf ppf "%a" + Environment.Error_monad.pp_print_error [ err ] + end ; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace locations rest in + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list + (fun ppf -> function + | Environment.Ecoproto_error errs -> print_trace (fun _ -> None) errs + | err -> pp_print_error ppf [ err ])) + errs diff --git a/src/client/embedded/alpha/michelson_v1_error_reporter.mli b/src/client/embedded/alpha/michelson_v1_error_reporter.mli new file mode 100644 index 000000000..70d7d7b96 --- /dev/null +++ b/src/client/embedded/alpha/michelson_v1_error_reporter.mli @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val report_errors : + details: bool -> + show_source: bool -> + ?parsed: Michelson_v1_parser.parsed -> + Format.formatter -> + Error_monad.error list -> + unit diff --git a/src/client/embedded/alpha/michelson_v1_parser.ml b/src/client/embedded/alpha/michelson_v1_parser.ml new file mode 100644 index 000000000..784aa1074 --- /dev/null +++ b/src/client/embedded/alpha/michelson_v1_parser.ml @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Micheline_parser +open Micheline + +type parsed = + { source : string ; + unexpanded : string canonical ; + expanded : Michelson_v1_primitives.prim canonical ; + expansion_table : (int * (Micheline_parser.location * int list)) list ; + unexpansion_table : (int * int) list } + +let expand_all source ast = + let unexpanded, loc_table = + extract_locations ast in + let rec expand expr = + match Michelson_macros.expand expr with + | Seq (loc, items, annot) -> + Seq (loc, List.map expand items, annot) + | Prim (loc, name, args, annot) -> + Prim (loc, name, List.map expand args, annot) + | Int _ | String _ as atom -> atom in + let expanded, unexpansion_table = + extract_locations (expand (root unexpanded)) in + let expansion_table = + let sorted = + List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table in + let grouped = + let rec group = function + | acc, [] -> acc + | [], (u, e) :: r -> + group ([ (e, [ u ]) ], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> + if e = pe then + group (((e, u :: us) :: racc), r) + else + group (((e, [ u ]) :: acc), r) in + group ([], sorted) in + List.map2 + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) in + Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) >>? fun expanded -> + ok { source ; unexpanded ; expanded ; expansion_table ; unexpansion_table } + +let parse_toplevel ?check source = + Micheline_parser.tokenize source >>? fun tokens -> + Micheline_parser.parse_toplevel ?check tokens >>? fun asts -> + let ast = match asts with + | [ ast ] -> ast + | asts -> + let start = min_point asts and stop = max_point asts in + Seq (Michelson_macros.{ start ; stop }, asts, None) in + expand_all source ast + +let parse_expression ?check source = + Micheline_parser.tokenize source >>? fun tokens -> + Micheline_parser.parse_expression ?check tokens >>? fun ast -> + expand_all source ast diff --git a/src/client/embedded/alpha/michelson_v1_parser.mli b/src/client/embedded/alpha/michelson_v1_parser.mli new file mode 100644 index 000000000..fc3f69c0d --- /dev/null +++ b/src/client/embedded/alpha/michelson_v1_parser.mli @@ -0,0 +1,31 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** The result of parsing and expanding a Michelson V1 script or data. *) +type parsed = + { source : + (** The original source code. *) + string ; + unexpanded : + (** Original expression with macros. *) + string Micheline.canonical ; + expanded : + (** Expression with macros fully expanded. *) + Script.expr ; + expansion_table : + (** Associates unexpanded nodes to their parsing locations and + the nodes expanded from it in the expanded expression. *) + (int * (Micheline_parser.location * int list)) list ; + unexpansion_table : + (** Associates an expanded node to its source in the unexpanded + expression. *) + (int * int) list } + +val parse_toplevel : ?check:bool -> string -> parsed tzresult +val parse_expression : ?check:bool -> string -> parsed tzresult diff --git a/src/client/embedded/alpha/michelson_v1_printer.ml b/src/client/embedded/alpha/michelson_v1_printer.ml new file mode 100644 index 000000000..beecc5654 --- /dev/null +++ b/src/client/embedded/alpha/michelson_v1_printer.ml @@ -0,0 +1,106 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Micheline +open Micheline_printer + +let anon = { comment = None } + +let print_expr ppf expr = + expr + |> Michelson_v1_primitives.strings_of_prims + |> Micheline.inject_locations (fun _ -> anon) + |> print_expr ppf + +let print_expr_unwrapped ppf expr = + expr + |> Michelson_v1_primitives.strings_of_prims + |> Micheline.inject_locations (fun _ -> anon) + |> print_expr_unwrapped ppf + +let print_stack ppf = function + | [] -> Format.fprintf ppf "[]" + | more -> + Format.fprintf ppf "@[[ %a ]@]" + (Format.pp_print_list + ~pp_sep: (fun ppf () -> Format.fprintf ppf "@ : ") + print_expr_unwrapped) + more + +let inject_types type_map parsed = + let rec inject_expr = function + | Seq (loc, items, annot) -> + Seq (inject_loc `before loc, List.map inject_expr items, annot) + | Prim (loc, name, items, annot) -> + Prim (inject_loc `after loc, name, List.map inject_expr items, annot) + | Int (loc, value) -> + Int (inject_loc `after loc, value) + | String (loc, value) -> + String (inject_loc `after loc, value) + and inject_loc which loc = try + let stack = + let locs = + List.assoc loc parsed.Michelson_v1_parser.expansion_table + |> snd + |> List.sort compare in + let (bef, aft) = + List.assoc (List.hd locs) type_map in + match which with + | `before -> bef + | `after -> aft in + { comment = Some (Format.asprintf "%a" print_stack stack) } + with Not_found -> { comment = None } in + inject_expr (root parsed.unexpanded) + +let unparse ?type_map parse expanded = + let rec unexpand expr = + match Michelson_macros.unexpand expr with + | Seq (loc, items, annot) -> + Seq (loc, List.map unexpand items, annot) + | Prim (loc, name, args, annot) -> + Prim (loc, name, List.map unexpand args, annot) + | Int _ | String _ as atom -> atom in + let source = + match type_map with + | Some type_map -> + let unexpanded, unexpansion_table = + expanded + |> Michelson_v1_primitives.strings_of_prims + |> root |> unexpand |> Micheline.extract_locations in + let rec inject_expr = function + | Seq (loc, items, annot) -> + Seq (inject_loc `before loc, List.map inject_expr items, annot) + | Prim (loc, name, items, annot) -> + Prim (inject_loc `after loc, name, List.map inject_expr items, annot) + | Int (loc, value) -> + Int (inject_loc `after loc, value) + | String (loc, value) -> + String (inject_loc `after loc, value) + and inject_loc which loc = try + let stack = + let (bef, aft) = + List.assoc (List.assoc loc unexpansion_table) type_map in + match which with + | `before -> bef + | `after -> aft in + { comment = Some (Format.asprintf "%a" print_stack stack) } + with Not_found -> { comment = None } in + unexpanded |> root |> inject_expr + |> Format.asprintf "%a" Micheline_printer.print_expr + | None -> + expanded |> Michelson_v1_primitives.strings_of_prims + |> root |> unexpand |> Micheline.strip_locations + |> Micheline_printer.printable (fun n -> n) + |> Format.asprintf "%a" Micheline_printer.print_expr in + match parse source with + | Ok res -> res + | Error _ -> Pervasives.failwith "Michelson_v1_printer.unexpand" + +let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel +let unparse_expression = unparse Michelson_v1_parser.parse_expression diff --git a/src/client/embedded/alpha/michelson_v1_printer.mli b/src/client/embedded/alpha/michelson_v1_printer.mli new file mode 100644 index 000000000..800b9d4c1 --- /dev/null +++ b/src/client/embedded/alpha/michelson_v1_printer.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val print_expr : + Format.formatter -> Script_repr.expr -> unit + +val print_expr_unwrapped : + Format.formatter -> Script_repr.expr -> unit + +(** Insert the type map returned by the typechecker as comments in a + printable Micheline AST. *) +val inject_types : + Script_ir_translator.type_map -> + Michelson_v1_parser.parsed -> + Micheline_printer.node + +(** Unexpand the macros and produce the result of parsing an + intermediate pretty printed source. Useful when working with + contracts extracted from the blockchain and not local files. *) +val unparse_toplevel : ?type_map: Script_ir_translator.type_map -> Script.expr -> Michelson_v1_parser.parsed +val unparse_expression : Script.expr -> Michelson_v1_parser.parsed diff --git a/src/client/embedded/alpha/script_located_ir.ml b/src/client/embedded/alpha/script_located_ir.ml index f2f70710f..b679255eb 100644 --- a/src/client/embedded/alpha/script_located_ir.ml +++ b/src/client/embedded/alpha/script_located_ir.ml @@ -7,19 +7,15 @@ (* *) (**************************************************************************) -type point = +type point = Micheline_parser.point = { point : int ; byte : int ; line : int ; column : int } -let point_zero = - { point = 0 ; - byte = 0 ; - line = 0 ; - column = 0 } +let point_zero = Micheline_parser.point_zero -type location = +type location = Micheline_parser.location = { start : point ; stop : point } @@ -41,11 +37,9 @@ let location_encoding = (req "start" point_encoding) (req "stop" point_encoding)) -type node = - | Int of location * string - | String of location * string - | Prim of location * string * node list * string option - | Seq of location * node list * string option +type node = (location, string) Micheline.node + +open Micheline let node_location = function | Int (loc, _) @@ -61,16 +55,16 @@ let strip_locations root = match l with | Int (loc, v) -> loc_table := (id, loc) :: !loc_table ; - Script.Int (id, v) + Int (id, v) | String (loc, v) -> loc_table := (id, loc) :: !loc_table ; - Script.String (id, v) + String (id, v) | Seq (loc, seq, annot) -> loc_table := (id, loc) :: !loc_table ; - Script.Seq (id, List.map strip_locations seq, annot) + Seq (id, List.map strip_locations seq, annot) | Prim (loc, name, seq, annot) -> loc_table := (id, loc) :: !loc_table ; - Script.Prim (id, name, List.map strip_locations seq, annot) in + Prim (id, name, List.map strip_locations seq, annot) in let stripped = strip_locations root in stripped, List.rev !loc_table diff --git a/src/proto/alpha/TEZOS_PROTOCOL b/src/proto/alpha/TEZOS_PROTOCOL index c10d38e62..6064904f2 100644 --- a/src/proto/alpha/TEZOS_PROTOCOL +++ b/src/proto/alpha/TEZOS_PROTOCOL @@ -17,6 +17,7 @@ "Seed_repr", "Script_int_repr", "Script_timestamp_repr", + "Michelson_v1_primitives", "Script_repr", "Contract_repr", "Roll_repr", diff --git a/src/proto/alpha/apply.ml b/src/proto/alpha/apply.ml index 156f7902e..ec35ac98f 100644 --- a/src/proto/alpha/apply.ml +++ b/src/proto/alpha/apply.ml @@ -91,15 +91,19 @@ let apply_manager_operation_content Contract.get_script ctxt destination >>=? function | None -> begin match parameters with - | None | Some (Prim (_, "Unit", [], _)) -> + | None -> return (ctxt, origination_nonce, None) - | Some _ -> fail (Bad_contract_parameter (destination, None, parameters)) + | Some arg -> + match Micheline.root arg with + | Prim (_, D_Unit, [], _) -> + return (ctxt, origination_nonce, None) + | _ -> fail (Bad_contract_parameter (destination, None, parameters)) end - | Some { code ; storage } -> + | Some script -> let call_contract argument = Script_interpreter.execute origination_nonce - source destination ctxt storage code amount argument + source destination ctxt script amount argument (Constants.instructions_per_transaction ctxt) >>= function | Ok (storage_res, _res, _steps, ctxt, origination_nonce) -> @@ -111,23 +115,26 @@ let apply_manager_operation_content return (ctxt, origination_nonce, None) | Error err -> return (ctxt, origination_nonce, Some err) in - match parameters, code.arg_type with - | None, Prim (_, "unit", _, _) -> call_contract (Prim (0, "Unit", [], None)) - | Some parameters, arg_type -> begin + Lwt.return (Script_ir_translator.parse_toplevel script.code) >>=? fun (arg_type, _, _, _) -> + let arg_type = Micheline.strip_locations arg_type in + match parameters, Micheline.root arg_type with + | None, Prim (_, T_unit, _, _) -> + call_contract (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))) + | Some parameters, _ -> begin Script_ir_translator.typecheck_data ctxt (parameters, arg_type) >>= function | Ok () -> call_contract parameters | Error errs -> let err = Bad_contract_parameter (destination, Some arg_type, Some parameters) in return (ctxt, origination_nonce, Some ((err :: errs))) end - | None, arg_type -> fail (Bad_contract_parameter (destination, Some arg_type, None)) + | None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None)) end | Origination { manager ; delegate ; script ; spendable ; delegatable ; credit } -> begin match script with | None -> return None - | Some ({ Script.storage ; code } as script) -> - Script_ir_translator.parse_script ctxt storage code >>=? fun _ -> + | Some script -> + Script_ir_translator.parse_script ctxt script >>=? fun _ -> return (Some (script, (Script_interpreter.dummy_code_fee, Script_interpreter.dummy_storage_fee))) end >>=? fun script -> Contract.spend ctxt source Constants.origination_burn >>=? fun ctxt -> diff --git a/src/proto/alpha/contract_storage.ml b/src/proto/alpha/contract_storage.ml index 17744cc52..c3603b5b9 100644 --- a/src/proto/alpha/contract_storage.ml +++ b/src/proto/alpha/contract_storage.ml @@ -309,18 +309,16 @@ let contract_fee c contract = Lwt.return Tez_repr.(Constants_repr.minimal_contract_balance +? script_fees) let update_script_storage_and_fees c contract storage_fees storage = - let open Script_repr in Storage.Contract.Balance.get_option c contract >>=? function | None -> (* The contract was destroyed *) return c | Some balance -> - Storage.Contract.Storage.get c contract >>=? fun { storage_type } -> Storage.Contract.Storage_fees.set c contract storage_fees >>=? fun c -> contract_fee c contract >>=? fun fee -> fail_unless Tez_repr.(balance > fee) (Cannot_pay_storage_fee (contract, balance, fee)) >>=? fun () -> - Storage.Contract.Storage.set c contract { storage; storage_type } + Storage.Contract.Storage.set c contract storage let spend_from_script c contract amount = Storage.Contract.Balance.get c contract >>=? fun balance -> diff --git a/src/proto/alpha/contract_storage.mli b/src/proto/alpha/contract_storage.mli index 40a766fa7..15609fb1d 100644 --- a/src/proto/alpha/contract_storage.mli +++ b/src/proto/alpha/contract_storage.mli @@ -37,7 +37,7 @@ val get_balance: Storage.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t val get_counter: Storage.t -> Contract_repr.t -> int32 tzresult Lwt.t val get_script: Storage.t -> Contract_repr.t -> Script_repr.t option tzresult Lwt.t -val get_storage: Storage.t -> Contract_repr.t -> Script_repr.storage option tzresult Lwt.t +val get_storage: Storage.t -> Contract_repr.t -> Script_repr.expr option tzresult Lwt.t val update_script_storage_and_fees: Storage.t -> Contract_repr.t -> Tez_repr.t -> Script_repr.expr -> Storage.t tzresult Lwt.t diff --git a/src/proto/alpha/michelson_v1_primitives.ml b/src/proto/alpha/michelson_v1_primitives.ml new file mode 100644 index 000000000..67b999fcc --- /dev/null +++ b/src/proto/alpha/michelson_v1_primitives.ml @@ -0,0 +1,618 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Micheline + +type error += Unknown_primitive of string +type error += Invalid_case of string + +type prim = + | K_parameter + | K_return + | K_storage + | K_code + | D_False + | D_Item + | D_Left + | D_List + | D_Map + | D_None + | D_Pair + | D_Right + | D_Set + | D_Some + | D_True + | D_Unit + | I_H + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_DEFAULT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAIL + | I_GE + | I_GET + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MANAGER + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_PUSH + | I_REDUCE + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_UNIT + | I_UPDATE + | I_XOR + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_tez + | T_timestamp + | T_unit + +let valid_case name = + let is_lower = function '_' | 'a'..'z' -> true | _ -> false in + let is_upper = function '_' | 'A'..'Z' -> true | _ -> false in + let rec for_all a b f = + Compare.Int.(a > b) || f a && for_all (a + 1) b f in + let len = String.length name in + Compare.Int.(len <> 0) + && + Compare.Char.(String.get name 0 <> '_') + && + ((is_upper (String.get name 0) + && for_all 1 (len - 1) (fun i -> is_upper (String.get name i))) + || + (is_upper (String.get name 0) + && for_all 1 (len - 1) (fun i -> is_lower (String.get name i))) + || + (is_lower (String.get name 0) + && for_all 1 (len - 1) (fun i -> is_lower (String.get name i)))) + +let string_of_prim = function + | K_parameter -> "parameter" + | K_return -> "return" + | K_storage -> "storage" + | K_code -> "code" + | D_False -> "False" + | D_Item -> "Item" + | D_Left -> "Left" + | D_List -> "List" + | D_Map -> "Map" + | D_None -> "None" + | D_Pair -> "Pair" + | D_Right -> "Right" + | D_Set -> "Set" + | D_Some -> "Some" + | D_True -> "True" + | D_Unit -> "Unit" + | I_H -> "H" + | I_ABS -> "ABS" + | I_ADD -> "ADD" + | I_AMOUNT -> "AMOUNT" + | I_AND -> "AND" + | I_BALANCE -> "BALANCE" + | I_CAR -> "CAR" + | I_CDR -> "CDR" + | I_CHECK_SIGNATURE -> "CHECK_SIGNATURE" + | I_COMPARE -> "COMPARE" + | I_CONCAT -> "CONCAT" + | I_CONS -> "CONS" + | I_CREATE_ACCOUNT -> "CREATE_ACCOUNT" + | I_CREATE_CONTRACT -> "CREATE_CONTRACT" + | I_DEFAULT_ACCOUNT -> "DEFAULT_ACCOUNT" + | I_DIP -> "DIP" + | I_DROP -> "DROP" + | I_DUP -> "DUP" + | I_EDIV -> "EDIV" + | I_EMPTY_MAP -> "EMPTY_MAP" + | I_EMPTY_SET -> "EMPTY_SET" + | I_EQ -> "EQ" + | I_EXEC -> "EXEC" + | I_FAIL -> "FAIL" + | I_GE -> "GE" + | I_GET -> "GET" + | I_GT -> "GT" + | I_HASH_KEY -> "HASH_KEY" + | I_IF -> "IF" + | I_IF_CONS -> "IF_CONS" + | I_IF_LEFT -> "IF_LEFT" + | I_IF_NONE -> "IF_NONE" + | I_INT -> "INT" + | I_LAMBDA -> "LAMBDA" + | I_LE -> "LE" + | I_LEFT -> "LEFT" + | I_LOOP -> "LOOP" + | I_LSL -> "LSL" + | I_LSR -> "LSR" + | I_LT -> "LT" + | I_MANAGER -> "MANAGER" + | I_MAP -> "MAP" + | I_MEM -> "MEM" + | I_MUL -> "MUL" + | I_NEG -> "NEG" + | I_NEQ -> "NEQ" + | I_NIL -> "NIL" + | I_NONE -> "NONE" + | I_NOT -> "NOT" + | I_NOW -> "NOW" + | I_OR -> "OR" + | I_PAIR -> "PAIR" + | I_PUSH -> "PUSH" + | I_REDUCE -> "REDUCE" + | I_RIGHT -> "RIGHT" + | I_SIZE -> "SIZE" + | I_SOME -> "SOME" + | I_SOURCE -> "SOURCE" + | I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA" + | I_SUB -> "SUB" + | I_SWAP -> "SWAP" + | I_TRANSFER_TOKENS -> "TRANSFER_TOKENS" + | I_UNIT -> "UNIT" + | I_UPDATE -> "UPDATE" + | I_XOR -> "XOR" + | T_bool -> "bool" + | T_contract -> "contract" + | T_int -> "int" + | T_key -> "key" + | T_key_hash -> "key_hash" + | T_lambda -> "lambda" + | T_list -> "list" + | T_map -> "map" + | T_nat -> "nat" + | T_option -> "option" + | T_or -> "or" + | T_pair -> "pair" + | T_set -> "set" + | T_signature -> "signature" + | T_string -> "string" + | T_tez -> "tez" + | T_timestamp -> "timestamp" + | T_unit -> "unit" + +let prim_of_string = function + | "parameter" -> ok K_parameter + | "return" -> ok K_return + | "storage" -> ok K_storage + | "code" -> ok K_code + | "False" -> ok D_False + | "Item" -> ok D_Item + | "Left" -> ok D_Left + | "List" -> ok D_List + | "Map" -> ok D_Map + | "None" -> ok D_None + | "Pair" -> ok D_Pair + | "Right" -> ok D_Right + | "Set" -> ok D_Set + | "Some" -> ok D_Some + | "True" -> ok D_True + | "Unit" -> ok D_Unit + | "H" -> ok I_H + | "ABS" -> ok I_ABS + | "ADD" -> ok I_ADD + | "AMOUNT" -> ok I_AMOUNT + | "AND" -> ok I_AND + | "BALANCE" -> ok I_BALANCE + | "CAR" -> ok I_CAR + | "CDR" -> ok I_CDR + | "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE + | "COMPARE" -> ok I_COMPARE + | "CONCAT" -> ok I_CONCAT + | "CONS" -> ok I_CONS + | "CREATE_ACCOUNT" -> ok I_CREATE_ACCOUNT + | "CREATE_CONTRACT" -> ok I_CREATE_CONTRACT + | "DEFAULT_ACCOUNT" -> ok I_DEFAULT_ACCOUNT + | "DIP" -> ok I_DIP + | "DROP" -> ok I_DROP + | "DUP" -> ok I_DUP + | "EDIV" -> ok I_EDIV + | "EMPTY_MAP" -> ok I_EMPTY_MAP + | "EMPTY_SET" -> ok I_EMPTY_SET + | "EQ" -> ok I_EQ + | "EXEC" -> ok I_EXEC + | "FAIL" -> ok I_FAIL + | "GE" -> ok I_GE + | "GET" -> ok I_GET + | "GT" -> ok I_GT + | "HASH_KEY" -> ok I_HASH_KEY + | "IF" -> ok I_IF + | "IF_CONS" -> ok I_IF_CONS + | "IF_LEFT" -> ok I_IF_LEFT + | "IF_NONE" -> ok I_IF_NONE + | "INT" -> ok I_INT + | "LAMBDA" -> ok I_LAMBDA + | "LE" -> ok I_LE + | "LEFT" -> ok I_LEFT + | "LOOP" -> ok I_LOOP + | "LSL" -> ok I_LSL + | "LSR" -> ok I_LSR + | "LT" -> ok I_LT + | "MANAGER" -> ok I_MANAGER + | "MAP" -> ok I_MAP + | "MEM" -> ok I_MEM + | "MUL" -> ok I_MUL + | "NEG" -> ok I_NEG + | "NEQ" -> ok I_NEQ + | "NIL" -> ok I_NIL + | "NONE" -> ok I_NONE + | "NOT" -> ok I_NOT + | "NOW" -> ok I_NOW + | "OR" -> ok I_OR + | "PAIR" -> ok I_PAIR + | "PUSH" -> ok I_PUSH + | "REDUCE" -> ok I_REDUCE + | "RIGHT" -> ok I_RIGHT + | "SIZE" -> ok I_SIZE + | "SOME" -> ok I_SOME + | "SOURCE" -> ok I_SOURCE + | "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA + | "SUB" -> ok I_SUB + | "SWAP" -> ok I_SWAP + | "TRANSFER_TOKENS" -> ok I_TRANSFER_TOKENS + | "UNIT" -> ok I_UNIT + | "UPDATE" -> ok I_UPDATE + | "XOR" -> ok I_XOR + | "bool" -> ok T_bool + | "contract" -> ok T_contract + | "int" -> ok T_int + | "key" -> ok T_key + | "key_hash" -> ok T_key_hash + | "lambda" -> ok T_lambda + | "list" -> ok T_list + | "map" -> ok T_map + | "nat" -> ok T_nat + | "option" -> ok T_option + | "or" -> ok T_or + | "pair" -> ok T_pair + | "set" -> ok T_set + | "signature" -> ok T_signature + | "string" -> ok T_string + | "tez" -> ok T_tez + | "timestamp" -> ok T_timestamp + | "unit" -> ok T_unit + | n -> + if valid_case n then + error (Unknown_primitive n) + else + error (Invalid_case n) + +let prims_of_strings expr = + let rec convert = function + | Int _ | String _ as expr -> ok expr + | Prim (_, prim, args, annot) -> + prim_of_string prim >>? fun prim -> + List.fold_left + (fun acc arg -> + acc >>? fun args -> + convert arg >>? fun arg -> + ok (arg :: args)) + (ok []) args >>? fun args -> + ok (Prim (0, prim, List.rev args, annot)) + | Seq (_, args, annot) -> + List.fold_left + (fun acc arg -> + acc >>? fun args -> + convert arg >>? fun arg -> + ok (arg :: args)) + (ok []) args >>? fun args -> + ok (Seq (0, List.rev args, annot)) in + convert (root expr) >>? fun expr -> + ok (strip_locations expr) + +let strings_of_prims expr = + let rec convert = function + | Int _ | String _ as expr -> expr + | Prim (_, prim, args, annot) -> + let prim = string_of_prim prim in + let args = List.map convert args in + Prim (0, prim, args, annot) + | Seq (_, args, annot) -> + let args = List.map convert args in + Seq (0, args, annot) in + strip_locations (convert (root expr)) + +let prim_encoding = + let to_int = function + | K_parameter -> 0 + | K_return -> 1 + | K_storage -> 2 + | K_code -> 3 + | D_False -> 4 + | D_Item -> 5 + | D_Left -> 6 + | D_List -> 7 + | D_Map -> 8 + | D_None -> 9 + | D_Pair -> 10 + | D_Right -> 11 + | D_Set -> 12 + | D_Some -> 13 + | D_True -> 14 + | D_Unit -> 15 + | I_H -> 16 + | I_ABS -> 17 + | I_ADD -> 18 + | I_AMOUNT -> 19 + | I_AND -> 20 + | I_BALANCE -> 21 + | I_CAR -> 22 + | I_CDR -> 23 + | I_CHECK_SIGNATURE -> 24 + | I_COMPARE -> 25 + | I_CONCAT -> 26 + | I_CONS -> 27 + | I_CREATE_ACCOUNT -> 28 + | I_CREATE_CONTRACT -> 29 + | I_DEFAULT_ACCOUNT -> 30 + | I_DIP -> 31 + | I_DROP -> 32 + | I_DUP -> 33 + | I_EDIV -> 34 + | I_EMPTY_MAP -> 35 + | I_EMPTY_SET -> 36 + | I_EQ -> 37 + | I_EXEC -> 38 + | I_FAIL -> 39 + | I_GE -> 40 + | I_GET -> 41 + | I_GT -> 42 + | I_HASH_KEY -> 43 + | I_IF -> 44 + | I_IF_CONS -> 45 + | I_IF_LEFT -> 46 + | I_IF_NONE -> 47 + | I_INT -> 48 + | I_LAMBDA -> 49 + | I_LE -> 50 + | I_LEFT -> 51 + | I_LOOP -> 52 + | I_LSL -> 53 + | I_LSR -> 54 + | I_LT -> 55 + | I_MANAGER -> 56 + | I_MAP -> 57 + | I_MEM -> 58 + | I_MUL -> 59 + | I_NEG -> 60 + | I_NEQ -> 61 + | I_NIL -> 62 + | I_NONE -> 63 + | I_NOT -> 64 + | I_NOW -> 65 + | I_OR -> 66 + | I_PAIR -> 67 + | I_PUSH -> 68 + | I_REDUCE -> 69 + | I_RIGHT -> 70 + | I_SIZE -> 71 + | I_SOME -> 72 + | I_SOURCE -> 73 + | I_STEPS_TO_QUOTA -> 74 + | I_SUB -> 75 + | I_SWAP -> 76 + | I_TRANSFER_TOKENS -> 77 + | I_UNIT -> 78 + | I_UPDATE -> 79 + | I_XOR -> 80 + | T_bool -> 81 + | T_contract -> 82 + | T_int -> 83 + | T_key -> 84 + | T_key_hash -> 85 + | T_lambda -> 86 + | T_list -> 87 + | T_map -> 88 + | T_nat -> 89 + | T_option -> 90 + | T_or -> 91 + | T_pair -> 92 + | T_set -> 93 + | T_signature -> 94 + | T_string -> 95 + | T_tez -> 96 + | T_timestamp -> 97 + | T_unit -> 99 in + let of_int_map = [| + K_parameter ; + K_return ; + K_storage ; + K_code ; + D_False ; + D_Item ; + D_Left ; + D_List ; + D_Map ; + D_None ; + D_Pair ; + D_Right ; + D_Set ; + D_Some ; + D_True ; + D_Unit ; + I_H ; + I_ABS ; + I_ADD ; + I_AMOUNT ; + I_AND ; + I_BALANCE ; + I_CAR ; + I_CDR ; + I_CHECK_SIGNATURE ; + I_COMPARE ; + I_CONCAT ; + I_CONS ; + I_CREATE_ACCOUNT ; + I_CREATE_CONTRACT ; + I_DEFAULT_ACCOUNT ; + I_DIP ; + I_DROP ; + I_DUP ; + I_EDIV ; + I_EMPTY_MAP ; + I_EMPTY_SET ; + I_EQ ; + I_EXEC ; + I_FAIL ; + I_GE ; + I_GET ; + I_GT ; + I_HASH_KEY ; + I_IF ; + I_IF_CONS ; + I_IF_LEFT ; + I_IF_NONE ; + I_INT ; + I_LAMBDA ; + I_LE ; + I_LEFT ; + I_LOOP ; + I_LSL ; + I_LSR ; + I_LT ; + I_MANAGER ; + I_MAP ; + I_MEM ; + I_MUL ; + I_NEG ; + I_NEQ ; + I_NIL ; + I_NONE ; + I_NOT ; + I_NOW ; + I_OR ; + I_PAIR ; + I_PUSH ; + I_REDUCE ; + I_RIGHT ; + I_SIZE ; + I_SOME ; + I_SOURCE ; + I_STEPS_TO_QUOTA ; + I_SUB ; + I_SWAP ; + I_TRANSFER_TOKENS ; + I_UNIT ; + I_UPDATE ; + I_XOR ; + T_bool ; + T_contract ; + T_int ; + T_key ; + T_key_hash ; + T_lambda ; + T_list ; + T_map ; + T_nat ; + T_option ; + T_or ; + T_pair ; + T_set ; + T_signature ; + T_string ; + T_tez ; + T_timestamp ; + T_unit |] in + let of_int i = + if Compare.Int.(i >= 0 || i <= 99) then + of_int_map.(i) + else + raise Data_encoding.No_case_matched in + let open Data_encoding in + let binary = + conv to_int of_int uint8 in + let json = + string_enum + (List.map (fun op -> string_of_prim op, op) + (Array.to_list of_int_map)) in + splitted ~json ~binary + +let () = + register_error_kind + `Permanent + ~id:"unknownPrimitiveNameTypeError" + ~title: "Unknown primitive name (typechecking error)" + ~description: + "In a script or data expression, a primitive was unknown." + ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n) + Data_encoding.(obj1 (req "wrongPrimitiveName" string)) + (function + | Unknown_primitive got -> Some got + | _ -> None) + (fun got -> + Unknown_primitive got) ; + register_error_kind + `Permanent + ~id:"invalidPrimitiveNameCaseTypeError" + ~title: "Invalid primitive name case (typechecking error)" + ~description: + "In a script or data expression, a primitive name is \ + neither uppercase, lowercase or capitalized." + Data_encoding.(obj1 (req "wrongPrimitiveName" string)) + (function + | Invalid_case name -> Some name + | _ -> None) + (fun name -> + Invalid_case name) diff --git a/src/proto/alpha/michelson_v1_primitives.mli b/src/proto/alpha/michelson_v1_primitives.mli new file mode 100644 index 000000000..dbdd50a59 --- /dev/null +++ b/src/proto/alpha/michelson_v1_primitives.mli @@ -0,0 +1,122 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type error += Unknown_primitive of string (* `Permanent *) +type error += Invalid_case of string (* `Permanent *) + +type prim = + | K_parameter + | K_return + | K_storage + | K_code + | D_False + | D_Item + | D_Left + | D_List + | D_Map + | D_None + | D_Pair + | D_Right + | D_Set + | D_Some + | D_True + | D_Unit + | I_H + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_DEFAULT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAIL + | I_GE + | I_GET + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MANAGER + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_PUSH + | I_REDUCE + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_UNIT + | I_UPDATE + | I_XOR + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_tez + | T_timestamp + | T_unit + +val prim_encoding : prim Data_encoding.encoding + +val string_of_prim : prim -> string + +val prim_of_string : string -> prim tzresult + +val prims_of_strings : string Micheline.canonical -> prim Micheline.canonical tzresult + +val strings_of_prims : prim Micheline.canonical -> string Micheline.canonical diff --git a/src/proto/alpha/script_interpreter.ml b/src/proto/alpha/script_interpreter.ml index 45c138eee..93ec26cfc 100644 --- a/src/proto/alpha/script_interpreter.ml +++ b/src/proto/alpha/script_interpreter.ml @@ -20,7 +20,7 @@ let dummy_storage_fee = Tez.fifty_cents type error += Quota_exceeded type error += Reject of Script.location type error += Overflow of Script.location -type error += Runtime_contract_error : Contract.t * Script.expr * _ ty * _ ty * _ ty -> error +type error += Runtime_contract_error : Contract.t * Script.expr -> error let () = let open Data_encoding in @@ -47,18 +47,15 @@ let () = ~id:"scriptRuntimeError" ~title: "Script runtime error" ~description: "Toplevel error for all runtime script errors" - (obj5 + (obj2 (req "contractHandle" Contract.encoding) - (req "contractCode" Script.expr_encoding) - (req "contractParameterType" ex_ty_enc) - (req "contractReturnType" ex_ty_enc) - (req "contractStorageType" ex_ty_enc)) + (req "contractCode" Script.expr_encoding)) (function - | Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty) -> - Some (contract, expr, Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty) + | Runtime_contract_error (contract, expr) -> + Some (contract, expr) | _ -> None) - (fun (contract, expr, Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty) -> - Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty)); + (fun (contract, expr) -> + Runtime_contract_error (contract, expr)); (* ---- interpreter ---------------------------------------------------------*) @@ -71,7 +68,7 @@ let rec unparse_stack = function | Empty, Empty_t -> [] | Item (v, rest), Item_t (ty, rest_ty) -> - unparse_data ty v :: unparse_stack (rest, rest_ty) + Micheline.strip_locations (unparse_data ty v) :: unparse_stack (rest, rest_ty) let rec interp : type p r. @@ -237,21 +234,21 @@ let rec interp Lwt.return Tez.(x -? y) >>=? fun res -> logged_return (Item (res, rest), qta - 1, ctxt) | Mul_teznat, Item (x, Item (y, rest)) -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow loc) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), qta - 1, ctxt) - end + begin + match Script_int.to_int64 y with + | None -> fail (Overflow loc) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), qta - 1, ctxt) + end | Mul_nattez, Item (y, Item (x, rest)) -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow loc) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), qta - 1, ctxt) - end + begin + match Script_int.to_int64 y with + | None -> fail (Overflow loc) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), qta - 1, ctxt) + end (* boolean operations *) | Or, Item (x, Item (y, rest)) -> logged_return (Item (x || y, rest), qta - 1, ctxt) @@ -287,53 +284,53 @@ let rec interp | Mul_natint, Item (x, Item (y, rest)) -> logged_return (Item (Script_int.mul x y, rest), qta - 1, ctxt) | Mul_natnat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.mul_n x y, rest), qta - 1, ctxt) + logged_return (Item (Script_int.mul_n x y, rest), qta - 1, ctxt) | Ediv_teznat, Item (x, Item (y, rest)) -> - let x = Script_int.of_int64 (Tez.to_cents x) in - let result = - match Script_int.ediv x y with - | None -> None - | Some (q, r) -> - match Script_int.to_int64 q, - Script_int.to_int64 r with - | Some q, Some r -> - begin - match Tez.of_cents q, Tez.of_cents r with - | Some q, Some r -> Some (q,r) - (* Cannot overflow *) - | _ -> assert false - end - (* Cannot overflow *) - | _ -> assert false + let x = Script_int.of_int64 (Tez.to_cents x) in + let result = + match Script_int.ediv x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 q, + Script_int.to_int64 r with + | Some q, Some r -> + begin + match Tez.of_cents q, Tez.of_cents r with + | Some q, Some r -> Some (q,r) + (* Cannot overflow *) + | _ -> assert false + end + (* Cannot overflow *) + | _ -> assert false in logged_return (Item (result, rest), qta -1, ctxt) | Ediv_tez, Item (x, Item (y, rest)) -> - let x = Script_int.abs (Script_int.of_int64 (Tez.to_cents x)) in - let y = Script_int.abs (Script_int.of_int64 (Tez.to_cents y)) in - begin match Script_int.ediv_n x y with - | None -> - logged_return (Item (None, rest), qta -1, ctxt) - | Some (q, r) -> - let r = - match Script_int.to_int64 r with - | None -> assert false (* Cannot overflow *) - | Some r -> - match Tez.of_cents r with - | None -> assert false (* Cannot overflow *) - | Some r -> r in - logged_return (Item (Some (q, r), rest), qta -1, ctxt) - end + let x = Script_int.abs (Script_int.of_int64 (Tez.to_cents x)) in + let y = Script_int.abs (Script_int.of_int64 (Tez.to_cents y)) in + begin match Script_int.ediv_n x y with + | None -> + logged_return (Item (None, rest), qta -1, ctxt) + | Some (q, r) -> + let r = + match Script_int.to_int64 r with + | None -> assert false (* Cannot overflow *) + | Some r -> + match Tez.of_cents r with + | None -> assert false (* Cannot overflow *) + | Some r -> r in + logged_return (Item (Some (q, r), rest), qta -1, ctxt) + end | Ediv_intint, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) + logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) | Ediv_intnat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) + logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) | Ediv_natint, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) + logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) | Ediv_natnat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.ediv_n x y, rest), qta -1, ctxt) + logged_return (Item (Script_int.ediv_n x y, rest), qta -1, ctxt) | Lsl_nat, Item (x, Item (y, rest)) -> begin match Script_int.shift_left_n x y with | None -> fail (Overflow loc) @@ -442,7 +439,7 @@ let rec interp Contract.spend_from_script ctxt source amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.get_script ctxt destination >>=? fun destination_script -> - let sto = unparse_data storage_type sto in + let sto = Micheline.strip_locations (unparse_data storage_type sto) in Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt -> begin match destination_script with | None -> @@ -450,9 +447,9 @@ let rec interp Lwt.return (ty_eq tp Unit_t |> record_trace (Invalid_contract (loc, destination))) >>=? fun (Eq _) -> return (ctxt, qta, origination) - | Some { code ; storage } -> + | Some script -> let p = unparse_data tp p in - execute origination source destination ctxt storage code amount p qta + execute origination source destination ctxt script amount p qta >>=? fun (csto, ret, qta, ctxt, origination) -> Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee csto >>=? fun ctxt -> trace @@ -462,8 +459,8 @@ let rec interp end >>=? fun (ctxt, qta, origination) -> Contract.get_script ctxt source >>=? (function | None -> assert false - | Some { storage = { storage } } -> - parse_data ctxt storage_type storage >>=? fun sto -> + | Some { storage } -> + parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto -> logged_return ~origination (Item ((), Item (sto, Empty)), qta - 1, ctxt)) end | Transfer_tokens storage_type, @@ -472,11 +469,11 @@ let rec interp Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.get_script ctxt destination >>=? function | None -> fail (Invalid_contract (loc, destination)) - | Some { code ; storage } -> - let sto = unparse_data storage_type sto in + | Some script -> + let sto = Micheline.strip_locations (unparse_data storage_type sto) in Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt -> let p = unparse_data tp p in - execute origination source destination ctxt storage code amount p qta + execute origination source destination ctxt script amount p qta >>=? fun (sto, ret, qta, ctxt, origination) -> Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee sto >>=? fun ctxt -> trace @@ -484,8 +481,8 @@ let rec interp (parse_data ctxt tr ret) >>=? fun v -> Contract.get_script ctxt source >>=? (function | None -> assert false - | Some { storage = { storage } } -> - parse_data ctxt storage_type storage >>=? fun sto -> + | Some { storage } -> + parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto -> logged_return ~origination (Item (v, Item (sto, Empty)), qta - 1, ctxt)) end | Create_account, @@ -501,11 +498,20 @@ let rec interp let contract = Contract.default_contract key in logged_return (Item ((Unit_t, Unit_t, contract), rest), qta - 1, ctxt) | Create_contract (g, p, r), - Item (manager, Item (delegate, Item (spendable, Item (delegatable, Item (credit, - Item (Lam (_, code), Item (init, rest))))))) -> - let code, storage = - { code; arg_type = unparse_ty p; ret_type = unparse_ty r; storage_type = unparse_ty g }, - { storage = unparse_data g init; storage_type = unparse_ty g } in + Item (manager, Item + (delegate, Item + (spendable, Item + (delegatable, Item + (credit, Item + (Lam (_, code), Item + (init, rest))))))) -> + let code = + Micheline.strip_locations + (Seq (0, [ Prim (0, K_parameter, [ unparse_ty p ], None) ; + Prim (0, K_return, [ unparse_ty r ], None) ; + Prim (0, K_storage, [ unparse_ty g ], None) ; + Prim (0, K_code, [ Micheline.root code ], None) ], None)) in + let storage = Micheline.strip_locations (unparse_data g init) in Contract.spend_from_script ctxt source credit >>=? fun ctxt -> Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> Contract.originate ctxt @@ -528,7 +534,7 @@ let rec interp | Hash_key, Item (key, rest) -> logged_return (Item (Ed25519.Public_key.hash key, rest), qta -1, ctxt) | H ty, Item (v, rest) -> - let hash = Script.hash_expr (unparse_data ty v) in + let hash = Script.hash_expr (Micheline.strip_locations (unparse_data ty v)) in logged_return (Item (hash, rest), qta - 1, ctxt) | Steps_to_quota, rest -> let steps = Script_int.abs (Script_int.of_int qta) in @@ -549,23 +555,25 @@ let rec interp (* ---- contract handling ---------------------------------------------------*) -and execute ?log origination orig source ctxt storage script amount arg qta = - parse_script ctxt storage script +and execute ?log origination orig source ctxt script amount arg qta = + parse_script ctxt script >>=? fun (Ex_script { code; arg_type; ret_type; storage; storage_type }) -> parse_data ctxt arg_type arg >>=? fun arg -> trace - (Runtime_contract_error (source, script.code, arg_type, ret_type, storage_type)) + (Runtime_contract_error (source, script.code)) (interp ?log origination qta orig source amount ctxt code (arg, storage)) - >>=? fun (ret, qta, ctxt, origination) -> - let ret, storage = ret in - return (unparse_data storage_type storage, + >>=? fun ((ret, storage), qta, ctxt, origination) -> + return (Micheline.strip_locations (unparse_data storage_type storage), unparse_data ret_type ret, qta, ctxt, origination) -let trace origination orig source ctxt storage script amount arg qta = +let trace origination orig source ctxt script amount arg qta = let log = ref [] in - execute ~log origination orig source ctxt storage script amount arg qta >>=? fun res -> - return (res, List.rev !log) + execute ~log origination orig source ctxt script amount (Micheline.root arg) qta + >>=? fun (sto, res, qta, ctxt, origination) -> + return ((sto, Micheline.strip_locations res, qta, ctxt, origination), List.rev !log) -let execute orig source ctxt storage script amount arg qta = - execute orig source ctxt storage script amount arg qta +let execute origination orig source ctxt script amount arg qta = + execute origination orig source ctxt script amount (Micheline.root arg) qta + >>=? fun (sto, res, qta, ctxt, origination) -> + return (sto, Micheline.strip_locations res, qta, ctxt, origination) diff --git a/src/proto/alpha/script_interpreter.mli b/src/proto/alpha/script_interpreter.mli index 96f53370c..274cbde10 100644 --- a/src/proto/alpha/script_interpreter.mli +++ b/src/proto/alpha/script_interpreter.mli @@ -8,12 +8,11 @@ (**************************************************************************) open Tezos_context -open Script_typed_ir type error += Quota_exceeded type error += Overflow of Script.location type error += Reject of Script.location -type error += Runtime_contract_error : Contract.t * Script.expr * _ ty * _ ty * _ ty -> error +type error += Runtime_contract_error : Contract.t * Script.expr -> error val dummy_code_fee : Tez.t val dummy_storage_fee : Tez.t @@ -21,14 +20,14 @@ val dummy_storage_fee : Tez.t val execute: Contract.origination_nonce -> Contract.t -> Contract.t -> Tezos_context.t -> - Script.storage -> Script.code -> Tez.t -> + Script.t -> Tez.t -> Script.expr -> int -> (Script.expr * Script.expr * int * context * Contract.origination_nonce) tzresult Lwt.t val trace: Contract.origination_nonce -> Contract.t -> Contract.t -> Tezos_context.t -> - Script.storage -> Script.code -> Tez.t -> + Script.t -> Tez.t -> Script.expr -> int -> ((Script.expr * Script.expr * int * context * Contract.origination_nonce) * (Script.location * int * Script.expr list) list) tzresult Lwt.t diff --git a/src/proto/alpha/script_ir_translator.ml b/src/proto/alpha/script_ir_translator.ml index fd5f0f812..75205f729 100644 --- a/src/proto/alpha/script_ir_translator.ml +++ b/src/proto/alpha/script_ir_translator.ml @@ -8,29 +8,31 @@ (**************************************************************************) open Tezos_context +open Micheline open Script open Script_typed_ir (* ---- Error definitions ---------------------------------------------------*) (* Auxiliary types for error documentation *) -type namespace = Type_namespace | Constant_namespace | Instr_namespace +type namespace = Type_namespace | Constant_namespace | Instr_namespace | Keyword_namespace type kind = Int_kind | String_kind | Prim_kind | Seq_kind type type_map = (int * (Script.expr list * Script.expr list)) list (* Structure errors *) -type error += Invalid_arity of Script.location * string * int * int -type error += Invalid_namespace of Script.location * string * namespace * namespace -type error += Invalid_primitive of Script.location * string list * string -type error += Invalid_case of Script.location * string +type error += Invalid_arity of Script.location * prim * int * int +type error += Invalid_namespace of Script.location * prim * namespace * namespace +type error += Invalid_primitive of Script.location * prim list * prim type error += Invalid_kind of Script.location * kind list * kind +type error += Missing_field of prim +type error += Duplicate_field of Script.location * prim (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location -type error += Undefined_binop : Script.location * string * _ ty * _ ty -> error -type error += Undefined_unop : Script.location * string * _ ty -> error +type error += Undefined_binop : Script.location * prim * _ ty * _ ty -> error +type error += Undefined_unop : Script.location * prim * _ ty -> error type error += Bad_return : Script.location * _ stack_ty * _ ty -> error -type error += Bad_stack : Script.location * string * int * _ stack_ty -> error +type error += Bad_stack : Script.location * prim * int * _ stack_ty -> error type error += Unmatched_branches : Script.location * _ stack_ty * _ stack_ty -> error type error += Transfer_in_lambda of Script.location type error += Transfer_in_dip of Script.location @@ -42,16 +44,16 @@ type error += Invalid_constant : Script.location * Script.expr * _ ty -> error type error += Invalid_contract of Script.location * Contract.t type error += Comparable_type_expected : Script.location * _ ty -> error type error += Inconsistent_types : _ ty * _ ty -> error - -(* Toplevel errors *) -type error += Ill_typed_data : string option * Script.expr * _ ty -> error -type error += Ill_formed_type of string option * Script.expr -type error += Ill_typed_contract : Script.expr * _ ty * _ ty * _ ty * type_map -> error type error += Unordered_map_keys of Script.location * Script.expr type error += Unordered_set_values of Script.location * Script.expr type error += Duplicate_map_keys of Script.location * Script.expr type error += Duplicate_set_values of Script.location * Script.expr +(* Toplevel errors *) +type error += Ill_typed_data : string option * Script.expr * _ ty -> error +type error += Ill_formed_type of string option * Script.expr * Script.location +type error += Ill_typed_contract : Script.expr * type_map -> error + type ex_comparable_ty = Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty type ex_ty = Ex_ty : 'a ty -> ex_ty type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty @@ -79,26 +81,107 @@ let kind = function | Prim _ -> Prim_kind | Seq _ -> Seq_kind -let namespace name = - let is_lower = function '_' | 'a'..'z' -> true | _ -> false in - let is_upper = function '_' | 'A'..'Z' -> true | _ -> false in - let rec for_all a b f = - Compare.Int.(a > b) || f a && for_all (a + 1) b f in - let len = String.length name in - if Compare.Int.(len = 0) - || Compare.Char.(String.get name 0 = '_') then - None - else if is_upper (String.get name 0) - && for_all 1 (len - 1) (fun i -> is_upper (String.get name i)) then - Some Instr_namespace - else if is_upper (String.get name 0) - && for_all 1 (len - 1) (fun i -> is_lower (String.get name i)) then - Some Constant_namespace - else if is_lower (String.get name 0) - && for_all 1 (len - 1) (fun i -> is_lower (String.get name i)) then - Some Type_namespace - else - None +let namespace = function + | K_parameter + | K_return + | K_storage + | K_code -> Keyword_namespace + | D_False + | D_Item + | D_Left + | D_List + | D_Map + | D_None + | D_Pair + | D_Right + | D_Set + | D_Some + | D_True + | D_Unit -> Constant_namespace + | I_H + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_DEFAULT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAIL + | I_GE + | I_GET + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MANAGER + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_PUSH + | I_REDUCE + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_UNIT + | I_UPDATE + | I_XOR -> Instr_namespace + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_tez + | T_timestamp + | T_unit -> Type_namespace + let unexpected expr exp_kinds exp_ns exp_prims = match expr with @@ -107,13 +190,11 @@ let unexpected expr exp_kinds exp_ns exp_prims = | Seq (loc, _, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind) | Prim (loc, name, _, _) -> match namespace name, exp_ns with - | None, _ -> - Invalid_case (loc, name) - | Some Type_namespace, Type_namespace - | Some Instr_namespace, Instr_namespace - | Some Constant_namespace, Constant_namespace -> + | Type_namespace, Type_namespace + | Instr_namespace, Instr_namespace + | Constant_namespace, Constant_namespace -> Invalid_primitive (loc, exp_prims, name) - | Some ns, _ -> + | ns, _ -> Invalid_namespace (loc, name, exp_ns, ns) let check_kind kinds expr = @@ -253,62 +334,62 @@ let ty_of_comparable_ty | Timestamp_key -> Timestamp_t let unparse_comparable_ty - : type a. a comparable_ty -> Script.expr = function - | Int_key -> Prim (-1, "int", [], None) - | Nat_key -> Prim (-1, "nat", [], None) - | String_key -> Prim (-1, "string", [], None) - | Tez_key -> Prim (-1, "tez", [], None) - | Bool_key -> Prim (-1, "bool", [], None) - | Key_hash_key -> Prim (-1, "key_hash", [], None) - | Timestamp_key -> Prim (-1, "timestamp", [], None) + : type a. a comparable_ty -> Script.node = function + | Int_key -> Prim (-1, T_int, [], None) + | Nat_key -> Prim (-1, T_nat, [], None) + | String_key -> Prim (-1, T_string, [], None) + | Tez_key -> Prim (-1, T_tez, [], None) + | Bool_key -> Prim (-1, T_bool, [], None) + | Key_hash_key -> Prim (-1, T_key_hash, [], None) + | Timestamp_key -> Prim (-1, T_timestamp, [], None) let rec unparse_ty - : type a. a ty -> Script.expr = function - | Unit_t -> Prim (-1, "unit", [], None) - | Int_t -> Prim (-1, "int", [], None) - | Nat_t -> Prim (-1, "nat", [], None) - | String_t -> Prim (-1, "string", [], None) - | Tez_t -> Prim (-1, "tez", [], None) - | Bool_t -> Prim (-1, "bool", [], None) - | Key_hash_t -> Prim (-1, "key_hash", [], None) - | Key_t -> Prim (-1, "key", [], None) - | Timestamp_t -> Prim (-1, "timestamp", [], None) - | Signature_t -> Prim (-1, "signature", [], None) + : type a. a ty -> Script.node = function + | Unit_t -> Prim (-1, T_unit, [], None) + | Int_t -> Prim (-1, T_int, [], None) + | Nat_t -> Prim (-1, T_nat, [], None) + | String_t -> Prim (-1, T_string, [], None) + | Tez_t -> Prim (-1, T_tez, [], None) + | Bool_t -> Prim (-1, T_bool, [], None) + | Key_hash_t -> Prim (-1, T_key_hash, [], None) + | Key_t -> Prim (-1, T_key, [], None) + | Timestamp_t -> Prim (-1, T_timestamp, [], None) + | Signature_t -> Prim (-1, T_signature, [], None) | Contract_t (utl, utr) -> let tl = unparse_ty utl in let tr = unparse_ty utr in - Prim (-1, "contract", [ tl; tr ], None) + Prim (-1, T_contract, [ tl; tr ], None) | Pair_t (utl, utr) -> let tl = unparse_ty utl in let tr = unparse_ty utr in - Prim (-1, "pair", [ tl; tr ], None) + Prim (-1, T_pair, [ tl; tr ], None) | Union_t (utl, utr) -> let tl = unparse_ty utl in let tr = unparse_ty utr in - Prim (-1, "or", [ tl; tr ], None) + Prim (-1, T_or, [ tl; tr ], None) | Lambda_t (uta, utr) -> let ta = unparse_ty uta in let tr = unparse_ty utr in - Prim (-1, "lambda", [ ta; tr ], None) + Prim (-1, T_lambda, [ ta; tr ], None) | Option_t ut -> let t = unparse_ty ut in - Prim (-1, "option", [ t ], None) + Prim (-1, T_option, [ t ], None) | List_t ut -> let t = unparse_ty ut in - Prim (-1, "list", [ t ], None) + Prim (-1, T_list, [ t ], None) | Set_t ut -> let t = unparse_comparable_ty ut in - Prim (-1, "set", [ t ], None) + Prim (-1, T_set, [ t ], None) | Map_t (uta, utr) -> let ta = unparse_comparable_ty uta in let tr = unparse_ty utr in - Prim (-1, "map", [ ta; tr ], None) + Prim (-1, T_map, [ ta; tr ], None) let rec unparse_data - : type a. a ty -> a -> Script.expr + : type a. a ty -> a -> Script.node = fun ty a -> match ty, a with | Unit_t, () -> - Prim (-1, "Unit", [], None) + Prim (-1, D_Unit, [], None) | Int_t, v -> Int (-1, Script_int.to_string v) | Nat_t, v -> @@ -316,9 +397,9 @@ let rec unparse_data | String_t, s -> String (-1, s) | Bool_t, true -> - Prim (-1, "True", [], None) + Prim (-1, D_True, [], None) | Bool_t, false -> - Prim (-1, "False", [], None) + Prim (-1, D_False, [], None) | Timestamp_t, t -> begin match Script_timestamp.to_notation t with @@ -341,21 +422,21 @@ let rec unparse_data | Pair_t (tl, tr), (l, r) -> let l = unparse_data tl l in let r = unparse_data tr r in - Prim (-1, "Pair", [ l; r ], None) + Prim (-1, D_Pair, [ l; r ], None) | Union_t (tl, _), L l -> let l = unparse_data tl l in - Prim (-1, "Left", [ l ], None) + Prim (-1, D_Left, [ l ], None) | Union_t (_, tr), R r -> let r = unparse_data tr r in - Prim (-1, "Right", [ r ], None) + Prim (-1, D_Right, [ r ], None) | Option_t t, Some v -> let v = unparse_data t v in - Prim (-1, "Some", [ v ], None) + Prim (-1, D_Some, [ v ], None) | Option_t _, None -> - Prim (-1, "None", [], None) + Prim (-1, D_None, [], None) | List_t t, items -> let items = List.map (unparse_data t) items in - Prim (-1, "List", items, None) + Prim (-1, D_List, items, None) | Set_t t, set -> let t = ty_of_comparable_ty t in let items = @@ -363,20 +444,20 @@ let rec unparse_data (fun item acc -> unparse_data t item :: acc ) set [] in - Prim (-1, "Set", List.rev items, None) + Prim (-1, D_Set, List.rev items, None) | Map_t (kt, vt), map -> let kt = ty_of_comparable_ty kt in let items = map_fold (fun k v acc -> - Prim (-1, "Item", + Prim (-1, D_Item, [ unparse_data kt k; unparse_data vt v ], None) :: acc) map [] in - Prim (-1, "Map", List.rev items, None) + Prim (-1, D_Map, List.rev items, None) | Lambda_t _, Lam (_, original_code) -> - original_code + root original_code (* ---- Equality witnesses --------------------------------------------------*) @@ -496,84 +577,86 @@ let merge_branches | Failed { descr = descrt }, Typed dbf -> return (Typed (branch (descrt dbf.aft) dbf)) -let rec parse_comparable_ty : Script.expr -> ex_comparable_ty tzresult = function - | Prim (_, "int", [], _) -> ok (Ex_comparable_ty Int_key) - | Prim (_, "nat", [], _) -> ok (Ex_comparable_ty Nat_key) - | Prim (_, "string", [], _) -> ok (Ex_comparable_ty String_key) - | Prim (_, "tez", [], _) -> ok (Ex_comparable_ty Tez_key) - | Prim (_, "bool", [], _) -> ok (Ex_comparable_ty Bool_key) - | Prim (_, "key_hash", [], _) -> ok (Ex_comparable_ty Key_hash_key) - | Prim (_, "timestamp", [], _) -> ok (Ex_comparable_ty Timestamp_key) - | Prim (loc, ("int" | "nat" - | "string" | "tez" | "bool" - | "key" | "timestamp" as prim), l, _) -> +let rec parse_comparable_ty : Script.node -> ex_comparable_ty tzresult = function + | Prim (_, T_int, [], _) -> ok (Ex_comparable_ty Int_key) + | Prim (_, T_nat, [], _) -> ok (Ex_comparable_ty Nat_key) + | Prim (_, T_string, [], _) -> ok (Ex_comparable_ty String_key) + | Prim (_, T_tez, [], _) -> ok (Ex_comparable_ty Tez_key) + | Prim (_, T_bool, [], _) -> ok (Ex_comparable_ty Bool_key) + | Prim (_, T_key_hash, [], _) -> ok (Ex_comparable_ty Key_hash_key) + | Prim (_, T_timestamp, [], _) -> ok (Ex_comparable_ty Timestamp_key) + | Prim (loc, (T_int | T_nat + | T_string | T_tez | T_bool + | T_key | T_timestamp as prim), l, _) -> error (Invalid_arity (loc, prim, 0, List.length l)) - | Prim (loc, ("pair" | "or" | "set" | "map" - | "list" | "option" | "lambda" - | "unit" | "signature" | "contract"), _, _) as expr -> + | Prim (loc, (T_pair | T_or | T_set | T_map + | T_list | T_option | T_lambda + | T_unit | T_signature | T_contract), _, _) as expr -> parse_ty expr >>? fun (Ex_ty ty) -> error (Comparable_type_expected (loc, ty)) | expr -> error @@ unexpected expr [] Type_namespace - [ "int" ; "nat" ; - "string" ; "tez" ; "bool" ; - "key" ; "key_hash" ; "timestamp" ] + [ T_int ; T_nat ; + T_string ; T_tez ; T_bool ; + T_key ; T_key_hash ; T_timestamp ] -and parse_ty : Script.expr -> ex_ty tzresult = function - | Prim (_, "unit", [], _) -> ok (Ex_ty Unit_t) - | Prim (_, "int", [], _) -> ok (Ex_ty (Int_t)) - | Prim (_, "nat", [], _) -> ok (Ex_ty (Nat_t)) - | Prim (_, "string", [], _) -> ok (Ex_ty String_t) - | Prim (_, "tez", [], _) -> ok (Ex_ty Tez_t) - | Prim (_, "bool", [], _) -> ok (Ex_ty Bool_t) - | Prim (_, "key", [], _) -> ok (Ex_ty Key_t) - | Prim (_, "key_hash", [], _) -> ok (Ex_ty Key_hash_t) - | Prim (_, "timestamp", [], _) -> ok (Ex_ty Timestamp_t) - | Prim (_, "signature", [], _) -> ok (Ex_ty Signature_t) - | Prim (_, "contract", [ utl; utr ], _) -> +and parse_ty : Script.node -> ex_ty tzresult = function + | Prim (_, T_unit, [], _) -> ok (Ex_ty Unit_t) + | Prim (_, T_int, [], _) -> ok (Ex_ty (Int_t)) + | Prim (_, T_nat, [], _) -> ok (Ex_ty (Nat_t)) + | Prim (_, T_string, [], _) -> ok (Ex_ty String_t) + | Prim (_, T_tez, [], _) -> ok (Ex_ty Tez_t) + | Prim (_, T_bool, [], _) -> ok (Ex_ty Bool_t) + | Prim (_, T_key, [], _) -> ok (Ex_ty Key_t) + | Prim (_, T_key_hash, [], _) -> ok (Ex_ty Key_hash_t) + | Prim (_, T_timestamp, [], _) -> ok (Ex_ty Timestamp_t) + | Prim (_, T_signature, [], _) -> ok (Ex_ty Signature_t) + | Prim (_, T_contract, [ utl; utr ], _) -> parse_ty utl >>? fun (Ex_ty tl) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Contract_t (tl, tr))) - | Prim (_, "pair", [ utl; utr ], _) -> + | Prim (_, T_pair, [ utl; utr ], _) -> parse_ty utl >>? fun (Ex_ty tl) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Pair_t (tl, tr))) - | Prim (_, "or", [ utl; utr ], _) -> + | Prim (_, T_or, [ utl; utr ], _) -> parse_ty utl >>? fun (Ex_ty tl) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Union_t (tl, tr))) - | Prim (_, "lambda", [ uta; utr ], _) -> + | Prim (_, T_lambda, [ uta; utr ], _) -> parse_ty uta >>? fun (Ex_ty ta) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Lambda_t (ta, tr))) - | Prim (_, "option", [ ut ], _) -> + | Prim (_, T_option, [ ut ], _) -> parse_ty ut >>? fun (Ex_ty t) -> ok (Ex_ty (Option_t t)) - | Prim (_, "list", [ ut ], _) -> + | Prim (_, T_list, [ ut ], _) -> parse_ty ut >>? fun (Ex_ty t) -> ok (Ex_ty (List_t t)) - | Prim (_, "set", [ ut ], _) -> + | Prim (_, T_set, [ ut ], _) -> parse_comparable_ty ut >>? fun (Ex_comparable_ty t) -> ok (Ex_ty (Set_t t)) - | Prim (_, "map", [ uta; utr ], _) -> + | Prim (_, T_map, [ uta; utr ], _) -> parse_comparable_ty uta >>? fun (Ex_comparable_ty ta) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Map_t (ta, tr))) - | Prim (loc, ("pair" | "or" | "set" | "map" - | "list" | "option" | "lambda" - | "unit" | "signature" | "contract" - | "int" | "nat" - | "string" | "tez" | "bool" - | "key" | "key_hash" | "timestamp" as prim), l, _) -> + | Prim (loc, (T_pair | T_or | T_map as prim), l, _) -> + error (Invalid_arity (loc, prim, 2, List.length l)) + | Prim (loc, (T_set | T_list | T_option as prim), l, _) -> + error (Invalid_arity (loc, prim, 1, List.length l)) + | Prim (loc, ( T_unit | T_signature | T_contract + | T_int | T_nat + | T_string | T_tez | T_bool + | T_key | T_key_hash | T_timestamp as prim), l, _) -> error (Invalid_arity (loc, prim, 0, List.length l)) | expr -> error @@ unexpected expr [] Type_namespace - [ "pair" ; "or" ; "set" ; "map" ; - "list" ; "option" ; "lambda" ; - "unit" ; "signature" ; "contract" ; - "int" ; "nat" ; - "string" ; "tez" ; "bool" ; - "key" ; "key_hash" ; "timestamp" ] + [ T_pair ; T_or ; T_set ; T_map ; + T_list ; T_option ; T_lambda ; + T_unit ; T_signature ; T_contract ; + T_int ; T_nat ; + T_string ; T_tez ; T_bool ; + T_key ; T_key_hash ; T_timestamp ] let comparable_ty_of_ty : type a. int -> a ty -> a comparable_ty tzresult @@ -591,31 +674,31 @@ let rec unparse_stack : type a. a stack_ty -> Script.expr list = function | Empty_t -> [] - | Item_t (ty, rest) -> unparse_ty ty :: unparse_stack rest + | Item_t (ty, rest) -> strip_locations (unparse_ty ty) :: unparse_stack rest let rec parse_data : type a. - ?type_logger: (int * (Script.expr list * Script.expr list) -> unit) -> - context -> a ty -> Script.expr -> a tzresult Lwt.t + ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> + context -> a ty -> Script.node -> a tzresult Lwt.t = fun ?type_logger ctxt ty script_data -> let error () = - Invalid_constant (location script_data, script_data, ty) in + Invalid_constant (location script_data, strip_locations script_data, ty) in let traced body = trace (error ()) body in match ty, script_data with (* Unit *) - | Unit_t, Prim (_, "Unit", [], _) -> return () - | Unit_t, Prim (loc, "Unit", l, _) -> - traced (fail (Invalid_arity (loc, "Unit", 0, List.length l))) + | Unit_t, Prim (_, D_Unit, [], _) -> return () + | Unit_t, Prim (loc, D_Unit, l, _) -> + traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l))) | Unit_t, expr -> - traced (fail (unexpected expr [] Constant_namespace [ "Unit" ])) + traced (fail (unexpected expr [] Constant_namespace [ D_Unit ])) (* Booleans *) - | Bool_t, Prim (_, "True", [], _) -> return true - | Bool_t, Prim (_, "False", [], _) -> return false - | Bool_t, Prim (loc, ("True" | "False" as c), l, _) -> + | Bool_t, Prim (_, D_True, [], _) -> return true + | Bool_t, Prim (_, D_False, [], _) -> return false + | Bool_t, Prim (loc, (D_True | D_False as c), l, _) -> traced (fail (Invalid_arity (loc, c, 0, List.length l))) | Bool_t, expr -> - traced (fail (unexpected expr [] Constant_namespace [ "True" ; "False" ])) + traced (fail (unexpected expr [] Constant_namespace [ D_True ; D_False ])) (* Strings *) | String_t, String (_, v) -> return v | String_t, expr -> @@ -699,30 +782,30 @@ let rec parse_data | Contract_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Pairs *) - | Pair_t (ta, tb), Prim (_, "Pair", [ va; vb ], _) -> + | Pair_t (ta, tb), Prim (_, D_Pair, [ va; vb ], _) -> traced @@ parse_data ?type_logger ctxt ta va >>=? fun va -> parse_data ?type_logger ctxt tb vb >>=? fun vb -> return (va, vb) - | Pair_t _, Prim (loc, "Pair", l, _) -> - fail @@ Invalid_arity (loc, "Pair", 2, List.length l) + | Pair_t _, Prim (loc, D_Pair, l, _) -> + fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) | Pair_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ "Pair" ])) + traced (fail (unexpected expr [] Constant_namespace [ D_Pair ])) (* Unions *) - | Union_t (tl, _), Prim (_, "Left", [ v ], _) -> + | Union_t (tl, _), Prim (_, D_Left, [ v ], _) -> traced @@ parse_data ?type_logger ctxt tl v >>=? fun v -> return (L v) - | Union_t _, Prim (loc, "Left", l, _) -> - fail @@ Invalid_arity (loc, "Left", 1, List.length l) - | Union_t (_, tr), Prim (_, "Right", [ v ], _) -> + | Union_t _, Prim (loc, D_Left, l, _) -> + fail @@ Invalid_arity (loc, D_Left, 1, List.length l) + | Union_t (_, tr), Prim (_, D_Right, [ v ], _) -> traced @@ parse_data ?type_logger ctxt tr v >>=? fun v -> return (R v) - | Union_t _, Prim (loc, "Right", l, _) -> - fail @@ Invalid_arity (loc, "Right", 1, List.length l) + | Union_t _, Prim (loc, D_Right, l, _) -> + fail @@ Invalid_arity (loc, D_Right, 1, List.length l) | Union_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ "Left" ; "Right" ])) + traced (fail (unexpected expr [] Constant_namespace [ D_Left ; D_Right ])) (* Lambdas *) | Lambda_t (ta, tr), (Seq _ as script_instr) -> traced @@ @@ -730,20 +813,20 @@ let rec parse_data | Lambda_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Options *) - | Option_t t, Prim (_, "Some", [ v ], _) -> + | Option_t t, Prim (_, D_Some, [ v ], _) -> traced @@ parse_data ?type_logger ctxt t v >>=? fun v -> return (Some v) - | Option_t _, Prim (loc, "Some", l, _) -> - fail @@ Invalid_arity (loc, "Some", 1, List.length l) - | Option_t _, Prim (_, "None", [], _) -> + | Option_t _, Prim (loc, D_Some, l, _) -> + fail @@ Invalid_arity (loc, D_Some, 1, List.length l) + | Option_t _, Prim (_, D_None, [], _) -> return None - | Option_t _, Prim (loc, "None", l, _) -> - fail @@ Invalid_arity (loc, "None", 0, List.length l) + | Option_t _, Prim (loc, D_None, l, _) -> + fail @@ Invalid_arity (loc, D_None, 0, List.length l) | Option_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ "Some" ; "None" ])) + traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ])) (* Lists *) - | List_t t, Prim (_, "List", vs, _) -> + | List_t t, Prim (_, D_List, vs, _) -> traced @@ fold_right_s (fun v rest -> @@ -751,9 +834,9 @@ let rec parse_data return (v :: rest)) vs [] | List_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ "List" ])) + traced (fail (unexpected expr [] Constant_namespace [ D_List ])) (* Sets *) - | Set_t t, (Prim (loc, "Set", vs, _) as expr) -> + | Set_t t, (Prim (loc, D_Set, vs, _) as expr) -> fold_left_s (fun (last_value, set) v -> parse_comparable_data ?type_logger ctxt t v >>=? fun v -> @@ -762,20 +845,20 @@ let rec parse_data if Compare.Int.(0 <= (compare_comparable t value v)) then if Compare.Int.(0 = (compare_comparable t value v)) - then fail (Duplicate_set_values (loc, expr)) - else fail (Unordered_set_values (loc, expr)) + then fail (Duplicate_set_values (loc, strip_locations expr)) + else fail (Unordered_set_values (loc, strip_locations expr)) else return () | None -> return () end >>=? fun () -> return (Some v, set_update v true set)) (None, empty_set t) vs >>|? snd |> traced | Set_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ "Set" ])) + traced (fail (unexpected expr [] Constant_namespace [ D_Set ])) (* Maps *) - | Map_t (tk, tv), (Prim (loc, "Map", vs, _) as expr) -> + | Map_t (tk, tv), (Prim (loc, D_Map, vs, _) as expr) -> (fold_left_s (fun (last_value, map) -> function - | Prim (_, "Item", [ k; v ], _) -> + | Prim (_, D_Item, [ k; v ], _) -> parse_comparable_data ?type_logger ctxt tk k >>=? fun k -> parse_data ?type_logger ctxt tv v >>=? fun v -> begin match last_value with @@ -783,32 +866,32 @@ let rec parse_data if Compare.Int.(0 <= (compare_comparable tk value k)) then if Compare.Int.(0 = (compare_comparable tk value k)) - then fail (Duplicate_map_keys (loc, expr)) - else fail (Unordered_map_keys (loc, expr)) + then fail (Duplicate_map_keys (loc, strip_locations expr)) + else fail (Unordered_map_keys (loc, strip_locations expr)) else return () | None -> return () end >>=? fun () -> return (Some k, map_update k (Some v) map) - | Prim (loc, "Item", l, _) -> - fail @@ Invalid_arity (loc, "Item", 2, List.length l) + | Prim (loc, D_Item, l, _) -> + fail @@ Invalid_arity (loc, D_Item, 2, List.length l) | Prim (loc, name, _, _) -> - fail @@ Invalid_primitive (loc, [ "Item" ], name) + fail @@ Invalid_primitive (loc, [ D_Item ], name) | Int _ | String _ | Seq _ -> fail (error ())) (None, empty_map tk) vs) >>|? snd |> traced | Map_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ "Map" ])) + traced (fail (unexpected expr [] Constant_namespace [ D_Map ])) and parse_comparable_data - : type a. ?type_logger:(int * (Script.expr list * Script.expr list) -> unit) -> - context -> a comparable_ty -> Script.expr -> a tzresult Lwt.t + : type a. ?type_logger:(int -> Script.expr list -> Script.expr list -> unit) -> + context -> a comparable_ty -> Script.node -> a tzresult Lwt.t = fun ?type_logger ctxt ty script_data -> parse_data ?type_logger ctxt (ty_of_comparable_ty ty) script_data and parse_returning : type arg ret. tc_context -> context -> - ?type_logger: (int * (Script.expr list * Script.expr list) -> unit) -> - arg ty -> ret ty -> Script.expr -> (arg, ret) lambda tzresult Lwt.t = + ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> + arg ty -> ret ty -> Script.node -> (arg, ret) lambda tzresult Lwt.t = fun tc_context ctxt ?type_logger arg ret script_instr -> parse_instr tc_context ctxt ?type_logger script_instr (Item_t (arg, Empty_t)) >>=? function @@ -816,18 +899,18 @@ and parse_returning trace (Bad_return (loc, stack_ty, ret)) (Lwt.return (ty_eq ty ret)) >>=? fun (Eq _) -> - return (Lam (descr, script_instr) : (arg, ret) lambda) + return (Lam (descr, strip_locations script_instr) : (arg, ret) lambda) | Typed { loc ; aft = stack_ty } -> fail (Bad_return (loc, stack_ty, ret)) | Failed { descr } -> - return (Lam (descr (Item_t (ret, Empty_t)), script_instr) : (arg, ret) lambda) + return (Lam (descr (Item_t (ret, Empty_t)), strip_locations script_instr) : (arg, ret) lambda) and parse_instr : type bef. tc_context -> context -> - ?type_logger: (int * (Script.expr list * Script.expr list) -> unit) -> - Script.expr -> bef stack_ty -> bef judgement tzresult Lwt.t = + ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> + Script.node -> bef stack_ty -> bef judgement tzresult Lwt.t = fun tc_context ctxt ?type_logger script_instr stack_ty -> let return : bef judgement -> bef judgement tzresult Lwt.t = return in let check_item check loc name n m = @@ -837,39 +920,41 @@ and parse_instr let check_item_ty exp got loc n = check_item (ty_eq exp got) loc n in let typed loc annot (instr, aft) = - begin match type_logger with - | Some log -> log (loc, (unparse_stack stack_ty, unparse_stack aft)) - | None -> () + begin match type_logger, script_instr with + | None, _ + | Some _, (Seq (-1, _, _) | Int _ | String _) -> () + | Some log, (Prim _ | Seq _) -> + log loc (unparse_stack stack_ty) (unparse_stack aft) end ; Typed { loc ; instr ; bef = stack_ty ; aft ; annot } in match script_instr, stack_ty with (* stack ops *) - | Prim (loc, "DROP", [], annot), + | Prim (loc, I_DROP, [], annot), Item_t (_, rest) -> return (typed loc annot (Drop, rest)) - | Prim (loc, "DUP", [], annot), + | Prim (loc, I_DUP, [], annot), Item_t (v, rest) -> return (typed loc annot (Dup, Item_t (v, Item_t (v, rest)))) - | Prim (loc, "SWAP", [], annot), + | Prim (loc, I_SWAP, [], annot), Item_t (v, Item_t (w, rest)) -> return (typed loc annot (Swap, Item_t (w, Item_t (v, rest)))) - | Prim (loc, "PUSH", [ t ; d ], annot), + | Prim (loc, I_PUSH, [ t ; d ], annot), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t) -> parse_data ?type_logger ctxt t d >>=? fun v -> return (typed loc annot (Const v, Item_t (t, stack))) - | Prim (loc, "UNIT", [], annot), + | Prim (loc, I_UNIT, [], annot), stack -> return (typed loc annot (Const (), Item_t (Unit_t, stack))) (* options *) - | Prim (loc, "SOME", [], annot), + | Prim (loc, I_SOME, [], annot), Item_t (t, rest) -> return (typed loc annot (Cons_some, Item_t (Option_t t, rest))) - | Prim (loc, "NONE", [ t ], annot), + | Prim (loc, I_NONE, [ t ], annot), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t) -> return (typed loc annot (Cons_none t, Item_t (Option_t t, stack))) - | Prim (loc, "IF_NONE", [ bt ; bf ], annot), + | Prim (loc, I_IF_NONE, [ bt ; bf ], annot), (Item_t (Option_t t, rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> @@ -879,25 +964,25 @@ and parse_instr { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft ; annot } in merge_branches loc btr bfr { branch } (* pairs *) - | Prim (loc, "PAIR", [], annot), + | Prim (loc, I_PAIR, [], annot), Item_t (a, Item_t (b, rest)) -> return (typed loc annot (Cons_pair, Item_t (Pair_t(a, b), rest))) - | Prim (loc, "CAR", [], annot), + | Prim (loc, I_CAR, [], annot), Item_t (Pair_t (a, _), rest) -> return (typed loc annot (Car, Item_t (a, rest))) - | Prim (loc, "CDR", [], annot), + | Prim (loc, I_CDR, [], annot), Item_t (Pair_t (_, b), rest) -> return (typed loc annot (Cdr, Item_t (b, rest))) (* unions *) - | Prim (loc, "LEFT", [ tr ], annot), + | Prim (loc, I_LEFT, [ tr ], annot), Item_t (tl, rest) -> (Lwt.return (parse_ty tr)) >>=? fun (Ex_ty tr) -> return (typed loc annot (Left, Item_t (Union_t (tl, tr), rest))) - | Prim (loc, "RIGHT", [ tl ], annot), + | Prim (loc, I_RIGHT, [ tl ], annot), Item_t (tr, rest) -> (Lwt.return (parse_ty tl)) >>=? fun (Ex_ty tl) -> return (typed loc annot (Right, Item_t (Union_t (tl, tr), rest))) - | Prim (loc, "IF_LEFT", [ bt ; bf ], annot), + | Prim (loc, I_IF_LEFT, [ bt ; bf ], annot), (Item_t (Union_t (tl, tr), rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> @@ -907,15 +992,15 @@ and parse_instr { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft ; annot } in merge_branches loc btr bfr { branch } (* lists *) - | Prim (loc, "NIL", [ t ], annot), + | Prim (loc, I_NIL, [ t ], annot), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t) -> return (typed loc annot (Nil, Item_t (List_t t, stack))) - | Prim (loc, "CONS", [], annot), + | Prim (loc, I_CONS, [], annot), Item_t (tv, Item_t (List_t t, rest)) -> - check_item_ty tv t loc "CONS" 1 2 >>=? fun (Eq _) -> + check_item_ty tv t loc I_CONS 1 2 >>=? fun (Eq _) -> return (typed loc annot (Cons_list, Item_t (List_t t, rest))) - | Prim (loc, "IF_CONS", [ bt ; bf ], annot), + | Prim (loc, I_IF_CONS, [ bt ; bf ], annot), (Item_t (List_t t, rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> @@ -924,99 +1009,96 @@ and parse_instr let branch ibt ibf = { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft ; annot } in merge_branches loc btr bfr { branch } - | Prim (loc, "MAP", [], annot), + | Prim (loc, I_MAP, [], annot), Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest)) -> - check_item_ty elt param loc "MAP" 2 2 >>=? fun (Eq _) -> + check_item_ty elt param loc I_MAP 2 2 >>=? fun (Eq _) -> return (typed loc annot (List_map, Item_t (List_t ret, rest))) - | Prim (loc, "REDUCE", [], annot), + | Prim (loc, I_REDUCE, [], annot), Item_t (Lambda_t (Pair_t (pelt, pr), r), Item_t (List_t elt, Item_t (init, rest))) -> - check_item_ty r pr loc "REDUCE" 1 3 >>=? fun (Eq _) -> - check_item_ty elt pelt loc "REDUCE" 2 3 >>=? fun (Eq _) -> - check_item_ty init r loc "REDUCE" 3 3 >>=? fun (Eq _) -> + check_item_ty r pr loc I_REDUCE 1 3 >>=? fun (Eq _) -> + check_item_ty elt pelt loc I_REDUCE 2 3 >>=? fun (Eq _) -> + check_item_ty init r loc I_REDUCE 3 3 >>=? fun (Eq _) -> return (typed loc annot (List_reduce, Item_t (r, rest))) - | Prim (loc, "SIZE", [], annot), + | Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest) -> return (typed loc annot (List_size, Item_t (Nat_t, rest))) (* sets *) - | Prim (loc, "EMPTY_SET", [ t ], annot), + | Prim (loc, I_EMPTY_SET, [ t ], annot), rest -> (Lwt.return (parse_comparable_ty t)) >>=? fun (Ex_comparable_ty t) -> return (typed loc annot (Empty_set t, Item_t (Set_t t, rest))) - | Prim (loc, "MAP", [], annot), + | Prim (loc, I_MAP, [], annot), Item_t (Lambda_t (param, ret), Item_t (Set_t elt, rest)) -> let elt = ty_of_comparable_ty elt in (Lwt.return (comparable_ty_of_ty loc ret)) >>=? fun ret -> - check_item_ty elt param loc "MAP" 1 2 >>=? fun (Eq _) -> + check_item_ty elt param loc I_MAP 1 2 >>=? fun (Eq _) -> return (typed loc annot (Set_map ret, Item_t (Set_t ret, rest))) - | Prim (loc, "REDUCE", [], annot), + | Prim (loc, I_REDUCE, [], annot), Item_t (Lambda_t (Pair_t (pelt, pr), r), Item_t (Set_t elt, Item_t (init, rest))) -> let elt = ty_of_comparable_ty elt in - check_item_ty r pr loc "REDUCE" 1 3 >>=? fun (Eq _) -> - check_item_ty elt pelt loc "REDUCE" 2 3 >>=? fun (Eq _) -> - check_item_ty init r loc "REDUCE" 3 3 >>=? fun (Eq _) -> + check_item_ty r pr loc I_REDUCE 1 3 >>=? fun (Eq _) -> + check_item_ty elt pelt loc I_REDUCE 2 3 >>=? fun (Eq _) -> + check_item_ty init r loc I_REDUCE 3 3 >>=? fun (Eq _) -> return (typed loc annot (Set_reduce, Item_t (r, rest))) - | Prim (loc, "MEM", [], annot), + | Prim (loc, I_MEM, [], annot), Item_t (v, Item_t (Set_t elt, rest)) -> let elt = ty_of_comparable_ty elt in - check_item_ty elt v loc "MEM" 1 2 >>=? fun (Eq _) -> + check_item_ty elt v loc I_MEM 1 2 >>=? fun (Eq _) -> return (typed loc annot (Set_mem, Item_t (Bool_t, rest))) - | Prim (loc, "UPDATE", [], annot), + | Prim (loc, I_UPDATE, [], annot), Item_t (v, Item_t (Bool_t, Item_t (Set_t elt, rest))) -> let ty = ty_of_comparable_ty elt in - check_item_ty ty v loc "UPDATE" 1 3 >>=? fun (Eq _) -> + check_item_ty ty v loc I_UPDATE 1 3 >>=? fun (Eq _) -> return (typed loc annot (Set_update, Item_t (Set_t elt, rest))) - | Prim (loc, "SIZE", [], annot), + | Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest) -> return (typed loc annot (Set_size, Item_t (Nat_t, rest))) (* maps *) - | Prim (loc, "EMPTY_MAP", [ tk ; tv ], annot), + | Prim (loc, I_EMPTY_MAP, [ tk ; tv ], annot), stack -> (Lwt.return (parse_comparable_ty tk)) >>=? fun (Ex_comparable_ty tk) -> (Lwt.return (parse_ty tv)) >>=? fun (Ex_ty tv) -> return (typed loc annot (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack))) - | Prim (loc, "MAP", [], annot), + | Prim (loc, I_MAP, [], annot), Item_t (Lambda_t (Pair_t (pk, pv), ret), Item_t (Map_t (ck, v), rest)) -> let k = ty_of_comparable_ty ck in - check_item_ty pk k loc "MAP" 1 2 >>=? fun (Eq _) -> - check_item_ty pv v loc "MAP" 1 2 >>=? fun (Eq _) -> + check_item_ty pk k loc I_MAP 1 2 >>=? fun (Eq _) -> + check_item_ty pv v loc I_MAP 1 2 >>=? fun (Eq _) -> return (typed loc annot (Map_map, Item_t (Map_t (ck, ret), rest))) - | Prim (loc, "REDUCE", [], annot), + | Prim (loc, I_REDUCE, [], annot), Item_t (Lambda_t (Pair_t (Pair_t (pk, pv), pr), r), Item_t (Map_t (ck, v), Item_t (init, rest))) -> let k = ty_of_comparable_ty ck in - check_item_ty pk k loc "REDUCE" 2 3 >>=? fun (Eq _) -> - check_item_ty pv v loc "REDUCE" 2 3 >>=? fun (Eq _) -> - check_item_ty r pr loc "REDUCE" 1 3 >>=? fun (Eq _) -> - check_item_ty init r loc "REDUCE" 3 3 >>=? fun (Eq _) -> + check_item_ty pk k loc I_REDUCE 2 3 >>=? fun (Eq _) -> + check_item_ty pv v loc I_REDUCE 2 3 >>=? fun (Eq _) -> + check_item_ty r pr loc I_REDUCE 1 3 >>=? fun (Eq _) -> + check_item_ty init r loc I_REDUCE 3 3 >>=? fun (Eq _) -> return (typed loc annot (Map_reduce, Item_t (r, rest))) - | Prim (loc, "MEM", [], annot), + | Prim (loc, I_MEM, [], annot), Item_t (vk, Item_t (Map_t (ck, _), rest)) -> let k = ty_of_comparable_ty ck in - check_item_ty vk k loc "MEM" 1 2 >>=? fun (Eq _) -> + check_item_ty vk k loc I_MEM 1 2 >>=? fun (Eq _) -> return (typed loc annot (Map_mem, Item_t (Bool_t, rest))) - | Prim (loc, "GET", [], annot), + | Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Map_t (ck, elt), rest)) -> let k = ty_of_comparable_ty ck in - check_item_ty vk k loc "GET" 1 2 >>=? fun (Eq _) -> + check_item_ty vk k loc I_GET 1 2 >>=? fun (Eq _) -> return (typed loc annot (Map_get, Item_t (Option_t elt, rest))) - | Prim (loc, "UPDATE", [], annot), + | Prim (loc, I_UPDATE, [], annot), Item_t (vk, Item_t (Option_t vv, Item_t (Map_t (ck, v), rest))) -> let k = ty_of_comparable_ty ck in - check_item_ty vk k loc "UPDATE" 1 3 >>=? fun (Eq _) -> - check_item_ty vv v loc "UPDATE" 2 3 >>=? fun (Eq _) -> + check_item_ty vk k loc I_UPDATE 1 3 >>=? fun (Eq _) -> + check_item_ty vv v loc I_UPDATE 2 3 >>=? fun (Eq _) -> return (typed loc annot (Map_update, Item_t (Map_t (ck, v), rest))) - | Prim (loc, "SIZE", [], annot), + | Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _), rest) -> return (typed loc annot (Map_size, Item_t (Nat_t, rest))) (* control *) | Seq (loc, [], annot), stack -> return (typed loc annot (Nop, stack)) - | Seq (_, [ single ], None), - stack -> - parse_instr ?type_logger tc_context ctxt single stack | Seq (loc, [ single ], (Some _ as annot)), stack -> parse_instr ?type_logger tc_context ctxt single stack >>=? begin function @@ -1034,9 +1116,9 @@ and parse_instr stack -> parse_instr ?type_logger tc_context ctxt hd stack >>=? begin function | Failed _ -> - fail (Fail_not_in_tail_position loc) + fail (Fail_not_in_tail_position (Micheline.location hd)) | Typed ({ aft = middle } as ihd) -> - parse_instr ?type_logger tc_context ctxt (Seq (loc, tl, annot)) middle >>=? function + parse_instr ?type_logger tc_context ctxt (Seq (-1, tl, annot)) middle >>=? function | Failed { descr } -> let descr ret = { loc ; instr = Seq (ihd, descr ret) ; @@ -1045,7 +1127,7 @@ and parse_instr | Typed itl -> return (typed loc annot (Seq (ihd, itl), itl.aft)) end - | Prim (loc, "IF", [ bt ; bf ], annot), + | Prim (loc, I_IF, [ bt ; bf ], annot), (Item_t (Bool_t, rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> @@ -1054,7 +1136,7 @@ and parse_instr let branch ibt ibf = { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft ; annot } in merge_branches loc btr bfr { branch } - | Prim (loc, "LOOP", [ body ], annot), + | Prim (loc, I_LOOP, [ body ], annot), (Item_t (Bool_t, rest) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> parse_instr ?type_logger tc_context ctxt body rest >>=? begin function @@ -1067,18 +1149,18 @@ and parse_instr let ibody = descr (Item_t (Bool_t, rest)) in return (typed loc annot (Loop ibody, rest)) end - | Prim (loc, "LAMBDA", [ arg ; ret ; code ], annot), + | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], annot), stack -> (Lwt.return (parse_ty arg)) >>=? fun (Ex_ty arg) -> (Lwt.return (parse_ty ret)) >>=? fun (Ex_ty ret) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_returning Lambda ?type_logger ctxt arg ret code >>=? fun lambda -> return (typed loc annot (Lambda lambda, Item_t (Lambda_t (arg, ret), stack))) - | Prim (loc, "EXEC", [], annot), + | Prim (loc, I_EXEC, [], annot), Item_t (arg, Item_t (Lambda_t (param, ret), rest)) -> - check_item_ty arg param loc "EXEC" 1 2 >>=? fun (Eq _) -> + check_item_ty arg param loc I_EXEC 1 2 >>=? fun (Eq _) -> return (typed loc annot (Exec, Item_t (ret, rest))) - | Prim (loc, "DIP", [ code ], annot), + | Prim (loc, I_DIP, [ code ], annot), Item_t (v, rest) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_instr ?type_logger (add_dip v tc_context) ctxt code rest >>=? begin function @@ -1087,207 +1169,207 @@ and parse_instr | Failed _ -> fail (Fail_not_in_tail_position loc) end - | Prim (loc, "FAIL", [], annot), + | Prim (loc, I_FAIL, [], annot), bef -> let descr aft = { loc ; instr = Fail ; bef ; aft ; annot } in return (Failed { descr }) (* timestamp operations *) - | Prim (loc, "ADD", [], annot), + | Prim (loc, I_ADD, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest)) -> return (typed loc annot (Add_timestamp_to_seconds, Item_t (Timestamp_t, rest))) - | Prim (loc, "ADD", [], annot), + | Prim (loc, I_ADD, [], annot), Item_t (Int_t, Item_t (Timestamp_t, rest)) -> return (typed loc annot (Add_seconds_to_timestamp, Item_t (Timestamp_t, rest))) - | Prim (loc, "SUB", [], annot), + | Prim (loc, I_SUB, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest)) -> return (typed loc annot (Sub_timestamp_seconds, Item_t (Timestamp_t, rest))) - | Prim (loc, "SUB", [], annot), + | Prim (loc, I_SUB, [], annot), Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) -> return (typed loc annot (Diff_timestamps, Item_t (Int_t, rest))) (* string operations *) - | Prim (loc, "CONCAT", [], annot), + | Prim (loc, I_CONCAT, [], annot), Item_t (String_t, Item_t (String_t, rest)) -> return (typed loc annot (Concat, Item_t (String_t, rest))) (* currency operations *) - | Prim (loc, "ADD", [], annot), + | Prim (loc, I_ADD, [], annot), Item_t (Tez_t, Item_t (Tez_t, rest)) -> return (typed loc annot (Add_tez, Item_t (Tez_t, rest))) - | Prim (loc, "SUB", [], annot), + | Prim (loc, I_SUB, [], annot), Item_t (Tez_t, Item_t (Tez_t, rest)) -> return (typed loc annot (Sub_tez, Item_t (Tez_t, rest))) - | Prim (loc, "MUL", [], annot), + | Prim (loc, I_MUL, [], annot), Item_t (Tez_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Mul_teznat, Item_t (Tez_t, rest))) - | Prim (loc, "MUL", [], annot), + | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, Item_t (Tez_t, rest)) -> return (typed loc annot (Mul_nattez, Item_t (Tez_t, rest))) (* boolean operations *) - | Prim (loc, "OR", [], annot), + | Prim (loc, I_OR, [], annot), Item_t (Bool_t, Item_t (Bool_t, rest)) -> return (typed loc annot (Or, Item_t (Bool_t, rest))) - | Prim (loc, "AND", [], annot), + | Prim (loc, I_AND, [], annot), Item_t (Bool_t, Item_t (Bool_t, rest)) -> return (typed loc annot (And, Item_t (Bool_t, rest))) - | Prim (loc, "XOR", [], annot), + | Prim (loc, I_XOR, [], annot), Item_t (Bool_t, Item_t (Bool_t, rest)) -> return (typed loc annot (Xor, Item_t (Bool_t, rest))) - | Prim (loc, "NOT", [], annot), + | Prim (loc, I_NOT, [], annot), Item_t (Bool_t, rest) -> return (typed loc annot (Not, Item_t (Bool_t, rest))) (* integer operations *) - | Prim (loc, "ABS", [], annot), + | Prim (loc, I_ABS, [], annot), Item_t (Int_t, rest) -> return (typed loc annot (Abs_int, Item_t (Nat_t, rest))) - | Prim (loc, "INT", [], annot), + | Prim (loc, I_INT, [], annot), Item_t (Nat_t, rest) -> return (typed loc annot (Int_nat, Item_t (Int_t, rest))) - | Prim (loc, "NEG", [], annot), + | Prim (loc, I_NEG, [], annot), Item_t (Int_t, rest) -> return (typed loc annot (Neg_int, Item_t (Int_t, rest))) - | Prim (loc, "NEG", [], annot), + | Prim (loc, I_NEG, [], annot), Item_t (Nat_t, rest) -> return (typed loc annot (Neg_nat, Item_t (Int_t, rest))) - | Prim (loc, "ADD", [], annot), + | Prim (loc, I_ADD, [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> return (typed loc annot (Add_intint, Item_t (Int_t, rest))) - | Prim (loc, "ADD", [], annot), + | Prim (loc, I_ADD, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Add_intnat, Item_t (Int_t, rest))) - | Prim (loc, "ADD", [], annot), + | Prim (loc, I_ADD, [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) -> return (typed loc annot (Add_natint, Item_t (Int_t, rest))) - | Prim (loc, "ADD", [], annot), + | Prim (loc, I_ADD, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Add_natnat, Item_t (Nat_t, rest))) - | Prim (loc, "SUB", [], annot), + | Prim (loc, I_SUB, [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> return (typed loc annot (Sub_int, Item_t (Int_t, rest))) - | Prim (loc, "SUB", [], annot), + | Prim (loc, I_SUB, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Sub_int, Item_t (Int_t, rest))) - | Prim (loc, "SUB", [], annot), + | Prim (loc, I_SUB, [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) -> return (typed loc annot (Sub_int, Item_t (Int_t, rest))) - | Prim (loc, "SUB", [], annot), + | Prim (loc, I_SUB, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Sub_int, Item_t (Int_t, rest))) - | Prim (loc, "MUL", [], annot), + | Prim (loc, I_MUL, [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> return (typed loc annot (Mul_intint, Item_t (Int_t, rest))) - | Prim (loc, "MUL", [], annot), + | Prim (loc, I_MUL, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Mul_intnat, Item_t (Int_t, rest))) - | Prim (loc, "MUL", [], annot), + | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) -> return (typed loc annot (Mul_natint, Item_t (Int_t, rest))) - | Prim (loc, "MUL", [], annot), + | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Mul_natnat, Item_t (Nat_t, rest))) - | Prim (loc, "EDIV", [], annot), + | Prim (loc, I_EDIV, [], annot), Item_t (Tez_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Ediv_teznat, Item_t (Option_t (Pair_t (Tez_t,Tez_t)), rest))) - | Prim (loc, "EDIV", [], annot), + | Prim (loc, I_EDIV, [], annot), Item_t (Tez_t, Item_t (Tez_t, rest)) -> return (typed loc annot (Ediv_tez, Item_t (Option_t (Pair_t (Nat_t,Tez_t)), rest))) - | Prim (loc, "EDIV", [], annot), + | Prim (loc, I_EDIV, [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> return (typed loc annot (Ediv_intint, Item_t (Option_t (Pair_t (Int_t,Nat_t)), rest))) - | Prim (loc, "EDIV", [], annot), + | Prim (loc, I_EDIV, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Ediv_intnat, Item_t (Option_t (Pair_t (Int_t,Nat_t)), rest))) - | Prim (loc, "EDIV", [], annot), + | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) -> return (typed loc annot (Ediv_natint, Item_t (Option_t (Pair_t (Int_t,Nat_t)), rest))) - | Prim (loc, "EDIV", [], annot), + | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Ediv_natnat, Item_t (Option_t (Pair_t (Nat_t,Nat_t)), rest))) - | Prim (loc, "LSL", [], annot), + | Prim (loc, I_LSL, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Lsl_nat, Item_t (Nat_t, rest))) - | Prim (loc, "LSR", [], annot), + | Prim (loc, I_LSR, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Lsr_nat, Item_t (Nat_t, rest))) - | Prim (loc, "OR", [], annot), + | Prim (loc, I_OR, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Or_nat, Item_t (Nat_t, rest))) - | Prim (loc, "AND", [], annot), + | Prim (loc, I_AND, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> return (typed loc annot (And_nat, Item_t (Nat_t, rest))) - | Prim (loc, "XOR", [], annot), + | Prim (loc, I_XOR, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Xor_nat, Item_t (Nat_t, rest))) - | Prim (loc, "NOT", [], annot), + | Prim (loc, I_NOT, [], annot), Item_t (Int_t, rest) -> return (typed loc annot (Not_int, Item_t (Int_t, rest))) - | Prim (loc, "NOT", [], annot), + | Prim (loc, I_NOT, [], annot), Item_t (Nat_t, rest) -> return (typed loc annot (Not_nat, Item_t (Int_t, rest))) (* comparison *) - | Prim (loc, "COMPARE", [], annot), + | Prim (loc, I_COMPARE, [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> return (typed loc annot (Compare Int_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", [], annot), + | Prim (loc, I_COMPARE, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> return (typed loc annot (Compare Nat_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", [], annot), + | Prim (loc, I_COMPARE, [], annot), Item_t (Bool_t, Item_t (Bool_t, rest)) -> return (typed loc annot (Compare Bool_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", [], annot), + | Prim (loc, I_COMPARE, [], annot), Item_t (String_t, Item_t (String_t, rest)) -> return (typed loc annot (Compare String_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", [], annot), + | Prim (loc, I_COMPARE, [], annot), Item_t (Tez_t, Item_t (Tez_t, rest)) -> return (typed loc annot (Compare Tez_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", [], annot), + | Prim (loc, I_COMPARE, [], annot), Item_t (Key_hash_t, Item_t (Key_hash_t, rest)) -> return (typed loc annot (Compare Key_hash_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", [], annot), + | Prim (loc, I_COMPARE, [], annot), Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) -> return (typed loc annot (Compare Timestamp_key, Item_t (Int_t, rest))) (* comparators *) - | Prim (loc, "EQ", [], annot), + | Prim (loc, I_EQ, [], annot), Item_t (Int_t, rest) -> return (typed loc annot (Eq, Item_t (Bool_t, rest))) - | Prim (loc, "NEQ", [], annot), + | Prim (loc, I_NEQ, [], annot), Item_t (Int_t, rest) -> return (typed loc annot (Neq, Item_t (Bool_t, rest))) - | Prim (loc, "LT", [], annot), + | Prim (loc, I_LT, [], annot), Item_t (Int_t, rest) -> return (typed loc annot (Lt, Item_t (Bool_t, rest))) - | Prim (loc, "GT", [], annot), + | Prim (loc, I_GT, [], annot), Item_t (Int_t, rest) -> return (typed loc annot (Gt, Item_t (Bool_t, rest))) - | Prim (loc, "LE", [], annot), + | Prim (loc, I_LE, [], annot), Item_t (Int_t, rest) -> return (typed loc annot (Le, Item_t (Bool_t, rest))) - | Prim (loc, "GE", [], annot), + | Prim (loc, I_GE, [], annot), Item_t (Int_t, rest) -> return (typed loc annot (Ge, Item_t (Bool_t, rest))) (* protocol *) - | Prim (loc, "MANAGER", [], annot), + | Prim (loc, I_MANAGER, [], annot), Item_t (Contract_t _, rest) -> return (typed loc annot (Manager, Item_t (Key_hash_t, rest))) - | Prim (loc, "TRANSFER_TOKENS", [], annot), + | Prim (loc, I_TRANSFER_TOKENS, [], annot), Item_t (p, Item_t (Tez_t, Item_t (Contract_t (cp, cr), Item_t (storage, Empty_t)))) -> - check_item_ty p cp loc "TRANSFER_TOKENS" 1 4 >>=? fun (Eq _) -> + check_item_ty p cp loc I_TRANSFER_TOKENS 1 4 >>=? fun (Eq _) -> begin match tc_context with | Dip _ -> fail (Transfer_in_dip loc) | Lambda -> fail (Transfer_in_lambda loc) | Toplevel { storage_type } -> - check_item_ty storage storage_type loc "TRANSFER_TOKENS" 3 4 >>=? fun (Eq _) -> + check_item_ty storage storage_type loc I_TRANSFER_TOKENS 3 4 >>=? fun (Eq _) -> return (typed loc annot (Transfer_tokens storage, Item_t (cr, Item_t (storage, Empty_t)))) end - | Prim (loc, "CREATE_ACCOUNT", [], annot), + | Prim (loc, I_CREATE_ACCOUNT, [], annot), Item_t (Key_hash_t, Item_t (Option_t Key_hash_t, Item_t @@ -1295,11 +1377,11 @@ and parse_instr (Tez_t, rest)))) -> return (typed loc annot (Create_account, Item_t (Contract_t (Unit_t, Unit_t), rest))) - | Prim (loc, "DEFAULT_ACCOUNT", [], annot), + | Prim (loc, I_DEFAULT_ACCOUNT, [], annot), Item_t (Key_hash_t, rest) -> return (typed loc annot (Default_account, Item_t (Contract_t (Unit_t, Unit_t), rest))) - | Prim (loc, "CREATE_CONTRACT", [], annot), + | Prim (loc, I_CREATE_CONTRACT, [], annot), Item_t (Key_hash_t, Item_t (Option_t Key_hash_t, Item_t @@ -1309,125 +1391,125 @@ and parse_instr (Lambda_t (Pair_t (p, gp), Pair_t (r, gr)), Item_t (ginit, rest))))))) -> - check_item_ty gp gr loc "CREATE_CONTRACT" 5 7 >>=? fun (Eq _) -> - check_item_ty ginit gp loc "CREATE_CONTRACT" 6 7 >>=? fun (Eq _) -> + check_item_ty gp gr loc I_CREATE_CONTRACT 5 7 >>=? fun (Eq _) -> + check_item_ty ginit gp loc I_CREATE_CONTRACT 6 7 >>=? fun (Eq _) -> return (typed loc annot (Create_contract (gp, p, r), Item_t (Contract_t (p, r), rest))) - | Prim (loc, "NOW", [], annot), + | Prim (loc, I_NOW, [], annot), stack -> return (typed loc annot (Now, Item_t (Timestamp_t, stack))) - | Prim (loc, "AMOUNT", [], annot), + | Prim (loc, I_AMOUNT, [], annot), stack -> return (typed loc annot (Amount, Item_t (Tez_t, stack))) - | Prim (loc, "BALANCE", [], annot), + | Prim (loc, I_BALANCE, [], annot), stack -> return (typed loc annot (Balance, Item_t (Tez_t, stack))) - | Prim (loc, "HASH_KEY", [], annot), + | Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t, rest) -> return (typed loc annot (Hash_key, Item_t (Key_hash_t, rest))) - | Prim (loc, "CHECK_SIGNATURE", [], annot), + | Prim (loc, I_CHECK_SIGNATURE, [], annot), Item_t (Key_t, Item_t (Pair_t (Signature_t, String_t), rest)) -> return (typed loc annot (Check_signature, Item_t (Bool_t, rest))) - | Prim (loc, "H", [], annot), + | Prim (loc, I_H, [], annot), Item_t (t, rest) -> return (typed loc annot (H t, Item_t (String_t, rest))) - | Prim (loc, "STEPS_TO_QUOTA", [], annot), + | Prim (loc, I_STEPS_TO_QUOTA, [], annot), stack -> return (typed loc annot (Steps_to_quota, Item_t (Nat_t, stack))) - | Prim (loc, "SOURCE", [ ta; tb ], annot), + | Prim (loc, I_SOURCE, [ ta; tb ], annot), stack -> (Lwt.return (parse_ty ta)) >>=? fun (Ex_ty ta) -> (Lwt.return (parse_ty tb)) >>=? fun (Ex_ty tb) -> return (typed loc annot (Source (ta, tb), Item_t (Contract_t (ta, tb), stack))) (* Primitive parsing errors *) - | Prim (loc, ("DROP" | "DUP" | "SWAP" | "SOME" | "UNIT" - | "PAIR" | "CAR" | "CDR" | "CONS" - | "MEM" | "UPDATE" | "MAP" | "REDUCE" - | "GET" | "EXEC" | "FAIL" | "SIZE" - | "CONCAT" | "ADD" | "SUB" - | "MUL" | "EDIV" | "OR" | "AND" | "XOR" - | "NOT" - | "ABS" | "NEG" | "LSL" | "LSR" - | "COMPARE" | "EQ" | "NEQ" - | "LT" | "GT" | "LE" | "GE" - | "MANAGER" | "TRANSFER_TOKENS" | "CREATE_ACCOUNT" - | "CREATE_CONTRACT" | "NOW" - | "DEFAULT_ACCOUNT" | "AMOUNT" | "BALANCE" - | "CHECK_SIGNATURE" | "HASH_KEY" - | "H" | "STEPS_TO_QUOTA" + | Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT + | I_PAIR | I_CAR | I_CDR | I_CONS + | I_MEM | I_UPDATE | I_MAP | I_REDUCE + | I_GET | I_EXEC | I_FAIL | I_SIZE + | I_CONCAT | I_ADD | I_SUB + | I_MUL | I_EDIV | I_OR | I_AND | I_XOR + | I_NOT + | I_ABS | I_NEG | I_LSL | I_LSR + | I_COMPARE | I_EQ | I_NEQ + | I_LT | I_GT | I_LE | I_GE + | I_MANAGER | I_TRANSFER_TOKENS | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT | I_NOW + | I_DEFAULT_ACCOUNT | I_AMOUNT | I_BALANCE + | I_CHECK_SIGNATURE | I_HASH_KEY + | I_H | I_STEPS_TO_QUOTA as name), (_ :: _ as l), _), _ -> fail (Invalid_arity (loc, name, 0, List.length l)) - | Prim (loc, ("NONE" | "LEFT" | "RIGHT" | "NIL" - | "EMPTY_SET" | "DIP" | "LOOP" + | Prim (loc, (I_NONE | I_LEFT | I_RIGHT | I_NIL + | I_EMPTY_SET | I_DIP | I_LOOP as name), ([] | _ :: _ :: _ as l), _), _ -> fail (Invalid_arity (loc, name, 1, List.length l)) - | Prim (loc, ("PUSH" | "IF_NONE" | "IF_LEFT" | "IF_CONS" - | "EMPTY_MAP" | "IF" | "SOURCE" + | Prim (loc, (I_PUSH | I_IF_NONE | I_IF_LEFT | I_IF_CONS + | I_EMPTY_MAP | I_IF | I_SOURCE as name), ([] | [ _ ] | _ :: _ :: _ :: _ as l), _), _ -> fail (Invalid_arity (loc, name, 2, List.length l)) - | Prim (loc, "LAMBDA", ([] | [ _ ] | [ _ ; _ ] + | Prim (loc, I_LAMBDA, ([] | [ _ ] | [ _ ; _ ] | _ :: _ :: _ :: _ :: _ as l), _), _ -> - fail (Invalid_arity (loc, "LAMBDA", 3, List.length l)) + fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l)) (* Stack errors *) - | Prim (loc, ("ADD" | "SUB" | "MUL" | "EDIV" - | "AND" | "OR" | "XOR" | "LSL" | "LSR" - | "CONCAT" | "COMPARE" as name), [], _), + | Prim (loc, (I_ADD | I_SUB | I_MUL | I_EDIV + | I_AND | I_OR | I_XOR | I_LSL | I_LSR + | I_CONCAT | I_COMPARE as name), [], _), Item_t (ta, Item_t (tb, _)) -> fail (Undefined_binop (loc, name, ta, tb)) - | Prim (loc, ("NEG" | "ABS" | "NOT" - | "EQ" | "NEQ" | "LT" | "GT" | "LE" | "GE" as name), + | Prim (loc, (I_NEG | I_ABS | I_NOT + | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE as name), [], _), Item_t (t, _) -> fail (Undefined_unop (loc, name, t)) - | Prim (loc, ("REDUCE" | "UPDATE" as name), [], _), + | Prim (loc, (I_REDUCE | I_UPDATE as name), [], _), stack -> fail (Bad_stack (loc, name, 3, stack)) - | Prim (loc, "CREATE_CONTRACT", [], _), + | Prim (loc, I_CREATE_CONTRACT, [], _), stack -> - fail (Bad_stack (loc, "CREATE_CONTRACT", 7, stack)) - | Prim (loc, "CREATE_ACCOUNT", [], _), + fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) + | Prim (loc, I_CREATE_ACCOUNT, [], _), stack -> - fail (Bad_stack (loc, "CREATE_ACCOUNT", 4, stack)) - | Prim (loc, "TRANSFER_TOKENS", [], _), + fail (Bad_stack (loc, I_CREATE_ACCOUNT, 4, stack)) + | Prim (loc, I_TRANSFER_TOKENS, [], _), stack -> - fail (Bad_stack (loc, "TRANSFER_TOKENS", 3, stack)) - | Prim (loc, ("DROP" | "DUP" | "CAR" | "CDR" | "SOME" | "H" | "DIP" - | "IF_NONE" | "LEFT" | "RIGHT" | "IF_LEFT" | "IF" - | "LOOP" | "IF_CONS" | "MANAGER" | "DEFAULT_ACCOUNT" - | "NEG" | "ABS" | "INT" | "NOT" - | "EQ" | "NEQ" | "LT" | "GT" | "LE" | "GE" as name), _, _), + fail (Bad_stack (loc, I_TRANSFER_TOKENS, 3, stack)) + | Prim (loc, (I_DROP | I_DUP | I_CAR | I_CDR | I_SOME | I_H | I_DIP + | I_IF_NONE | I_LEFT | I_RIGHT | I_IF_LEFT | I_IF + | I_LOOP | I_IF_CONS | I_MANAGER | I_DEFAULT_ACCOUNT + | I_NEG | I_ABS | I_INT | I_NOT + | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE as name), _, _), stack -> fail (Bad_stack (loc, name, 1, stack)) - | Prim (loc, ("SWAP" | "PAIR" | "CONS" - | "MAP" | "GET" | "MEM" | "EXEC" - | "CHECK_SIGNATURE" | "ADD" | "SUB" | "MUL" - | "EDIV" | "AND" | "OR" | "XOR" - | "LSL" | "LSR" | "CONCAT" as name), _, _), + | Prim (loc, (I_SWAP | I_PAIR | I_CONS + | I_MAP | I_GET | I_MEM | I_EXEC + | I_CHECK_SIGNATURE | I_ADD | I_SUB | I_MUL + | I_EDIV | I_AND | I_OR | I_XOR + | I_LSL | I_LSR | I_CONCAT as name), _, _), stack -> fail (Bad_stack (loc, name, 2, stack)) (* Generic parsing errors *) | expr, _ -> fail @@ unexpected expr [ Seq_kind ] Instr_namespace - [ "DROP" ; "DUP" ; "SWAP" ; "SOME" ; "UNIT" ; - "PAIR" ; "CAR" ; "CDR" ; "CONS" ; - "MEM" ; "UPDATE" ; "MAP" ; "REDUCE" ; - "GET" ; "EXEC" ; "FAIL" ; "SIZE" ; - "CONCAT" ; "ADD" ; "SUB" ; - "MUL" ; "EDIV" ; "OR" ; "AND" ; "XOR" ; - "NOT" ; - "ABS" ; "INT"; "NEG" ; "LSL" ; "LSR" ; - "COMPARE" ; "EQ" ; "NEQ" ; - "LT" ; "GT" ; "LE" ; "GE" ; - "MANAGER" ; "TRANSFER_TOKENS" ; "CREATE_ACCOUNT" ; - "CREATE_CONTRACT" ; "NOW" ; "AMOUNT" ; "BALANCE" ; - "DEFAULT_ACCOUNT" ; "CHECK_SIGNATURE" ; "H" ; "HASH_KEY" ; - "STEPS_TO_QUOTA" ; - "PUSH" ; "NONE" ; "LEFT" ; "RIGHT" ; "NIL" ; - "EMPTY_SET" ; "DIP" ; "LOOP" ; - "IF_NONE" ; "IF_LEFT" ; "IF_CONS" ; - "EMPTY_MAP" ; "IF" ; "SOURCE" ; "LAMBDA" ] + [ I_DROP ; I_DUP ; I_SWAP ; I_SOME ; I_UNIT ; + I_PAIR ; I_CAR ; I_CDR ; I_CONS ; + I_MEM ; I_UPDATE ; I_MAP ; I_REDUCE ; + I_GET ; I_EXEC ; I_FAIL ; I_SIZE ; + I_CONCAT ; I_ADD ; I_SUB ; + I_MUL ; I_EDIV ; I_OR ; I_AND ; I_XOR ; + I_NOT ; + I_ABS ; I_INT; I_NEG ; I_LSL ; I_LSR ; + I_COMPARE ; I_EQ ; I_NEQ ; + I_LT ; I_GT ; I_LE ; I_GE ; + I_MANAGER ; I_TRANSFER_TOKENS ; I_CREATE_ACCOUNT ; + I_CREATE_CONTRACT ; I_NOW ; I_AMOUNT ; I_BALANCE ; + I_DEFAULT_ACCOUNT ; I_CHECK_SIGNATURE ; I_H ; I_HASH_KEY ; + I_STEPS_TO_QUOTA ; + I_PUSH ; I_NONE ; I_LEFT ; I_RIGHT ; I_NIL ; + I_EMPTY_SET ; I_DIP ; I_LOOP ; + I_IF_NONE ; I_IF_LEFT ; I_IF_CONS ; + I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_LAMBDA ] and parse_contract : type arg ret. context -> arg ty -> ret ty -> Script.location -> Contract.t -> @@ -1446,9 +1528,10 @@ and parse_contract let contract : (arg, ret) typed_contract = (arg, ret, contract) in ok contract) - | Some { code = { arg_type; ret_type} } -> + | Some { code } -> Lwt.return - (parse_ty arg_type >>? fun (Ex_ty targ) -> + (parse_toplevel code >>? fun (arg_type, ret_type, _, _) -> + parse_ty arg_type >>? fun (Ex_ty targ) -> parse_ty ret_type >>? fun (Ex_ty tret) -> ty_eq targ arg >>? fun (Eq _) -> ty_eq tret ret >>? fun (Eq _) -> @@ -1456,139 +1539,103 @@ and parse_contract (arg, ret, contract) in ok contract) +and parse_toplevel + : Script.expr -> (Script.node * Script.node * Script.node * Script.node) tzresult + = fun toplevel -> match root toplevel with + | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind)) + | String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind)) + | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [ Seq_kind ], Prim_kind)) + | Seq (_, fields, _) -> + let rec find_fields p r s c fields = + match fields with + | [] -> ok (p, r, s, c) + | Int (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Int_kind)) + | String (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], String_kind)) + | Seq (loc, _, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind)) + | Prim (loc, K_parameter, [ arg ], _) :: rest -> + begin match p with + | None -> find_fields (Some arg) r s c rest + | Some _ -> error (Duplicate_field (loc, K_parameter)) + end + | Prim (loc, K_return, [ arg ], _) :: rest -> + begin match r with + | None -> find_fields p (Some arg) s c rest + | Some _ -> error (Duplicate_field (loc, K_return)) + end + | Prim (loc, K_storage, [ arg ], _) :: rest -> + begin match s with + | None -> find_fields p r (Some arg) c rest + | Some _ -> error (Duplicate_field (loc, K_storage)) + end + | Prim (loc, K_code, [ arg ], _) :: rest -> + begin match c with + | None -> find_fields p r s (Some arg) rest + | Some _ -> error (Duplicate_field (loc, K_code)) + end + | Prim (loc, (K_parameter | K_return | K_storage | K_code as name), args, _) :: _ -> + error (Invalid_arity (loc, name, 1, List.length args)) + | Prim (loc, name, _, _) :: _ -> + let allowed = [ K_parameter ; K_return ; K_storage ; K_code ] in + error (Invalid_primitive (loc, allowed, name)) + in + find_fields None None None None fields >>? function + | (None, _, _, _) -> error (Missing_field K_parameter) + | (Some _, None, _, _) -> error (Missing_field K_return) + | (Some _, Some _, None, _) -> error (Missing_field K_storage) + | (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.storage -> Script.code -> ex_script tzresult Lwt.t - = fun ?type_logger ctxt - { storage; storage_type = init_storage_type } - { code; arg_type; ret_type; storage_type } -> + : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> + context -> Script.t -> ex_script tzresult Lwt.t + = fun ?type_logger ctxt { code ; storage } -> + Lwt.return (parse_toplevel code) >>=? fun (arg_type, ret_type, storage_type, code_field) -> trace - (Ill_formed_type (Some "parameter", arg_type)) + (Ill_formed_type (Some "parameter", code, location arg_type)) (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type) -> trace - (Ill_formed_type (Some "return", ret_type)) + (Ill_formed_type (Some "return", code, location ret_type)) (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type) -> trace - (Ill_formed_type (Some "initial storage", init_storage_type)) - (Lwt.return (parse_ty init_storage_type)) >>=? fun (Ex_ty init_storage_type) -> - trace - (Ill_formed_type (Some "storage", storage_type)) + (Ill_formed_type (Some "storage", code, location storage_type)) (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type) -> let arg_type_full = Pair_t (arg_type, storage_type) in let ret_type_full = Pair_t (ret_type, storage_type) in - Lwt.return (ty_eq init_storage_type storage_type) >>=? fun (Eq _) -> trace (Ill_typed_data (None, storage, storage_type)) - (parse_data ?type_logger ctxt storage_type storage) >>=? fun storage -> + (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun storage -> trace - (Ill_typed_contract (code, arg_type, ret_type, storage_type, [])) - (parse_returning (Toplevel { storage_type }) ctxt ?type_logger arg_type_full ret_type_full code) + (Ill_typed_contract (code, [])) + (parse_returning (Toplevel { storage_type }) ctxt ?type_logger arg_type_full ret_type_full code_field) >>=? fun code -> return (Ex_script { code; arg_type; ret_type; storage; storage_type }) let type_map_enc = let open Data_encoding in list - (tup2 - int31 - (tup2 - (list Script.expr_encoding) - (list Script.expr_encoding))) - -let type_map descr = - let rec instr_type_map - : type bef aft. type_map -> (bef, aft) descr -> type_map - = fun acc { loc ; instr ; bef ; aft } -> - let self acc = - (loc, (unparse_stack bef, unparse_stack aft)) :: acc in - match instr, aft with - | If_none (dbt, dbf), _ -> - let acc = instr_type_map acc dbt in - let acc = instr_type_map acc dbf in - self acc - | If_left (dbt, dbf), _ -> - let acc = instr_type_map acc dbt in - let acc = instr_type_map acc dbf in - self acc - | If_cons (dbt, dbf), _ -> - let acc = instr_type_map acc dbt in - let acc = instr_type_map acc dbf in - self acc - | Seq (dl, dr), _ -> - let acc = instr_type_map acc dl in - let acc = instr_type_map acc dr in - acc - | If (dbt, dbf), _ -> - let acc = instr_type_map acc dbt in - let acc = instr_type_map acc dbf in - self acc - | Loop body, _ -> - let acc = instr_type_map acc body in - self acc - | Dip body, _ -> - let acc = instr_type_map acc body in - self acc - | Lambda (Lam (body, _)), _ -> - let acc = instr_type_map acc body in - self acc - | Const v, Item_t (ty, _) -> - let acc = data_type_map acc ty v in - self acc - | _, _ -> - self acc - and data_type_map - : type a. type_map -> a ty -> a -> type_map - = fun acc ty v -> - match ty, v with - | Unit_t, _ -> acc - | Int_t, _ -> acc - | Nat_t, _ -> acc - | Signature_t, _ -> acc - | String_t, _ -> acc - | Tez_t, _ -> acc - | Key_t, _ -> acc - | Key_hash_t, _ -> acc - | Timestamp_t, _ -> acc - | Bool_t, _ -> acc - | Contract_t _,_ -> acc - | Set_t _, _ -> acc - | Pair_t (lty, rty), (l, r) -> - let acc = data_type_map acc lty l in - let acc = data_type_map acc rty r in - acc - | Union_t (lty, _), L l -> - data_type_map acc lty l - | Union_t (_, rty), R r -> - data_type_map acc rty r - | Lambda_t _, Lam (body, _) -> - instr_type_map acc body - | Option_t _, None -> acc - | Option_t ty, Some v -> - data_type_map acc ty v - | List_t ty, l -> - List.fold_left - (fun acc v -> data_type_map acc ty v) - acc l - | Map_t (_, ty), m -> - map_fold - (fun _ v acc -> data_type_map acc ty v) - m acc in - instr_type_map [] descr + (conv + (fun (loc, (bef, aft)) -> (loc, bef, aft)) + (fun (loc, bef, aft) -> (loc, (bef, aft))) + (obj3 + (req "location" Script.location_encoding) + (req "stackBefore" (list Script.expr_encoding)) + (req "stackAfter" (list Script.expr_encoding)))) let typecheck_code - : context -> Script.code -> type_map tzresult Lwt.t - = fun ctxt { code; arg_type; ret_type; storage_type } -> - let failure_type_map = ref [] in + : context -> Script.expr -> type_map tzresult Lwt.t + = fun ctxt code -> + Lwt.return (parse_toplevel code) >>=? fun (arg_type, ret_type, storage_type, code_field) -> + let type_map = ref [] in trace - (Ill_formed_type (Some "parameter", arg_type)) + (Ill_formed_type (Some "parameter", code, location arg_type)) (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type) -> trace - (Ill_formed_type (Some "return", ret_type)) + (Ill_formed_type (Some "return", code, location ret_type)) (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type) -> trace - (Ill_formed_type (Some "storage", storage_type)) + (Ill_formed_type (Some "storage", code, location storage_type)) (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type) -> let arg_type_full = Pair_t (arg_type, storage_type) in let ret_type_full = Pair_t (ret_type, storage_type) in @@ -1596,32 +1643,32 @@ let typecheck_code parse_returning (Toplevel { storage_type }) ctxt - ~type_logger:(fun x -> failure_type_map := x :: !failure_type_map) - arg_type_full ret_type_full code in + ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) + arg_type_full ret_type_full code_field in trace - (Ill_typed_contract (code, arg_type, ret_type, storage_type, !failure_type_map)) - result >>=? fun (Lam (descr,_)) -> - return (type_map descr) + (Ill_typed_contract (code, !type_map)) + result >>=? fun (Lam _) -> + return !type_map let typecheck_data - : ?type_logger: (int * (Script.expr list * Script.expr list) -> unit) -> + : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> context -> Script.expr * Script.expr -> unit tzresult Lwt.t = fun ?type_logger ctxt (data, exp_ty) -> trace - (Ill_formed_type (None, exp_ty)) - (Lwt.return (parse_ty exp_ty)) >>=? fun (Ex_ty exp_ty) -> + (Ill_formed_type (None, exp_ty, 0)) + (Lwt.return (parse_ty (root exp_ty))) >>=? fun (Ex_ty exp_ty) -> trace (Ill_typed_data (None, data, exp_ty)) - (parse_data ?type_logger ctxt exp_ty data) >>=? fun _ -> + (parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun _ -> return () (* ---- Error registration --------------------------------------------------*) let ex_ty_enc = Data_encoding.conv - (fun (Ex_ty ty) -> unparse_ty ty) + (fun (Ex_ty ty) -> strip_locations (unparse_ty ty)) (fun expr -> - match parse_ty expr with + match parse_ty (root expr) with | Ok (Ex_ty ty) -> Ex_ty ty | _ -> Ex_ty Unit_t (* FIXME: ? *)) Script.expr_encoding @@ -1675,7 +1722,7 @@ let () = "In a script or data expression, a primitive was applied \ to an unsupported number of arguments." (located (obj3 - (req "primitiveName" string) + (req "primitiveName" Script.prim_encoding) (req "expectedArity" arity_enc) (req "wrongArity" arity_enc))) (function @@ -1684,6 +1731,15 @@ let () = | _ -> None) (fun (loc, (name, exp, got)) -> Invalid_arity (loc, name, exp, got)) ; + register_error_kind + `Permanent + ~id:"missingScriptField" + ~title:"Script is missing a field (parse error)" + ~description: + "When parsing script, a field was expected, but not provided" + (obj1 (req "prim" prim_encoding)) + (function Missing_field prim -> Some prim | _ -> None) + (fun prim -> Missing_field prim) ; register_error_kind `Permanent ~id:"invalidPrimitiveTypeError" @@ -1691,26 +1747,13 @@ let () = ~description: "In a script or data expression, a primitive was unknown." (located (obj2 - (dft "expectedPrimitiveNames" (list string) []) - (req "wrongPrimitiveName" string))) + (dft "expectedPrimitiveNames" (list prim_encoding) []) + (req "wrongPrimitiveName" prim_encoding))) (function | Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None) (fun (loc, (exp, got)) -> Invalid_primitive (loc, exp, got)) ; - register_error_kind - `Permanent - ~id:"invalidPrimitiveNameCaseTypeError" - ~title: "Invalid primitive name case (typechecking error)" - ~description: - "In a script or data expression, a primitive name is \ - neither uppercase, lowercase or capitalized." - (located (obj1 (req "wrongPrimitiveName" string))) - (function - | Invalid_case (loc, name) -> Some (loc, name) - | _ -> None) - (fun (loc, name) -> - Invalid_case (loc, name)) ; register_error_kind `Permanent ~id:"invalidExpressionKindTypeError" @@ -1733,7 +1776,7 @@ let () = ~description: "In a script or data expression, a primitive was of the wrong namespace." (located (obj3 - (req "primitiveName" string) + (req "primitiveName" prim_encoding) (req "expectedNamespace" namespace_enc) (req "wrongNamespace" namespace_enc))) (function @@ -1811,7 +1854,7 @@ let () = "A binary operation is called on operands of types \ over which it is not defined." (located (obj3 - (req "operatorName" string) + (req "operatorName" prim_encoding) (req "wrongLeftOperandType" ex_ty_enc) (req "wrongRightOperandType" ex_ty_enc))) (function @@ -1828,7 +1871,7 @@ let () = "A unary operation is called on an operand of type \ over which it is not defined." (located (obj2 - (req "operatorName" string) + (req "operatorName" prim_encoding) (req "wrongOperandType" ex_ty_enc))) (function | Undefined_unop (loc, n, ty) -> @@ -1857,7 +1900,7 @@ let () = ~description: "The stack has an unexpected length or contents." (located (obj3 - (req "primitiveName" string) + (req "primitiveName" prim_encoding) (req "relevantStackPortion" int16) (req "wrongStackType" ex_stack_ty_enc))) (function @@ -2007,14 +2050,15 @@ let () = ~description: "The toplevel error thrown when trying to parse a type expression \ (always followed by more precise errors)." - (obj2 + (obj3 (opt "identifier" string) - (req "illFormedExpression" Script.expr_encoding)) + (req "illFormedExpression" Script.expr_encoding) + (req "location" Script.location_encoding)) (function - | Ill_formed_type (name, expr) -> Some (name, expr) + | Ill_formed_type (name, expr, loc) -> Some (name, expr, loc) | _ -> None) - (fun (name, expr) -> - Ill_formed_type (name, expr)) ; + (fun (name, expr, loc) -> + Ill_formed_type (name, expr, loc)) ; register_error_kind `Permanent ~id:"illTypedContractTypeError" @@ -2023,15 +2067,12 @@ let () = "The toplevel error thrown when trying to typecheck \ a contract code against given input, output and storage types \ (always followed by more precise errors)." - (obj5 - (req "expectedParameterType" ex_ty_enc) - (req "expectedReturnType" ex_ty_enc) - (req "expectedStorageType" ex_ty_enc) - (req "illTypedExpression" Script.expr_encoding) + (obj2 + (req "illTypedCode" Script.expr_encoding) (req "typeMap" type_map_enc)) (function - | Ill_typed_contract (expr, arg_ty, ret_ty, storage_ty, type_map) -> - Some (Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty, expr, type_map) + | Ill_typed_contract (expr, type_map) -> + Some (expr, type_map) | _ -> None) - (fun (Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty, expr, type_map) -> - Ill_typed_contract (expr, arg_ty, ret_ty, storage_ty, type_map)) + (fun (expr, type_map) -> + Ill_typed_contract (expr, type_map)) diff --git a/src/proto/alpha/script_ir_translator.mli b/src/proto/alpha/script_ir_translator.mli index b9f2a3d57..381604370 100644 --- a/src/proto/alpha/script_ir_translator.mli +++ b/src/proto/alpha/script_ir_translator.mli @@ -19,23 +19,25 @@ type ex_script = Ex_script : ('a, 'b, 'c) Script_typed_ir.script -> ex_script (* ---- Error definitions ---------------------------------------------------*) (* Auxiliary types for error documentation *) -type namespace = Type_namespace | Constant_namespace | Instr_namespace -type kind = Int_kind | String_kind | Prim_kind | Seq_kind +type namespace = + Type_namespace | Constant_namespace | Instr_namespace | Keyword_namespace +type kind = + Int_kind | String_kind | Prim_kind | Seq_kind type type_map = (int * (Script.expr list * Script.expr list)) list (* Structure errors *) -type error += Invalid_arity of Script.location * string * int * int -type error += Invalid_namespace of Script.location * string * namespace * namespace -type error += Invalid_primitive of Script.location * string list * string -type error += Invalid_case of Script.location * string +type error += Invalid_arity of Script.location * Script.prim * int * int +type error += Invalid_namespace of Script.location * Script.prim * namespace * namespace +type error += Invalid_primitive of Script.location * Script.prim list * Script.prim type error += Invalid_kind of Script.location * kind list * kind +type error += Missing_field of Script.prim (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location -type error += Undefined_binop : Script.location * string * _ Script_typed_ir.ty * _ Script_typed_ir.ty -> error -type error += Undefined_unop : Script.location * string * _ Script_typed_ir.ty -> error +type error += Undefined_binop : Script.location * Script.prim * _ Script_typed_ir.ty * _ Script_typed_ir.ty -> error +type error += Undefined_unop : Script.location * Script.prim * _ Script_typed_ir.ty -> error type error += Bad_return : Script.location * _ Script_typed_ir.stack_ty * _ Script_typed_ir.ty -> error -type error += Bad_stack : Script.location * string * int * _ Script_typed_ir.stack_ty -> error +type error += Bad_stack : Script.location * Script.prim * int * _ Script_typed_ir.stack_ty -> error type error += Unmatched_branches : Script.location * _ Script_typed_ir.stack_ty * _ Script_typed_ir.stack_ty -> error type error += Transfer_in_lambda of Script.location type error += Transfer_in_dip of Script.location @@ -54,8 +56,8 @@ type error += Duplicate_set_values of Script.location * Script.expr (* Toplevel errors *) type error += Ill_typed_data : string option * Script.expr * _ Script_typed_ir.ty -> error -type error += Ill_formed_type of string option * Script.expr -type error += Ill_typed_contract : Script.expr * _ Script_typed_ir.ty * _ Script_typed_ir.ty * _ Script_typed_ir.ty * type_map -> error +type error += Ill_formed_type of string option * Script.expr * Script.location +type error += Ill_typed_contract : Script.expr * type_map -> error (* ---- Sets and Maps -------------------------------------------------------*) @@ -83,26 +85,29 @@ val ty_eq : ('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq tzresult val parse_data : - ?type_logger: (int * (Script.expr list * Script.expr list) -> unit) -> - context -> 'a Script_typed_ir.ty -> Script.expr -> 'a tzresult Lwt.t + ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> + context -> 'a Script_typed_ir.ty -> Script.node -> 'a tzresult Lwt.t val unparse_data : - 'a Script_typed_ir.ty -> 'a -> Script.expr + 'a Script_typed_ir.ty -> 'a -> Script.node val parse_ty : - Script.expr -> ex_ty tzresult + Script.node -> ex_ty tzresult val unparse_ty : - 'a Script_typed_ir.ty -> Script.expr + 'a Script_typed_ir.ty -> Script.node val type_map_enc : type_map Data_encoding.encoding val ex_ty_enc : ex_ty Data_encoding.encoding +val parse_toplevel + : Script.expr -> (Script.node * Script.node * Script.node * Script.node) tzresult + val typecheck_code : - context -> Script.code -> type_map tzresult Lwt.t + context -> Script.expr -> type_map tzresult Lwt.t val typecheck_data : - ?type_logger: (int * (Script.expr list * Script.expr list) -> unit) -> + ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> context -> Script.expr * Script.expr -> unit tzresult Lwt.t val parse_script : - ?type_logger: (int * (Script.expr list * Script.expr list) -> unit) -> - context -> Script.storage -> Script.code -> ex_script tzresult Lwt.t + ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> + context -> Script.t -> ex_script tzresult Lwt.t diff --git a/src/proto/alpha/script_repr.ml b/src/proto/alpha/script_repr.ml index 88d65db85..9320f6b53 100644 --- a/src/proto/alpha/script_repr.ml +++ b/src/proto/alpha/script_repr.ml @@ -9,142 +9,25 @@ open Tezos_hash -(* Tezos protocol "bootstrap" - untyped script representation *) +type location = Micheline.canonical_location -type location = int +let location_encoding = Micheline.canonical_location_encoding -let location_encoding = - let open Data_encoding in - def - "scriptLocation" @@ - describe - ~title: - "Script location" - ~description: - "The location of a node in a script (code, data or type) \ - as its index in the expression tree in prefix order, with \ - zero being the root and adding one for every basic node, \ - sequence and primitive application." @@ - int31 +type expr = Michelson_v1_primitives.prim Micheline.canonical -type expr = (* TODO: turn the location into an alpha ? *) - | Int of location * string - | String of location * string - | Prim of location * string * expr list * string option - | Seq of location * expr list * string option +type node = (location, Michelson_v1_primitives.prim) Micheline.node -let expr_encoding = - let open Data_encoding in - let int_encoding = - obj1 (req "int" string) in - let string_encoding = - obj1 (req "string" string) in - let prim_encoding expr_encoding = - let json = - union - [ case string - (function (v, [], None) -> Some v | _ -> None) - (fun v -> (v, [], None)) ; - case (assoc (tup2 (list expr_encoding) (option string))) - (fun (v, args, annot) -> Some [ (v, (args, annot)) ]) - (function - | [ (v, (args, annot)) ] -> (v, args, annot) - | _ -> Json.cannot_destruct "invalid script expression") ] in - let binary = - obj3 (req "prim" string) (req "args" (list expr_encoding)) (opt "annot" string) in - splitted ~json ~binary in - let seq_encoding expr_encoding = - list expr_encoding in - mu "tezosScriptExpression" (fun expr_encoding -> - describe - ~title: "Script expression (data, type or code)" @@ - union ~tag_size:`Uint8 - [ case ~tag:0 int_encoding - (function Int (_, v) -> Some v | _ -> None) - (fun v -> Int (-1, v)) ; - case ~tag:1 string_encoding - (function String (_, v) -> Some v | _ -> None) - (fun v -> String (-1, v)) ; - case ~tag:2 (prim_encoding expr_encoding) - (function - | Prim (_, v, args, annot) -> Some (v, args, annot) - | _ -> None) - (function (prim, args, annot) -> Prim (-1, prim, args, annot)) ; - case ~tag:3 (seq_encoding expr_encoding) - (function Seq (_, v, _annot) -> Some v | _ -> None) - (fun args -> Seq (-1, args, None)) ]) - -let update_locations ir = - let rec update_locations i = function - | Int (_, v) -> (Int (i, v), succ i) - | String (_, v) -> (String (i, v), succ i) - | Prim (_, name, args, annot) -> - let (nargs, ni) = - List.fold_left (fun (nargs, ni) arg -> - let narg, ni = update_locations ni arg in - (narg :: nargs, ni)) - ([], succ i) args in - (Prim (i, name, List.rev nargs, annot), ni) - | Seq (_, args, annot) -> - let (nargs, ni) = - List.fold_left (fun (nargs, ni) arg -> - let narg, ni = update_locations ni arg in - (narg :: nargs, ni)) - ([], succ i) args in - (Seq (i, List.rev nargs, annot), ni) in - fst (update_locations 1 ir) - -let expr_encoding = - Data_encoding.conv - (fun to_write -> to_write) - (fun just_read -> update_locations just_read) - expr_encoding - -type code = - { code : expr ; - arg_type : expr ; - ret_type : expr ; - storage_type : expr } - -type storage = - { storage : expr ; - storage_type : expr } - -open Data_encoding - -let storage_encoding = - conv - (fun { storage ; storage_type } -> (storage, storage_type)) - (fun (storage, storage_type) -> { storage ; storage_type }) - (obj2 - (req "storage" expr_encoding) - (req "storageType" expr_encoding)) - -let code_encoding = - conv - (fun { code; arg_type; ret_type; storage_type } -> - (code, arg_type, ret_type, storage_type)) - (fun (code, arg_type, ret_type, storage_type) -> - { code; arg_type; ret_type; storage_type }) - (obj4 - (req "code" expr_encoding) - (req "argType" expr_encoding) - (req "retType" expr_encoding) - (req "storageType" expr_encoding)) +let expr_encoding = Micheline.canonical_encoding Michelson_v1_primitives.prim_encoding let hash_expr data = let bytes = Data_encoding.Binary.to_bytes expr_encoding data in Script_expr_hash.(hash_bytes [ bytes ] |> to_b58check) -type t = - { code : code ; - storage : storage } +type t = { code : expr ; storage : expr } let encoding = let open Data_encoding in conv - (function { code ; storage } -> (code, storage)) + (fun { code ; storage } -> (code, storage)) (fun (code, storage) -> { code ; storage }) - (obj2 - (req "code" code_encoding) - (req "storage" storage_encoding)) + (obj2 (req "code" expr_encoding) (req "storage" expr_encoding)) diff --git a/src/proto/alpha/script_repr.mli b/src/proto/alpha/script_repr.mli index 6060b7792..960e3ee8b 100644 --- a/src/proto/alpha/script_repr.mli +++ b/src/proto/alpha/script_repr.mli @@ -7,44 +7,18 @@ (* *) (**************************************************************************) -(* A smart contract is some code and some storage. The storage has a - type and an initial value. The code is the code itself, the types of - its arguments, the type of its result, and the type of the storage - it is using. +type location = Micheline.canonical_location - All of them are expressed in a simple [expr] type, combining - [Int] (integer constant), [String] (string constant), [Prim] - (a generic primitive for most operations) and [Seq] a sequence - of operations. - *) +type expr = Michelson_v1_primitives.prim Micheline.canonical -type location = - int - -type expr = - | Int of location * string - | String of location * string - | Prim of location * string * expr list * string option - | Seq of location * expr list * string option - -type code = - { code : expr ; - arg_type : expr ; - ret_type : expr ; - storage_type : expr } - -type storage = - { storage : expr ; - storage_type : expr } - -type t = - { code : code ; - storage : storage } +type node = (location, Michelson_v1_primitives.prim) Micheline.node val location_encoding : location Data_encoding.t + val expr_encoding : expr Data_encoding.t -val storage_encoding : storage Data_encoding.t -val code_encoding : code Data_encoding.t -val encoding : t Data_encoding.t val hash_expr : expr -> string + +type t = { code : expr ; storage : expr } + +val encoding : t Data_encoding.encoding diff --git a/src/proto/alpha/services.ml b/src/proto/alpha/services.ml index 625fedf73..6573016eb 100644 --- a/src/proto/alpha/services.ml +++ b/src/proto/alpha/services.ml @@ -305,7 +305,7 @@ module Context = struct RPC.service ~description: "Access the data of the contract." ~input: empty - ~output: (wrap_tzerror (option Script.storage_encoding)) + ~output: (wrap_tzerror (option Script.expr_encoding)) RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "storage") type info = { @@ -365,7 +365,7 @@ module Helpers = struct let run_code_input_encoding = (obj6 - (req "script" Script.code_encoding) + (req "script" Script.expr_encoding) (req "storage" Script.expr_encoding) (req "input" Script.expr_encoding) (req "amount" Tez.encoding) @@ -414,7 +414,7 @@ module Helpers = struct let typecheck_code custom_root = RPC.service ~description: "Typecheck a piece of code in the current context" - ~input: Script.code_encoding + ~input: Script.expr_encoding ~output: (wrap_tzerror Script_ir_translator.type_map_enc) RPC.Path.(custom_root / "helpers" / "typecheck_code") diff --git a/src/proto/alpha/services_registration.ml b/src/proto/alpha/services_registration.ml index d2f15b937..de84448f6 100644 --- a/src/proto/alpha/services_registration.ml +++ b/src/proto/alpha/services_registration.ml @@ -265,8 +265,6 @@ let () = | None -> Contract.default_contract (List.hd (Bootstrap.accounts ctxt)).Bootstrap.public_key_hash in - let storage : Script.storage = - { storage ; storage_type = (script : Script.code).storage_type } in let qta = Constants.instructions_per_transaction ctxt in let origination_nonce = @@ -278,24 +276,24 @@ let () = (script, storage, input, amount, contract, qta, origination_nonce) in register1 Services.Helpers.run_code (fun ctxt parameters -> - let (script, storage, input, amount, contract, qta, origination_nonce) = + let (code, storage, input, amount, contract, qta, origination_nonce) = run_parameters ctxt parameters in Script_interpreter.execute origination_nonce contract (* transaction initiator *) contract (* script owner *) - ctxt storage script amount input + ctxt { storage ; code } amount input qta >>=? fun (sto, ret, _qta, _ctxt, _) -> Error_monad.return (sto, ret)) ; register1 Services.Helpers.trace_code (fun ctxt parameters -> - let (script, storage, input, amount, contract, qta, origination_nonce) = + let (code, storage, input, amount, contract, qta, origination_nonce) = run_parameters ctxt parameters in Script_interpreter.trace origination_nonce contract (* transaction initiator *) contract (* script owner *) - ctxt storage script amount input + ctxt { storage ; code } amount input qta >>=? fun ((sto, ret, _qta, _ctxt, _), trace) -> Error_monad.return (sto, ret, trace)) diff --git a/src/proto/alpha/storage.ml b/src/proto/alpha/storage.ml index befdbea43..ba24c4687 100644 --- a/src/proto/alpha/storage.ml +++ b/src/proto/alpha/storage.ml @@ -340,19 +340,19 @@ module Contract = struct module Code = Make_indexed_data_storage(struct type key = Contract_repr.t - type value = Script_repr.code + type value = Script_repr.expr let name = "contract code" let key = Key.Contract.code - let encoding = Script_repr.code_encoding + let encoding = Script_repr.expr_encoding end) module Storage = Make_indexed_data_storage(struct type key = Contract_repr.t - type value = Script_repr.storage + type value = Script_repr.expr let name = "contract storage" let key = Key.Contract.storage - let encoding = Script_repr.storage_encoding + let encoding = Script_repr.expr_encoding end) module Code_fees = diff --git a/src/proto/alpha/storage.mli b/src/proto/alpha/storage.mli index 45ae2110e..ee4b5f243 100644 --- a/src/proto/alpha/storage.mli +++ b/src/proto/alpha/storage.mli @@ -162,12 +162,12 @@ module Contract : sig module Code : Indexed_data_storage with type key = Contract_repr.t - and type value = Script_repr.code + and type value = Script_repr.expr and type context := t module Storage : Indexed_data_storage with type key = Contract_repr.t - and type value = Script_repr.storage + and type value = Script_repr.expr and type context := t module Code_fees : Indexed_data_storage diff --git a/src/proto/alpha/tezos_context.ml b/src/proto/alpha/tezos_context.ml index 586922cfa..f5cadad59 100644 --- a/src/proto/alpha/tezos_context.ml +++ b/src/proto/alpha/tezos_context.ml @@ -45,8 +45,10 @@ module Script_timestamp = struct |> Timestamp.to_seconds |> of_int64 end -module Script = Script_repr - +module Script = struct + include Michelson_v1_primitives + include Script_repr +end type public_key = Ed25519.Public_key.t type public_key_hash = Ed25519.Public_key_hash.t type secret_key = Ed25519.Secret_key.t diff --git a/src/proto/alpha/tezos_context.mli b/src/proto/alpha/tezos_context.mli index 6bc478245..28f575da2 100644 --- a/src/proto/alpha/tezos_context.mli +++ b/src/proto/alpha/tezos_context.mli @@ -125,34 +125,120 @@ end module Script : sig - type location = int + type prim = Michelson_v1_primitives.prim = + | K_parameter + | K_return + | K_storage + | K_code + | D_False + | D_Item + | D_Left + | D_List + | D_Map + | D_None + | D_Pair + | D_Right + | D_Set + | D_Some + | D_True + | D_Unit + | I_H + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_DEFAULT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAIL + | I_GE + | I_GET + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MANAGER + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_PUSH + | I_REDUCE + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_UNIT + | I_UPDATE + | I_XOR + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_tez + | T_timestamp + | T_unit - type expr = - | Int of location * string - | String of location * string - | Prim of location * string * expr list * string option - | Seq of location * expr list * string option + type location = Micheline.canonical_location - type code = { - code: expr ; - arg_type: expr ; - ret_type: expr ; - storage_type: expr ; - } + type expr = prim Micheline.canonical - type storage = { - storage: expr ; - storage_type: expr ; - } + type node = (location, prim) Micheline.node type t = - { code : code ; - storage : storage } + { code : expr ; + storage : expr } val location_encoding: location Data_encoding.t val expr_encoding: expr Data_encoding.t - val storage_encoding: storage Data_encoding.t - val code_encoding: code Data_encoding.t + val prim_encoding: prim Data_encoding.t val encoding: t Data_encoding.t val hash_expr : expr -> string @@ -345,7 +431,7 @@ module Contract : sig val get_script: context -> contract -> (Script.t option) tzresult Lwt.t val get_storage: - context -> contract -> (Script.storage option) tzresult Lwt.t + context -> contract -> (Script.expr option) tzresult Lwt.t val get_counter: context -> contract -> int32 tzresult Lwt.t val get_balance: