From 2a90be292c245d83b166844b7c7a727d448f7ac9 Mon Sep 17 00:00:00 2001 From: galfour Date: Fri, 20 Sep 2019 11:59:44 +0200 Subject: [PATCH] more formats --- src/bin/cli.ml | 62 ++++++++++++++++++++++-------------------- src/bin/cli_helpers.ml | 17 +++++++----- src/main/display.ml | 55 +++++++++++++++++++++++++++++++++---- 3 files changed, 91 insertions(+), 43 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 8d051dd83..4e7897720 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -45,89 +45,91 @@ let amount = info ~docv ~doc ["amount"] in value @@ opt string "0" info +let display_format = + let open Arg in + let info = + let docv = "DISPLAY_FORMAT" in + let doc = "$(docv) is the format that will be used by the CLI. Available formats are 'dev', 'json', and 'human-readable' (default). When human-readable lacks details (we are still tweaking it), please contact us and use another format in the meanwhile." in + info ~docv ~doc ["format" ; "display-format"] in + value @@ opt string "human-readable" info + let compile_file = - let f source entry_point syntax = - toplevel @@ + let f source entry_point syntax display_format = + toplevel ~display_format @@ let%bind contract = trace (simple_info "compiling contract to michelson") @@ Ligo.Compile.Of_source.compile_file_contract_entry source entry_point (Syntax_name syntax) in - Format.printf "%a\n" Tezos_utils.Michelson.pp contract.body ; - ok () + ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp contract.body in let term = - Term.(const f $ source 0 $ entry_point 1 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ syntax $ display_format) in let cmdname = "compile-contract" in let docs = "Subcommand: compile a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) let compile_parameter = - let f source entry_point expression syntax = - toplevel @@ + let f source entry_point expression syntax display_format = + toplevel ~display_format @@ let%bind value = trace (simple_error "compile-input") @@ Ligo.Compile.Of_source.compile_file_contract_parameter source entry_point expression (Syntax_name syntax) in - Format.printf "%a\n" Tezos_utils.Michelson.pp value; - ok () + ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ display_format) in let cmdname = "compile-parameter" in let docs = "Subcommand: compile parameters to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which calls a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) let compile_storage = - let f source entry_point expression syntax = - toplevel @@ + let f source entry_point expression syntax display_format = + toplevel ~display_format @@ let%bind value = trace (simple_error "compile-storage") @@ Ligo.Compile.Of_source.compile_file_contract_storage source entry_point expression (Syntax_name syntax) in - Format.printf "%a\n" Tezos_utils.Michelson.pp value; - ok () + ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ display_format) in let cmdname = "compile-storage" in let docs = "Subcommand: compile an initial storage in ligo syntax to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which originates a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) let dry_run = - let f source entry_point storage input amount syntax = - toplevel @@ + let f source entry_point storage input amount syntax display_format = + toplevel ~display_format @@ let%bind output = Ligo.Run.Of_source.run_contract ~amount source entry_point storage input (Syntax_name syntax) in - Format.printf "%a\n" Ast_simplified.PP.expression output ; - ok () + ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ syntax $ display_format) in let cmdname = "dry-run" in let docs = "Subcommand: run a smart-contract with the given storage and input." in (term , Term.info ~docs cmdname) let run_function = - let f source entry_point parameter amount syntax = - toplevel @@ + let f source entry_point parameter amount syntax display_format = + toplevel ~display_format @@ let%bind output = Ligo.Run.Of_source.run_function ~amount source entry_point parameter (Syntax_name syntax) in - Format.printf "%a\n" Ast_simplified.PP.expression output ; - ok () + ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ syntax $ display_format) in let cmdname = "run-function" in let docs = "Subcommand: run a function with the given parameter." in (term , Term.info ~docs cmdname) let evaluate_value = - let f source entry_point amount syntax = - toplevel @@ + let f source entry_point amount syntax display_format = + toplevel ~display_format @@ let%bind output = Ligo.Run.Of_source.evaluate ~amount source entry_point (Syntax_name syntax) in - Format.printf "%a\n" Ast_simplified.PP.expression output ; - ok () + ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output in let term = - Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax $ display_format) in let cmdname = "evaluate-value" in let docs = "Subcommand: evaluate a given definition." in (term , Term.info ~docs cmdname) diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml index ac0354368..dacac127e 100644 --- a/src/bin/cli_helpers.ml +++ b/src/bin/cli_helpers.ml @@ -1,9 +1,12 @@ open Trace +open Main.Display -let toplevel x = - match x with - | Trace.Ok ((), annotations) -> ignore annotations; () - | Error ss -> ( - Format.printf "%a%!" Main.Display.error_pp (ss ()) - ) - +let toplevel ~(display_format : string) (x : string result) = + let display_format = + try display_format_of_string display_format + with _ -> ( + Format.printf "bad display format %s, try looking at DISPLAY_FORMAT in the man (--help)." display_format ; + failwith "Display format" + ) + in + Format.printf "%a" (formatted_string_result_pp display_format) x diff --git a/src/main/display.ml b/src/main/display.ml index ab35528cb..753da77ec 100644 --- a/src/main/display.ml +++ b/src/main/display.ml @@ -1,8 +1,6 @@ -open Trace +open! Trace -let dev = false - -let rec error_pp out (e : error) = +let rec error_pp ?(dev = false) out (e : error) = let open JSON_string_utils in let message = let opt = e |> member "message" |> string in @@ -50,7 +48,52 @@ let rec error_pp out (e : error) = print "%s%s%s%s%s" location title error_code message data ) else ( print "%s%s%s.\n%s%s\n%a\n%a\n" title error_code message data location - (Format.pp_print_list error_pp) infos - (Format.pp_print_list error_pp) children + (Format.pp_print_list (error_pp ~dev)) infos + (Format.pp_print_list (error_pp ~dev)) children ) +let result_pp_hr f out (r : _ result) = + match r with + | Ok (s , _) -> Format.fprintf out "%a" f s + | Error e -> Format.fprintf out "%a" (error_pp ~dev:false) (e ()) + +let string_result_pp_hr = result_pp_hr (fun out s -> Format.fprintf out "%s" s) + +let result_pp_dev f out (r : _ result) = + match r with + | Ok (s , _) -> Format.fprintf out "%a" f s + | Error e -> Format.fprintf out "%a" (error_pp ~dev:false) (e ()) + +let string_result_pp_dev = result_pp_hr (fun out s -> Format.fprintf out "%s" s) + +let string_result_pp_json out (r : string result) = + let status_json status content : J.t = `Assoc ([ + ("status" , `String status) ; + ("content" , content) ; + ]) in + match r with + | Ok (x , _) -> ( + Format.fprintf out "%a" J.pp (status_json "ok" (`String x)) + ) + | Error e -> ( + Format.fprintf out "%a" J.pp (status_json "error" (e ())) + ) + +type display_format = [ + | `Human_readable + | `Json + | `Dev +] + +let display_format_of_string = fun s : display_format -> + match s with + | "dev" -> `Dev + | "json" -> `Json + | "human-readable" -> `Human_readable + | _ -> failwith "bad display_format" + +let formatted_string_result_pp (display_format : display_format) = + match display_format with + | `Human_readable -> string_result_pp_hr + | `Dev -> string_result_pp_dev + | `Json -> string_result_pp_json