Error_monad: change error wrapping to flatten the JSON format

src/lib_error_monad/error_monad.ml

@@ -13,10 +13,7 @@
 
 type error_category = [ `Branch | `Temporary | `Permanent ]
 
-type 'err full_error_category =
+(* hack: forward reference from [Data_encoding_ezjsonm] *)
-  [ error_category | `Wrapped of 'err -> error_category ]
-
-(* 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
+      match category with
-        (describe ~title ~description @@
+      | Wrapped (module WEM) ->
-         conv (fun x -> (((), ()), x)) (fun (((),()), x) -> x) @@
+          let unwrap err =
-         merge_objs
+            match WEM.unwrap err with
-           (obj2
+            | Some (WEM.Unclassified _) -> None
-              (req "kind" (constant (string_of_category category)))
+            | Some (WEM.Unregistred_error _) ->
-              (req "id" (constant name)))
+                Format.eprintf "What %s@." name ;
-           encoding)
+                None
-        from_error to_error in
+            | res -> res in
-    error_encoding_cache := None ;
+          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 ;
+      Error_kind
-                   category ;
+        { id = name ;
-                   from_error ;
+          category ;
-                   encoding_case ;
+          title ;
-                   pp = Option.unopt ~default:(json_pp name encoding) pp } :: !error_kinds
+          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
+      (module WEM : Wrapped_error_monad) ~id ~title ~description =
-      encoding from_error to_error =
     raw_register_error_kind
-      (`Wrapped category)
+      (Wrapped (module WEM))
-      ~id ~title ~description ?pp
+      ~id ~title ~description
-      encoding from_error to_error
+      ~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
+              | Main error_category -> error_category
-              | #error_category as x -> x
+              | 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

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

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
 

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

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)
+        (module Wrapped_error_monad)
-        ~id ~title:"Error returned by the protocol"
+        ~id ~title: ("Error returned by protocol " ^ Param.name)
-        ~description:"Wrapped error for the economic protocol."
+        ~description: ("Wrapped error for economic protocol " ^ Param.name ^ ".")
-        ~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)
 
     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 =

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

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 ->
+    | Alpha_environment.Ecoproto_error error -> f error
-        List.exists f errors
     | _ -> false
 
   let hash op = Tezos_base.Operation.hash op

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

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, _, _) :: _
+    | (Inconsistent_type_annotations (loc, _, _)
-    | Unexpected_annotation loc :: _
+      | Unexpected_annotation loc
-    | Ill_formed_type (_, _, loc) :: _
+      | Ill_formed_type (_, _, loc)
-    | Invalid_arity (loc, _, _, _) :: _
+      | Invalid_arity (loc, _, _, _)
-    | Invalid_namespace (loc, _, _, _) :: _
+      | Invalid_namespace (loc, _, _, _)
-    | Invalid_primitive (loc, _, _) :: _
+      | Invalid_primitive (loc, _, _)
-    | Invalid_kind (loc, _, _) :: _
+      | Invalid_kind (loc, _, _)
-    | Fail_not_in_tail_position loc :: _
+      | Fail_not_in_tail_position loc
-    | Undefined_binop (loc, _, _, _) :: _
+      | Undefined_binop (loc, _, _, _)
-    | Undefined_unop (loc, _, _) :: _
+      | Undefined_unop (loc, _, _)
-    | Bad_return (loc, _, _) :: _
+      | Bad_return (loc, _, _)
-    | Bad_stack (loc, _, _, _) :: _
+      | Bad_stack (loc, _, _, _)
-    | Unmatched_branches (loc, _, _) :: _
+      | Unmatched_branches (loc, _, _)
-    | Transfer_in_lambda loc :: _
+      | Transfer_in_lambda loc
-    | Transfer_in_dip loc :: _
+      | Transfer_in_dip loc
-    | Invalid_constant (loc, _, _) :: _
+      | Invalid_constant (loc, _, _)
-    | Invalid_contract (loc, _) :: _
+      | Invalid_contract (loc, _)
-    | Comparable_type_expected (loc, _) :: _
+      | Comparable_type_expected (loc, _)
-    | Michelson_v1_primitives.Invalid_primitive_name loc :: _ -> 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 ->
+            | Missing_break_after_number point ->
-                [ err ], { start = point ; stop = point }
+                { start = point ; stop = point }
             | Unterminated_string loc
             | Unterminated_integer loc
             | Unterminated_comment loc
             | Unclosed { loc }
             | Unexpected { loc }
-            | Extra { loc } as err ->
+            | Extra { loc } -> loc
-                [ err ], loc
+            | Misaligned node -> location node
-            | Misaligned node as err ->
+            | _ -> find_location 0 in
-                [ err ], location node
-            | err -> [ err ], 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

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
+    | Alpha_environment.Ecoproto_error
-    | (Ill_typed_data (_, _, _)
+        (Ill_formed_type (_, _, _)
-      | Ill_typed_contract (_, _)) :: _
+        | Runtime_contract_error (_, _)
+        | Michelson_v1_primitives.Invalid_primitive_name (_, _)
+        | Ill_typed_data (_, _, _)
+        | Ill_typed_contract (_, _)) :: _
     | [] -> acc
-    | (Invalid_arity (loc, _, _, _)
+    | Alpha_environment.Ecoproto_error
-      | Inconsistent_type_annotations (loc, _, _)
+        (Invalid_arity (loc, _, _, _)
-      | Unexpected_annotation loc
+        | Inconsistent_type_annotations (loc, _, _)
-      | Type_too_large (loc, _, _)
+        | Unexpected_annotation loc
-      | Invalid_namespace (loc, _, _, _)
+        | Type_too_large (loc, _, _)
-      | Invalid_primitive (loc, _, _)
+        | Invalid_namespace (loc, _, _, _)
-      | Invalid_kind (loc, _, _)
+        | Invalid_primitive (loc, _, _)
-      | Duplicate_field (loc, _)
+        | Invalid_kind (loc, _, _)
-      | Unexpected_big_map loc
+        | Duplicate_field (loc, _)
-      | Fail_not_in_tail_position loc
+        | Unexpected_big_map loc
-      | Undefined_binop (loc, _, _, _)
+        | Fail_not_in_tail_position loc
-      | Undefined_unop (loc, _, _)
+        | Undefined_binop (loc, _, _, _)
-      | Bad_return (loc, _, _)
+        | Undefined_unop (loc, _, _)
-      | Bad_stack (loc, _, _, _)
+        | Bad_return (loc, _, _)
-      | Unmatched_branches (loc, _, _)
+        | Bad_stack (loc, _, _, _)
-      | Transfer_in_lambda loc
+        | Unmatched_branches (loc, _, _)
-      | Self_in_lambda loc
+        | Transfer_in_lambda loc
-      | Transfer_in_dip loc
+        | Self_in_lambda loc
-      | Invalid_constant (loc, _, _)
+        | Transfer_in_dip loc
-      | Invalid_contract (loc, _)
+        | Invalid_constant (loc, _, _)
-      | Comparable_type_expected (loc, _)
+        | Invalid_contract (loc, _)
-      | Overflow loc
+        | Comparable_type_expected (loc, _)
-      | Reject loc
+        | Overflow loc
-      | Michelson_v1_primitives.Invalid_primitive_name loc) :: rest ->
+        | 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"
+          | Reject loc ->
-          | Overflow _ -> Format.fprintf ppf "Unexpected arithmetic overflow"
+              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.fprintf ppf "@[<v 0>" ;
-    (Format.pp_print_list
+  print_trace (fun _ -> None) errs ;
-       (fun ppf -> function
+  Format.fprintf ppf "@]"
-          | Alpha_environment.Ecoproto_error errs ->
-              print_trace (fun _ -> None) errs
-          | err -> pp ppf err))
-    errs

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

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

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
+  let expanded, expansion_errors =
-    | [] -> (List.rev expanded, List.rev errors)
+    Michelson_v1_macros.expand_rec (root unexpanded) in
-    | 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, 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

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)

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

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
                "(@[<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)

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 ->
+    (fun (expr, loc) ->
-       Invalid_primitive_name loc)
+       Invalid_primitive_name (expr, loc))

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

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 ->
+  | Alpha_environment.Ecoproto_error error -> f error
-      List.exists f errors
   | _ -> false
 
 let contain_error ?(msg="") ~f = function