ligo/src/proto_alpha/lib_client/michelson_v1_emacs.ml

(**************************************************************************)
(*                                                                        *)
(*    Copyright (c) 2014 - 2018.                                          *)
(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
(*                                                                        *)
(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
(*                                                                        *)
(**************************************************************************)

open Proto_alpha
open Tezos_micheline
open Micheline

let print_expr ppf expr =
  let print_annot ppf = function
    | None -> ()
    | Some annot -> Format.fprintf ppf " %s" annot in
  let rec print_expr ppf = function
    | Int (_, value) -> Format.fprintf ppf "%s" value
    | String (_, value) -> Micheline_printer.print_string ppf value
    | Seq (_, items, annot) ->
        Format.fprintf ppf "(seq%a %a)"
          print_annot annot
          (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
          items
    | Prim (_, name, [], None) ->
        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

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, _)
    | String (loc, _) ->
        print_item ppf loc
    | Seq (loc, items, _)
    | Prim (loc, _, items, _) ->
        print_item ppf loc ;
        List.iter (print_expr_types ppf) items
  and print_stack ppf items =
    Format.fprintf ppf "(%a)"
      (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
      items
  and print_item ppf loc = try
      let { start = { point = s } ; stop = { point = e } }, locs =
        List.assoc loc parsed.Michelson_v1_parser.expansion_table in
      let locs = List.sort compare locs in
      let (bef, aft) = List.assoc (List.hd locs) type_map in
      Format.fprintf ppf "(@[<h>%d %d %a %a@])@,"
        s e
        print_stack bef
        print_stack aft
    with Not_found -> () 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_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) =
  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 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
            | 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