https://gitlab.com/tezos/tezos
Tip revision: 5b282b00373f4efda31fec1c3fb6887a713ba6b9 authored by Antonio Locascio on 19 January 2024, 09:37:00 UTC
wip
wip
Tip revision: 5b282b0
michelson_v1_emacs.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Tezos_micheline
open Micheline
let print_expr ppf expr =
let print_annot ppf = function
| [] -> ()
| annots -> Format.fprintf ppf " %s" (String.concat " " annots)
in
let rec print_expr ppf = function
| Int (_, value) -> Format.fprintf ppf "%s" (Z.to_string value)
| String (_, value) -> Micheline_printer.print_string ppf value
| Bytes (_, value) -> Format.fprintf ppf "0x%a" Hex.pp (Hex.of_bytes value)
| Seq (_, items) ->
Format.fprintf
ppf
"(seq %a)"
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
items
| Prim (_, name, [], []) -> Format.fprintf ppf "%s" name
| Prim (_, name, items, annot) ->
Format.fprintf
ppf
"(%s%a%s%a)"
name
print_annot
annot
(if items = [] then "" else " ")
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
items
in
let root = root (Michelson_v1_primitives.strings_of_prims expr) in
Format.fprintf ppf "@[<h>%a@]" print_expr root
let print_var_annots ppf = List.iter (Format.fprintf ppf "%s ")
let print_annot_expr ppf (expr, annot) =
Format.fprintf ppf "(%a%a)" print_var_annots annot print_expr expr
open Micheline_parser
open Script_tc_errors
let print_type_map ppf (parsed, type_map) =
let rec print_expr_types ppf = function
| Seq (loc, [])
| Prim (loc, _, [], _)
| Int (loc, _)
| Bytes (loc, _)
| String (loc, _) ->
print_item ppf loc
| Seq (loc, items) | Prim (loc, _, items, _) ->
print_item ppf loc ;
List.iter (print_expr_types ppf) items
and print_stack ppf items =
Format.fprintf
ppf
"(%a)"
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr)
items
and print_item ppf loc =
(let ( >?? ) = Option.bind in
List.assoc ~equal:Int.equal loc parsed.Michelson_v1_parser.expansion_table
>?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) ->
let locs = List.sort Stdlib.compare locs in
List.hd locs >?? fun hd_loc ->
List.assoc ~equal:Int.equal hd_loc type_map >?? fun (bef, aft) ->
Some (s, e, bef, aft))
|> Option.iter (fun (s, e, bef, aft) ->
Format.fprintf
ppf
"(@[<h>%d %d %a %a@])@,"
s
e
print_stack
bef
print_stack
aft)
in
Format.fprintf ppf "(@[<v 0>%a@])" print_expr_types (root parsed.unexpanded)
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_seq_arity (loc, _, _)
| Invalid_namespace (loc, _, _, _)
| Invalid_primitive (loc, _, _)
| Invalid_kind (loc, _, _)
| Invalid_never_expr loc
| Fail_not_in_tail_position loc
| Undefined_binop (loc, _, _, _)
| Undefined_unop (loc, _, _)
| Bad_return (loc, _, _)
| Bad_stack (loc, _, _, _)
| Unmatched_branches (loc, _, _)
| Invalid_constant (loc, _, _)
| Invalid_syntactic_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) =
let eco, out =
List.fold_left
(fun (eco, out) -> function
| 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 =
WithExceptions.Option.get ~loc:__LOC__
@@ List.assoc
~equal:Int.equal
loc
parsed.Michelson_v1_parser.unexpansion_table
in
fst
(WithExceptions.Option.get ~loc:__LOC__
@@ List.assoc ~equal:Int.equal oloc parsed.expansion_table)
in
match errs with
| top :: errs ->
let errs, loc =
( List.map (fun e -> 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 =
WithExceptions.Option.get ~loc:__LOC__
@@ List.assoc
~equal:Int.equal
loc
parsed.Michelson_v1_parser.unexpansion_table
in
fst
(WithExceptions.Option.get ~loc:__LOC__
@@ List.assoc ~equal:Int.equal oloc parsed.expansion_table)
in
let loc =
match err with
| Invalid_utf8_sequence (point, _)
| Unexpected_character (point, _)
| Undefined_escape_sequence (point, _)
| Missing_break_after_number point ->
{start = point; stop = point}
| Unterminated_string loc
| Unterminated_integer loc
| Unterminated_comment loc
| Invalid_hex_bytes loc
| Unclosed {loc; _}
| Unexpected {loc; _}
| 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)
[err]
in
let {start = {point = s; _}; stop = {point = e; _}} = loc in
Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message))
out