diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml index 83687f9a9..83343e203 100644 --- a/src/lib_error_monad/error_monad.ml +++ b/src/lib_error_monad/error_monad.ml @@ -13,10 +13,7 @@ type error_category = [ `Branch | `Temporary | `Permanent ] -type 'err full_error_category = - [ error_category | `Wrapped of 'err -> error_category ] - -(* HACK: forward reference from [Data_encoding_ezjsonm] *) +(* hack: forward reference from [Data_encoding_ezjsonm] *) let json_to_string = ref (fun _ -> "") let json_pp id encoding ppf x = @@ -26,77 +23,202 @@ let json_pp id encoding ppf x = Data_encoding.(merge_objs (obj1 (req "id" string)) encoding) in Data_encoding.Json.construct encoding (id, x) -module Make() = struct +let set_error_encoding_cache_dirty = ref (fun () -> ()) + +module Make(Prefix : sig val id : string end) = struct type error = .. + module type Wrapped_error_monad = sig + type unwrapped = .. + include Error_monad_sig.S with type error := unwrapped + val unwrap : error -> unwrapped option + val wrap : unwrapped -> error + end + + type full_error_category = + | Main of error_category + | Wrapped of (module Wrapped_error_monad) + (* the toplevel store for error kinds *) type error_kind = Error_kind : { id: string ; + title: string ; + description: string ; from_error: error -> 'err option ; - category: 'err full_error_category ; + category: full_error_category ; encoding_case: error Data_encoding.case ; pp: Format.formatter -> 'err -> unit ; } -> error_kind + type error_info = + { category : error_category ; + id: string ; + title : string ; + description : string ; + schema : Data_encoding.json_schema } + let error_kinds : error_kind list ref = ref [] + let get_registered_errors () : error_info list = + List.flatten + (List.map + (function + | Error_kind { id = "" ; _ } -> [] + | Error_kind { id ; title ; description ; category = Main category ; encoding_case ; _ } -> + [ { id ; title ; description ; category ; + schema = Data_encoding.Json.schema (Data_encoding.union [ encoding_case ]) } ] + | Error_kind { category = Wrapped (module WEM) ; _ } -> + List.map + (fun { WEM.id ; title ; description ; category ; schema } -> + { id ; title ; description ; category ; schema }) + (WEM.get_registered_errors ())) + !error_kinds) + let error_encoding_cache = ref None + let () = + let cont = !set_error_encoding_cache_dirty in + set_error_encoding_cache_dirty := fun () -> + cont () ; + error_encoding_cache := None let string_of_category = function | `Permanent -> "permanent" | `Temporary -> "temporary" | `Branch -> "branch" - | `Wrapped _ -> "wrapped" + + let pp_info + ppf + { category; id; title; description; schema } = + Format.fprintf + ppf + "@[category : %s\nid : %s\ntitle : %s\ndescription : %s\nschema : %a@]" + (string_of_category category) + id title description + (Json_repr.pp (module Json_repr.Ezjsonm)) + (Json_schema.to_json schema) + + (* Catch all error when 'serializing' an error. *) + type error += Unclassified of string + + let () = + let id = "" in + let category = Main `Temporary in + let to_error msg = Unclassified msg in + let from_error = function + | Unclassified msg -> Some msg + | error -> + let msg = Obj.(extension_name @@ extension_constructor error) in + Some ("Unclassified error: " ^ msg ^ ". Was the error registered?") in + let title = "Generic error" in + let description = "An unclassified error" in + let encoding_case = + let open Data_encoding in + case Json_only + (describe ~title ~description @@ + conv (fun x -> ((), x)) (fun ((), x) -> x) @@ + (obj2 + (req "kind" (constant "generic")) + (req "error" string))) + from_error to_error in + let pp = Format.pp_print_string in + error_kinds := + Error_kind { id ; title ; description ; + from_error ; category ; encoding_case ; pp } :: !error_kinds + + (* Catch all error when 'deserializing' an error. *) + type error += Unregistred_error of Data_encoding.json + + let () = + let id = "" in + let category = Main `Temporary in + let to_error msg = Unregistred_error msg in + let from_error = function + | Unregistred_error json -> Some json + | _ -> None in + let encoding_case = + let open Data_encoding in + case Json_only json from_error to_error in + let pp ppf json = + Format.fprintf ppf "@[Unregistred error:@ %a@]" + Data_encoding.Json.pp json in + error_kinds := + Error_kind { id ; title = "" ; description = "" ; + from_error ; category ; encoding_case ; pp } :: !error_kinds + let raw_register_error_kind category ~id:name ~title ~description ?pp encoding from_error to_error = + let name = Prefix.id ^ name in if List.exists (fun (Error_kind { id ; _ }) -> name = id) !error_kinds then invalid_arg (Printf.sprintf "register_error_kind: duplicate error name: %s" name) ; - if not (Data_encoding.is_obj encoding) - then invalid_arg - (Printf.sprintf - "Specified encoding for \"%s\" is not an object, but error encodings must be objects." - name) ; let encoding_case = let open Data_encoding in - case Json_only - (describe ~title ~description @@ - conv (fun x -> (((), ()), x)) (fun (((),()), x) -> x) @@ - merge_objs - (obj2 - (req "kind" (constant (string_of_category category))) - (req "id" (constant name))) - encoding) - from_error to_error in - error_encoding_cache := None ; + match category with + | Wrapped (module WEM) -> + let unwrap err = + match WEM.unwrap err with + | Some (WEM.Unclassified _) -> None + | Some (WEM.Unregistred_error _) -> + Format.eprintf "What %s@." name ; + None + | res -> res in + let wrap err = + match err with + | WEM.Unclassified _ -> + failwith "ignore wrapped error when serializing" + | WEM.Unregistred_error _ -> + failwith "ignore wrapped error when deserializing" + | res -> WEM.wrap res in + case Json_only WEM.error_encoding unwrap wrap + | Main category -> + let with_id_and_kind_encoding = + merge_objs + (obj2 + (req "kind" (constant (string_of_category category))) + (req "id" (constant name))) + encoding in + case Json_only + (describe ~title ~description + (conv (fun x -> (((), ()), x)) (fun (((),()), x) -> x) + with_id_and_kind_encoding)) + from_error to_error in + !set_error_encoding_cache_dirty () ; error_kinds := - Error_kind { id = name ; - category ; - from_error ; - encoding_case ; - pp = Option.unopt ~default:(json_pp name encoding) pp } :: !error_kinds + Error_kind + { id = name ; + category ; + title ; + description ; + from_error ; + encoding_case ; + pp = Option.unopt ~default:(json_pp name encoding) pp } + :: !error_kinds let register_wrapped_error_kind - category ~id ~title ~description ?pp - encoding from_error to_error = + (module WEM : Wrapped_error_monad) ~id ~title ~description = raw_register_error_kind - (`Wrapped category) - ~id ~title ~description ?pp - encoding from_error to_error + (Wrapped (module WEM)) + ~id ~title ~description + ~pp:WEM.pp WEM.error_encoding WEM.unwrap WEM.wrap let register_error_kind category ~id ~title ~description ?pp encoding from_error to_error = + if not (Data_encoding.is_obj encoding) + then invalid_arg + (Printf.sprintf + "Specified encoding for \"%s%s\" is not an object, but error encodings must be objects." + Prefix.id id) ; raw_register_error_kind - (category :> _ full_error_category) + (Main category) ~id ~title ~description ?pp encoding from_error to_error @@ -105,7 +227,7 @@ module Make() = struct | None -> let cases = List.map - (fun (Error_kind { encoding_case ; _ }) -> encoding_case ) + (fun (Error_kind { encoding_case ; _ }) -> encoding_case) !error_kinds in let json_encoding = Data_encoding.union cases in let encoding = @@ -134,10 +256,13 @@ module Make() = struct (* assert false (\* See "Generic error" *\) *) | Error_kind { from_error ; category ; _ } :: rest -> match from_error e with - | Some x -> begin + | Some _ -> begin match category with - | `Wrapped f -> f x - | #error_category as x -> x + | Main error_category -> error_category + | Wrapped (module WEM) -> + match WEM.unwrap e with + | Some e -> WEM.classify_errors [ e ] + | None -> find e rest end | None -> find e rest in find error !error_kinds @@ -413,7 +538,6 @@ module Make() = struct (Format.pp_print_list pp) (List.rev errors) - (** Catch all error when 'serializing' an error. *) type error += Unclassified of string @@ -464,7 +588,7 @@ module Make() = struct let () = let id = "" in - let category = `Permanent in + let category = Main `Permanent in let to_error (loc, msg) = Assert_error (loc, msg) in let from_error = function | Assert_error (loc, msg) -> Some (loc, msg) @@ -487,7 +611,8 @@ module Make() = struct loc (if msg = "" then "." else ": " ^ msg) in error_kinds := - Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds + Error_kind { id ; title ; description ; + from_error ; category ; encoding_case ; pp } :: !error_kinds let _assert b loc fmt = if b then @@ -497,7 +622,7 @@ module Make() = struct end -include Make() +include Make(struct let id = "" end) let generic_error fmt = Format.kasprintf (fun s -> error (Unclassified s)) fmt diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index b344504c3..ad7e65201 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -18,6 +18,18 @@ type error_category = include Error_monad_sig.S +module type Wrapped_error_monad = sig + type unwrapped = .. + include Error_monad_sig.S with type error := unwrapped + val unwrap : error -> unwrapped option + val wrap : unwrapped -> error +end + +val register_wrapped_error_kind : + (module Wrapped_error_monad) -> + id:string -> title:string -> description:string -> + unit + (** Erroneous result (shortcut for generic errors) *) val generic_error : ('a, Format.formatter, unit, 'b tzresult) format4 -> @@ -38,8 +50,8 @@ val pp_exn : Format.formatter -> exn -> unit val failure : ('a, Format.formatter, unit, error) format4 -> 'a +(** Wrapped OCaml/Lwt exception *) type error += Exn of exn -type error += Unclassified of string type error += Canceled @@ -53,7 +65,7 @@ val with_timeout: ?canceler:Lwt_canceler.t -> unit Lwt.t -> (Lwt_canceler.t -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t -module Make() : Error_monad_sig.S +module Make(Prefix : sig val id : string end) : Error_monad_sig.S (**/**) val json_to_string : (Data_encoding.json -> string) ref diff --git a/src/lib_error_monad/error_monad_sig.ml b/src/lib_error_monad/error_monad_sig.ml index 420fa03c8..609bbc052 100644 --- a/src/lib_error_monad/error_monad_sig.ml +++ b/src/lib_error_monad/error_monad_sig.ml @@ -18,6 +18,11 @@ module type S = sig type error = .. + (** Catch all error when 'serializing' an error. *) + type error += private Unclassified of string + (** Catch all error when 'deserializing' an error. *) + type error += private Unregistred_error of Data_encoding.json + val pp: Format.formatter -> error -> unit val pp_print_error: Format.formatter -> error list -> unit @@ -26,6 +31,21 @@ module type S = sig val json_of_error : error -> Data_encoding.json val error_of_json : Data_encoding.json -> error + (** {2 Error documentation} ************************************************) + + (** Error information *) + type error_info = + { category : error_category ; + id : string ; + title : string ; + description : string ; + schema : Data_encoding.json_schema } + + val pp_info: Format.formatter -> error_info -> unit + + (** Retrieves information of registered errors *) + val get_registered_errors : unit -> error_info list + (** {2 Error classification} ***********************************************) (** For other modules to register specialized error serializers *) @@ -37,14 +57,6 @@ module type S = sig (error -> 'err option) -> ('err -> error) -> unit - val register_wrapped_error_kind : - ('err -> error_category) -> - id:string -> title:string -> description:string -> - ?pp:(Format.formatter -> 'err -> unit) -> - 'err Data_encoding.t -> - (error -> 'err option) -> ('err -> error) -> - unit - (** Classify an error using the registered kinds *) val classify_errors : error list -> error_category diff --git a/src/lib_protocol_environment/sigs/v1/error_monad.mli b/src/lib_protocol_environment/sigs/v1/error_monad.mli index 7203a517a..40f32f650 100644 --- a/src/lib_protocol_environment/sigs/v1/error_monad.mli +++ b/src/lib_protocol_environment/sigs/v1/error_monad.mli @@ -29,6 +29,19 @@ val error_encoding : error Data_encoding.t val json_of_error : error -> Data_encoding.json val error_of_json : Data_encoding.json -> error +(** Error information *) +type error_info = + { category : error_category ; + id: string ; + title : string ; + description : string ; + schema : Data_encoding.json_schema } + +val pp_info: Format.formatter -> error_info -> unit + +(** Retrieves information of registered errors *) +val get_registered_errors : unit -> error_info list + (** For other modules to register specialized error serializers *) val register_error_kind : error_category -> diff --git a/src/lib_protocol_environment/tezos_protocol_environment.ml b/src/lib_protocol_environment/tezos_protocol_environment.ml index 6b0e4488e..dfae8f796 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.ml +++ b/src/lib_protocol_environment/tezos_protocol_environment.ml @@ -137,7 +137,7 @@ module Make (Context : CONTEXT) = struct and type (+'m,'pr,'p,'q,'i,'o) RPC_service.t = ('m,'pr,'p,'q,'i,'o) RPC_service.t and type Error_monad.shell_error = Error_monad.error - type error += Ecoproto_error of Error_monad.error list + type error += Ecoproto_error of Error_monad.error val wrap_error : 'a Error_monad.tzresult -> 'a tzresult module Lift (P : Updater.PROTOCOL) : PROTOCOL @@ -193,30 +193,31 @@ module Make (Context : CONTEXT) = struct type 'a shell_tzresult = 'a Error_monad.tzresult type shell_error = Error_monad.error = .. type error_category = [ `Branch | `Temporary | `Permanent ] - include Error_monad.Make() + include Error_monad.Make(struct let id = Format.asprintf "proto.%s." Param.name end) end - type error += Ecoproto_error of Error_monad.error list + type error += Ecoproto_error of Error_monad.error + + module Wrapped_error_monad = struct + type unwrapped = Error_monad.error = .. + include (Error_monad : Error_monad_sig.S with type error := unwrapped) + let unwrap = function + | Ecoproto_error ecoerror -> Some ecoerror + | _ -> None + let wrap ecoerror = + Ecoproto_error ecoerror + end let () = - let id = Format.asprintf "Ecoproto.%s" Param.name in + let id = Format.asprintf "proto.%s.wrapper" Param.name in register_wrapped_error_kind - (fun ecoerrors -> Error_monad.classify_errors ecoerrors) - ~id ~title:"Error returned by the protocol" - ~description:"Wrapped error for the economic protocol." - ~pp:(fun ppf -> - Format.fprintf ppf - "@[Economic error:@ %a@]" - (Format.pp_print_list Error_monad.pp)) - Data_encoding.(obj1 (req "ecoproto" - (list Error_monad.error_encoding))) - (function Ecoproto_error ecoerrors -> Some ecoerrors - | _ -> None ) - (function ecoerrors -> Ecoproto_error ecoerrors) + (module Wrapped_error_monad) + ~id ~title: ("Error returned by protocol " ^ Param.name) + ~description: ("Wrapped error for economic protocol " ^ Param.name ^ ".") let wrap_error = function | Ok _ as ok -> ok - | Error errors -> Error [Ecoproto_error errors] + | Error errors -> Error (List.map (fun error -> Ecoproto_error error) errors) module Block_hash = Block_hash module Operation_hash = Operation_hash @@ -269,19 +270,19 @@ module Make (Context : CONTEXT) = struct | `Created s -> Lwt.return (`Created s) | `No_content -> Lwt.return (`No_content) | `Unauthorized e -> - let e = Option.map e ~f:(fun e -> [Ecoproto_error e]) in + let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in Lwt.return (`Unauthorized e) | `Forbidden e -> - let e = Option.map e ~f:(fun e -> [Ecoproto_error e]) in + let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in Lwt.return (`Forbidden e) | `Not_found e -> - let e = Option.map e ~f:(fun e -> [Ecoproto_error e]) in + let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in Lwt.return (`Not_found e) | `Conflict e -> - let e = Option.map e ~f:(fun e -> [Ecoproto_error e]) in + let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in Lwt.return (`Conflict e) | `Error e -> - let e = Option.map e ~f:(fun e -> [Ecoproto_error e]) in + let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in Lwt.return (`Error e)) let register dir service handler = diff --git a/src/lib_protocol_environment/tezos_protocol_environment.mli b/src/lib_protocol_environment/tezos_protocol_environment.mli index 207bbb2de..c2bc15b9e 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.mli +++ b/src/lib_protocol_environment/tezos_protocol_environment.mli @@ -130,7 +130,7 @@ module Make (Context : CONTEXT) : sig and type (+'m,'pr,'p,'q,'i,'o) RPC_service.t = ('m,'pr,'p,'q,'i,'o) RPC_service.t and type Error_monad.shell_error = Error_monad.error - type error += Ecoproto_error of Error_monad.error list + type error += Ecoproto_error of Error_monad.error val wrap_error : 'a Error_monad.tzresult -> 'a tzresult module Lift (P : Updater.PROTOCOL) : PROTOCOL diff --git a/src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml b/src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml index 06bf608b7..1bbee0a31 100644 --- a/src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml +++ b/src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml @@ -321,8 +321,7 @@ module Assert = struct equal_pkh ~msg expected_delegate actual_delegate let ecoproto_error f = function - | Alpha_environment.Ecoproto_error errors -> - List.exists f errors + | Alpha_environment.Ecoproto_error error -> f error | _ -> false let hash op = Tezos_base.Operation.hash op diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index b99b27f03..1c2626557 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -131,7 +131,7 @@ let print_typecheck_result let type_map, errs = match res with | Ok type_map -> type_map, [] | Error (Alpha_environment.Ecoproto_error - (Script_tc_errors.Ill_typed_contract (_, type_map ) :: _) + (Script_tc_errors.Ill_typed_contract (_, type_map )) :: _ as errs) -> type_map, errs | Error errs -> diff --git a/src/proto_alpha/lib_client/michelson_v1_emacs.ml b/src/proto_alpha/lib_client/michelson_v1_emacs.ml index d93092f01..57e81d9fd 100644 --- a/src/proto_alpha/lib_client/michelson_v1_emacs.ml +++ b/src/proto_alpha/lib_client/michelson_v1_emacs.ml @@ -68,69 +68,97 @@ let print_type_map ppf (parsed, type_map) = let first_error_location errs = let rec find = function | [] -> 0 - | Inconsistent_type_annotations (loc, _, _) :: _ - | Unexpected_annotation loc :: _ - | 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, _) :: _ - | Michelson_v1_primitives.Invalid_primitive_name loc :: _ -> loc + | (Inconsistent_type_annotations (loc, _, _) + | Unexpected_annotation loc + | 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, _) + | Michelson_v1_primitives.Invalid_primitive_name (_, loc)) :: _ -> loc | _ :: rest -> find rest in find errs let report_errors ppf (parsed, errs) = - Format.fprintf ppf "(@[%a@])" + let eco, out = + List.fold_left + (fun (eco, out) -> function + | Alpha_environment.Ecoproto_error err -> (err :: eco, out) + | err -> (eco, err :: out)) + ([], []) errs in + let eco, out = List.rev eco, List.rev out in + Format.fprintf ppf "(@[%a@,%a@])" + (fun ppf errs -> + let find_location loc = + let oloc = List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in + fst (List.assoc oloc parsed.expansion_table) in + match errs with + | top :: errs -> + let errs, loc = + List.map + (fun e -> Alpha_environment.Ecoproto_error e) + (top :: errs), + match top with + | Ill_typed_contract (expr, _) + | Ill_typed_data (_, expr, _) -> + if expr = parsed.expanded then + find_location + (first_error_location + (top :: errs)) + else find_location 0 + | Michelson_v1_primitives.Invalid_primitive_name (expr, loc) -> + if Micheline.strip_locations (Michelson_v1_macros.unexpand_rec (Micheline.root expr)) = + parsed.Michelson_v1_parser.unexpanded then + find_location loc + else + find_location 0 + | _ -> find_location 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 } } = loc in + Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message + | [] -> ()) + eco (Format.pp_print_list (fun ppf err -> let find_location loc = let oloc = List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in fst (List.assoc oloc parsed.expansion_table) in - let errs, loc = + let loc = match err with - | Alpha_environment.Ecoproto_error (top :: errs) -> - [ Alpha_environment.Ecoproto_error (top :: errs) ], - begin match top with - | Ill_typed_contract (expr, _) - | Ill_typed_data (_, expr, _) -> - if expr = parsed.expanded then - find_location (first_error_location (top :: errs)) - else find_location 0 - | Michelson_v1_primitives.Invalid_primitive_name loc -> - find_location loc - | _ -> find_location 0 - end | Invalid_utf8_sequence (point, _) | Unexpected_character (point, _) | Undefined_escape_sequence (point, _) - | Missing_break_after_number point as err -> - [ err ], { start = point ; stop = point } + | Missing_break_after_number point -> + { start = point ; stop = point } | Unterminated_string loc | Unterminated_integer loc | Unterminated_comment loc | Unclosed { loc } | Unexpected { loc } - | Extra { loc } as err -> - [ err ], loc - | Misaligned node as err -> - [ err ], location node - | err -> [ err ], find_location 0 in + | Extra { loc } -> loc + | Misaligned node -> location node + | _ -> find_location 0 in let message = Format.asprintf "%a" (Michelson_v1_error_reporter.report_errors ~details:false ~show_source:false ~parsed) - errs in + [ err ] in let { start = { point = s } ; stop = { point = e } } = loc in Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message)) - errs + out diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index 62e5fe15a..de6b2e337 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -54,34 +54,37 @@ let rec print_enumeration ppf = function let collect_error_locations errs = let rec collect acc = function - | Ill_formed_type (_, _, loc) :: _ -> loc :: acc - | (Ill_typed_data (_, _, _) - | Ill_typed_contract (_, _)) :: _ + | Alpha_environment.Ecoproto_error + (Ill_formed_type (_, _, _) + | Runtime_contract_error (_, _) + | Michelson_v1_primitives.Invalid_primitive_name (_, _) + | Ill_typed_data (_, _, _) + | Ill_typed_contract (_, _)) :: _ | [] -> acc - | (Invalid_arity (loc, _, _, _) - | Inconsistent_type_annotations (loc, _, _) - | Unexpected_annotation loc - | Type_too_large (loc, _, _) - | Invalid_namespace (loc, _, _, _) - | Invalid_primitive (loc, _, _) - | Invalid_kind (loc, _, _) - | Duplicate_field (loc, _) - | Unexpected_big_map 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 - | Self_in_lambda loc - | Transfer_in_dip loc - | Invalid_constant (loc, _, _) - | Invalid_contract (loc, _) - | Comparable_type_expected (loc, _) - | Overflow loc - | Reject loc - | Michelson_v1_primitives.Invalid_primitive_name loc) :: rest -> + | Alpha_environment.Ecoproto_error + (Invalid_arity (loc, _, _, _) + | Inconsistent_type_annotations (loc, _, _) + | Unexpected_annotation loc + | Type_too_large (loc, _, _) + | Invalid_namespace (loc, _, _, _) + | Invalid_primitive (loc, _, _) + | Invalid_kind (loc, _, _) + | Duplicate_field (loc, _) + | Unexpected_big_map 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 + | Self_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 @@ -113,7 +116,26 @@ let report_errors ~details ~show_source ?parsed ppf errs = (List.mapi (fun i l -> (i + 1, l)) lines) in match errs with | [] -> () - | Ill_typed_data (name, expr, ty) :: rest -> + | Alpha_environment.Ecoproto_error (Michelson_v1_primitives.Invalid_primitive_name (expr, loc)) :: rest -> + let parsed = + match parsed with + | Some parsed -> + if Micheline.strip_locations (Michelson_v1_macros.unexpand_rec (Micheline.root expr)) = + parsed.Michelson_v1_parser.unexpanded then + parsed + else + Michelson_v1_printer.unparse_invalid expr + | None -> Michelson_v1_printer.unparse_invalid expr in + let hilights = loc :: collect_error_locations rest in + if show_source then + Format.fprintf ppf + "@[@[Invalid primitive:@ %a@]@]" + print_source (parsed, hilights) + else + Format.fprintf ppf "Invalid primitive." ; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace (parsed_locations parsed) rest + | Alpha_environment.Ecoproto_error (Ill_typed_data (name, expr, ty)) :: rest -> let parsed = match parsed with | Some parsed when expr = parsed.Michelson_v1_parser.expanded -> parsed @@ -130,12 +152,12 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_ty (None, ty) ; if rest <> [] then Format.fprintf ppf "@," ; print_trace (parsed_locations parsed) rest - | Ill_formed_type (_, expr, loc) :: rest -> + | Alpha_environment.Ecoproto_error (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 + let hilights = loc :: collect_error_locations errs in if show_source then Format.fprintf ppf "@[%aill formed type:@ %a@]" @@ -145,7 +167,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = "Ill formed type." ; if rest <> [] then Format.fprintf ppf "@," ; print_trace (parsed_locations parsed) rest - | Ill_typed_contract (expr, type_map) :: rest -> + | Alpha_environment.Ecoproto_error (Ill_typed_contract (expr, type_map)) :: rest -> let parsed = match parsed with | Some parsed when not details && expr = parsed.Michelson_v1_parser.expanded -> parsed @@ -159,20 +181,20 @@ let report_errors ~details ~show_source ?parsed ppf errs = Format.fprintf ppf "Ill typed contract."; if rest <> [] then Format.fprintf ppf "@," ; print_trace (parsed_locations parsed) rest - | Missing_field prim :: rest -> + | Alpha_environment.Ecoproto_error (Missing_field prim) :: rest -> Format.fprintf ppf "@[Missing contract field: %s@]" (Michelson_v1_primitives.string_of_prim prim) ; print_trace locations rest - | Duplicate_field (loc, prim) :: rest -> + | Alpha_environment.Ecoproto_error (Duplicate_field (loc, prim)) :: rest -> Format.fprintf ppf "@[%aduplicate contract field: %s@]" print_loc loc (Michelson_v1_primitives.string_of_prim prim) ; print_trace locations rest - | Unexpected_big_map loc :: rest -> + | Alpha_environment.Ecoproto_error (Unexpected_big_map loc) :: rest -> Format.fprintf ppf "%abig_map type only allowed on the left of the toplevel storage pair" print_loc loc ; print_trace locations rest - | Runtime_contract_error (contract, expr) :: rest -> + | Alpha_environment.Ecoproto_error (Runtime_contract_error (contract, expr)) :: rest -> let parsed = match parsed with | Some parsed when expr = parsed.Michelson_v1_parser.expanded -> parsed @@ -184,7 +206,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_source (parsed, hilights) ; if rest <> [] then Format.fprintf ppf "@," ; print_trace (parsed_locations parsed) rest - | err :: rest -> + | Alpha_environment.Ecoproto_error err :: rest -> begin match err with | Apply.Bad_contract_parameter (c, None, _) -> Format.fprintf ppf @@ -366,16 +388,20 @@ let report_errors ~details ~show_source ?parsed ppf errs = @[is not compatible with type@ %a.@]@]" print_ty (None, tya) print_ty (None, tyb) - | Reject _ -> Format.fprintf ppf "Script reached FAIL instruction" - | Overflow _ -> Format.fprintf ppf "Unexpected arithmetic overflow" + | Reject loc -> + Format.fprintf ppf "%ascript reached FAIL instruction" + print_loc loc + | Overflow loc -> + Format.fprintf ppf "%aunexpected arithmetic overflow" + print_loc loc | err -> Format.fprintf ppf "%a" Alpha_environment.Error_monad.pp err end ; if rest <> [] then Format.fprintf ppf "@," ; + print_trace locations rest + | err :: rest -> + Format.fprintf ppf "%a" Error_monad.pp err ; + if rest <> [] then Format.fprintf ppf "@," ; print_trace locations rest in - Format.fprintf ppf "@[%a@]" - (Format.pp_print_list - (fun ppf -> function - | Alpha_environment.Ecoproto_error errs -> - print_trace (fun _ -> None) errs - | err -> pp ppf err)) - errs + Format.fprintf ppf "@[" ; + print_trace (fun _ -> None) errs ; + Format.fprintf ppf "@]" diff --git a/src/proto_alpha/lib_client/michelson_v1_macros.ml b/src/proto_alpha/lib_client/michelson_v1_macros.ml index 2d4156ed7..a3f2d6663 100644 --- a/src/proto_alpha/lib_client/michelson_v1_macros.ml +++ b/src/proto_alpha/lib_client/michelson_v1_macros.ml @@ -503,6 +503,30 @@ let expand original = expand_if_some ; expand_if_right ] +let expand_rec expr = + let rec error_map (expanded, errors) f = function + | [] -> (List.rev expanded, List.rev errors) + | hd :: tl -> + let (new_expanded, new_errors) = f hd in + error_map + (new_expanded :: expanded, List.rev_append new_errors errors) + f tl in + let error_map = error_map ([], []) in + let rec expand_rec expr = + match expand expr with + | Ok expanded -> + begin + match expanded with + | Seq (loc, items, annot) -> + let items, errors = error_map expand_rec items in + (Seq (loc, items, annot), errors) + | Prim (loc, name, args, annot) -> + let args, errors = error_map expand_rec args in + (Prim (loc, name, args, annot), errors) + | Int _ | String _ as atom -> (atom, []) end + | Error errors -> (expr, errors) in + expand_rec expr + let unexpand_caddadr expanded = let rec rsteps acc = function | [] -> Some acc @@ -840,6 +864,14 @@ let unexpand original = unexpand_if_some ; unexpand_if_right ] +let rec unexpand_rec expr = + match unexpand expr with + | Seq (loc, items, annot) -> + Seq (loc, List.map unexpand_rec items, annot) + | Prim (loc, name, args, annot) -> + Prim (loc, name, List.map unexpand_rec args, annot) + | Int _ | String _ as atom -> atom + let () = let open Data_encoding in register_error_kind diff --git a/src/proto_alpha/lib_client/michelson_v1_macros.mli b/src/proto_alpha/lib_client/michelson_v1_macros.mli index 687a09032..c553c2aeb 100644 --- a/src/proto_alpha/lib_client/michelson_v1_macros.mli +++ b/src/proto_alpha/lib_client/michelson_v1_macros.mli @@ -16,6 +16,7 @@ type error += Sequence_expected of string type error += Invalid_arity of string * int * int val expand : 'l node -> 'l node tzresult +val expand_rec : 'l node -> 'l node * error list val expand_caddadr : 'l node -> 'l node option tzresult val expand_set_caddadr : 'l node -> 'l node option tzresult @@ -30,6 +31,7 @@ val expand_if_some : 'l node -> 'l node option tzresult val expand_if_right : 'l node -> 'l node option tzresult val unexpand : 'l node -> 'l node +val unexpand_rec : 'l node -> 'l node val unexpand_caddadr : 'l node -> 'l node option val unexpand_set_caddadr : 'l node -> 'l node option diff --git a/src/proto_alpha/lib_client/michelson_v1_parser.ml b/src/proto_alpha/lib_client/michelson_v1_parser.ml index 66251778a..799058ff8 100644 --- a/src/proto_alpha/lib_client/michelson_v1_parser.ml +++ b/src/proto_alpha/lib_client/michelson_v1_parser.ml @@ -23,28 +23,8 @@ type parsed = let expand_all source ast errors = let unexpanded, loc_table = extract_locations ast in - let rec error_map (expanded, errors) f = function - | [] -> (List.rev expanded, List.rev errors) - | hd :: tl -> - let (new_expanded, new_errors) = f hd in - error_map - (new_expanded :: expanded, List.rev_append new_errors errors) - f tl in - let error_map = error_map ([], []) in - let rec expand expr = - match Michelson_v1_macros.expand expr with - | Ok expanded -> - begin - match expanded with - | Seq (loc, items, annot) -> - let items, errors = error_map expand items in - (Seq (loc, items, annot), errors) - | Prim (loc, name, args, annot) -> - let args, errors = error_map expand args in - (Prim (loc, name, args, annot), errors) - | Int _ | String _ as atom -> (atom, []) end - | Error errors -> (expr, errors) in - let expanded, expansion_errors = expand (root unexpanded) in + let expanded, expansion_errors = + Michelson_v1_macros.expand_rec (root unexpanded) in let expanded, unexpansion_table = extract_locations expanded in let expansion_table = @@ -76,7 +56,7 @@ let expand_all source ast errors = { source ; unexpanded ; expanded = Micheline.strip_locations (Seq ((), [], None)) ; expansion_table ; unexpansion_table }, - errs @ errors @ expansion_errors + errors @ expansion_errors @ errs let parse_toplevel ?check source = let tokens, lexing_errors = Micheline_parser.tokenize source in diff --git a/src/proto_alpha/lib_client/michelson_v1_printer.ml b/src/proto_alpha/lib_client/michelson_v1_printer.ml index 3c1f37143..05de8a82c 100644 --- a/src/proto_alpha/lib_client/michelson_v1_printer.ml +++ b/src/proto_alpha/lib_client/michelson_v1_printer.ml @@ -61,20 +61,13 @@ let inject_types type_map parsed = inject_expr (root parsed.unexpanded) let unparse ?type_map parse expanded = - let rec unexpand expr = - match Michelson_v1_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 + |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in let rec inject_expr = function | Seq (loc, items, annot) -> Seq (inject_loc `before loc, List.map inject_expr items, annot) @@ -97,12 +90,20 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr | None -> expanded |> Michelson_v1_primitives.strings_of_prims - |> root |> unexpand |> Micheline.strip_locations + |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.strip_locations |> Micheline_printer.printable (fun n -> n) |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with | res, [] -> res - | _, _ :: _ -> Pervasives.failwith "Michelson_v1_printer.unexpand" + | _, _ :: _ -> Pervasives.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel let unparse_expression = unparse Michelson_v1_parser.parse_expression + +let unparse_invalid expanded = + let source = + expanded + |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.strip_locations + |> Micheline_printer.printable (fun n -> n) + |> Format.asprintf "%a" Micheline_printer.print_expr_unwrapped in + fst (Michelson_v1_parser.parse_toplevel source) diff --git a/src/proto_alpha/lib_client/michelson_v1_printer.mli b/src/proto_alpha/lib_client/michelson_v1_printer.mli index f8a8bd289..7aa3b2312 100644 --- a/src/proto_alpha/lib_client/michelson_v1_printer.mli +++ b/src/proto_alpha/lib_client/michelson_v1_printer.mli @@ -29,3 +29,8 @@ val inject_types : contracts extracted from the blockchain and not local files. *) val unparse_toplevel : ?type_map: Script_tc_errors.type_map -> Script.expr -> Michelson_v1_parser.parsed val unparse_expression : Script.expr -> Michelson_v1_parser.parsed + +(** Unexpand the macros and produce the result of parsing an + intermediate pretty printed source. Works on generic trees,for + programs that fail to be converted to a specific script version. *) +val unparse_invalid : string Micheline.canonical -> Michelson_v1_parser.parsed diff --git a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index 96824decb..db114082b 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml @@ -119,11 +119,20 @@ let commands () = program res cctxt - | res_with_errors -> + | res_with_errors when emacs_mode -> cctxt#message "(@[(types . ())@ (errors . %a)@])" Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> - return ()) ; + return () + | (parsed, errors) -> + cctxt#message "%a" + (fun ppf () -> + Michelson_v1_error_reporter.report_errors + ~details:(not no_print_source) ~parsed + ~show_source:(not no_print_source) + ppf errors) () >>= fun () -> + return () + ) ; command ~group ~desc: "Ask the node to typecheck a data expression." (args1 no_print_source_flag) diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml index a5b4b523a..cd55055d5 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml @@ -11,7 +11,7 @@ open Micheline type error += Unknown_primitive_name of string type error += Invalid_case of string -type error += Invalid_primitive_name of Micheline.canonical_location +type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location type prim = | K_parameter @@ -348,7 +348,7 @@ let prims_of_strings expr = | Int _ | String _ as expr -> ok expr | Prim (loc, prim, args, annot) -> Error_monad.record_trace - (Invalid_primitive_name loc) + (Invalid_primitive_name (expr, loc)) (prim_of_string prim) >>? fun prim -> List.fold_left (fun acc arg -> @@ -491,7 +491,7 @@ let () = ~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) + ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n) Data_encoding.(obj1 (req "wrongPrimitiveName" string)) (function | Unknown_primitive_name got -> Some got @@ -520,9 +520,11 @@ let () = "In a script or data expression, a primitive name is \ unknown or has a wrong case." ~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.") - Data_encoding.(obj1 (req "location" Micheline.canonical_location_encoding)) + Data_encoding.(obj2 + (req "expression" (Micheline.canonical_encoding ~variant:"generic" string)) + (req "location" Micheline.canonical_location_encoding)) (function - | Invalid_primitive_name loc -> Some loc + | Invalid_primitive_name (expr, loc) -> Some (expr, loc) | _ -> None) - (fun loc -> - Invalid_primitive_name loc) + (fun (expr, loc) -> + Invalid_primitive_name (expr, loc)) diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli index 84c82959c..cca53a235 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli @@ -9,7 +9,7 @@ type error += Unknown_primitive_name of string (* `Permanent *) type error += Invalid_case of string (* `Permanent *) -type error += Invalid_primitive_name of Micheline.canonical_location (* `Permanent *) +type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location (* `Permanent *) type prim = | K_parameter diff --git a/src/proto_alpha/lib_protocol/test/helpers/helpers_assert.ml b/src/proto_alpha/lib_protocol/test/helpers/helpers_assert.ml index ee04227ad..e197288d9 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_assert.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_assert.ml @@ -135,8 +135,7 @@ let equal_cents_balance ~tc ?msg (contract, cents_balance) = (contract, Helpers_cast.cents_of_int cents_balance) let ecoproto_error f = function - | Alpha_environment.Ecoproto_error errors -> - List.exists f errors + | Alpha_environment.Ecoproto_error error -> f error | _ -> false let contain_error ?(msg="") ~f = function