balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Error_monad: change error wrapping to flatten the JSON format

Browse Source
This commit is contained in:
Benjamin Canou 2018-02-21 20:58:53 +01:00
parent bd3191059b
commit 19eb1c2520
19 changed files with 455 additions and 209 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

207
src/lib_error_monad/error_monad.ml
View File

@ -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
"@[<v 2>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 "@[<v 2>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

16
src/lib_error_monad/error_monad.mli
View File

@ -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

28
src/lib_error_monad/error_monad_sig.ml
View File

@ -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

13
src/lib_protocol_environment/sigs/v1/error_monad.mli
View File

@ -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 ->

45
src/lib_protocol_environment/tezos_protocol_environment.ml
View File

@ -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
"@[<v 2>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 =

2
src/lib_protocol_environment/tezos_protocol_environment.mli
View File

@ -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

3
src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml
View File

@ -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

2
src/proto_alpha/lib_client/client_proto_programs.ml
View File

@ -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 ->

112
src/proto_alpha/lib_client/michelson_v1_emacs.ml
View File

@ -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 "(@[<v 0>%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 "(@[<v 0>%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

116
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml
View File

@ -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
"@[<hov 0>@[<hov 2>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
"@[<v 2>%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 "@[<v 0>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 "@[<v 0>%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 =
@[<hov 2>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 "@[<v 0>%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 "@[<v 0>" ;
print_trace (fun _ -> None) errs ;
Format.fprintf ppf "@]"

32
src/proto_alpha/lib_client/michelson_v1_macros.ml
View File

@ -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

2
src/proto_alpha/lib_client/michelson_v1_macros.mli
View File

@ -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

26
src/proto_alpha/lib_client/michelson_v1_parser.ml
View File

@ -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

21
src/proto_alpha/lib_client/michelson_v1_printer.ml
View File

@ -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)

5
src/proto_alpha/lib_client/michelson_v1_printer.mli
View File

@ -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

13
src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml
View File

@ -119,11 +119,20 @@ let commands () =
program
res
cctxt
| res_with_errors ->
| res_with_errors when emacs_mode ->
cctxt#message
"(@[<v 0>(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)

16
src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml
View File

@ -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))

2
src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli
View File

@ -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

3
src/proto_alpha/lib_protocol/test/helpers/helpers_assert.ml
View File

@ -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