From 0786edf3f33797ac78d182c36c086979b5dffd71 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sat, 20 Apr 2019 00:02:54 +0200 Subject: [PATCH] Added JSON annotations on Ok values in the trace monad. In some cases the values are dropped when converting values out of the monad or when converting the successful generation of an error message to an actual error. Look for `ignore annotations` in the source code for the places where these annotations are dropped. --- src/lib_utils/trace.ml | 46 +++++++++++++++++++++++------------ src/ligo/bin/cli.ml | 2 +- src/ligo/test/test_helpers.ml | 2 +- 3 files changed, 32 insertions(+), 18 deletions(-) diff --git a/src/lib_utils/trace.ml b/src/lib_utils/trace.ml index 4afc46b80..f39658fca 100644 --- a/src/lib_utils/trace.ml +++ b/src/lib_utils/trace.ml @@ -39,11 +39,14 @@ let mk_error ?(error_code : int option) ~(title : string) ?(message : string opt type error_thunk = unit -> error +type annotation = J.t (* feel free to add different annotations here. *) +type annotation_thunk = unit -> annotation + type 'a result = - Ok of 'a + Ok of 'a * annotation_thunk list | Errors of error_thunk list -let ok x = Ok x +let ok x = Ok (x, []) let fail err = Errors [err] (* When passing a constant string where a thunk is expected, we wrap it with thunk, as follows: @@ -64,11 +67,14 @@ let simple_fail str = fail @@ simple_error str let dummy_fail = simple_fail "dummy" let map f = function - | Ok x -> f x + | Ok (x, annotations) -> + (match f x with + Ok (x', annotations') -> Ok (x', annotations' @ annotations) + | Errors _ as e' -> ignore annotations; e') | Errors _ as e -> e let apply f = function - | Ok x -> Ok (f x) + | Ok (x, annotations) -> Ok (f x, annotations) | Errors _ as e -> e let (>>?) x f = map f x @@ -91,7 +97,7 @@ let trace_r err_thunk_may_fail = function | Ok _ as o -> o | Errors errs -> match err_thunk_may_fail () with - | Ok err -> Errors (err :: errs) + | Ok (err, annotations) -> ignore annotations; Errors (err :: errs) | Errors errors_while_generating_error -> (* TODO: the complexity could be O(n*n) in the worst case, this should use some catenable lists. *) @@ -111,7 +117,7 @@ let trace_f_2_ez f name = trace_f_2 f (error (thunk "in function") name) let to_option = function - | Ok o -> Some o + | Ok (o, annotations) -> ignore annotations; Some o | Errors _ -> None let trace_option error = function @@ -164,8 +170,8 @@ let bind_find_map_list error f lst = | [] -> fail error | hd :: tl -> ( match f hd with - | Ok x -> ok x | Errors _ -> aux tl + | o -> o ) in aux lst @@ -176,21 +182,21 @@ let bind_list_iter f lst = let bind_or (a, b) = match a with - | Ok x -> ok x + | Ok _ as o -> o | _ -> b let bind_lr (type a b) ((a : a result), (b:b result)) : [`Left of a | `Right of b] result = match (a, b) with - | Ok x, _ -> ok @@ `Left x - | _, Ok x -> ok @@ `Right x + | (Ok _ as o), _ -> apply (fun x -> `Left x) o + | _, (Ok _ as o) -> apply (fun x -> `Right x) o | _, Errors b -> Errors b let bind_lr_lazy (type a b) ((a : a result), (b:unit -> b result)) : [`Left of a | `Right of b] result = match a with - | Ok x -> ok @@ `Left x + | Ok _ as o -> apply (fun x -> `Left x) o | _ -> ( match b() with - | Ok x -> ok @@ `Right x + | Ok _ as o -> apply (fun x -> `Right x) o | Errors b -> Errors b ) @@ -232,7 +238,7 @@ let trace_tzresult_r err_thunk_may_fail = | Error errs -> let tz_errs = List.map of_tz_error errs in match err_thunk_may_fail () with - | Ok err -> Errors (err :: tz_errs) + | Ok (err, annotations) -> ignore annotations; Errors (err :: tz_errs) | Errors errors_while_generating_error -> (* TODO: the complexity could be O(n*n) in the worst case, this should use some catenable lists. *) @@ -268,13 +274,21 @@ let sys_command command = | n -> fail (fun () -> error (thunk "Nonzero return code") (fun () -> (string_of_int n)) ()) let sequence f lst = - let rec aux acc = function + let lazy_map_force : 'a . (unit -> 'a) list -> (unit -> 'a list) = fun l -> + fun () -> + List.rev @@ List.rev_map (fun a -> a ()) l in + let rec aux acc_x acc_annotations = function | hd :: tl -> ( match f hd with - | Ok x -> aux (x :: acc) tl + (* TODO: what should we do with the annotations? *) + | Ok (x, annotations) -> aux (x :: acc_x) (lazy_map_force annotations :: acc_annotations) tl | Errors _ as errs -> errs ) - | [] -> ok @@ List.rev acc in + | [] -> + let old_annotations () = List.map (fun a -> `List (a ())) @@ List.rev acc_annotations in + (* Builds a JSON annotation { "type": "list"; "content": [[…], …] } *) + let annotation = fun () -> `Assoc [("type", `String "list"); ("content", `List (old_annotations ()))] + in Ok (List.rev acc_x, [annotation]) in aux [] lst let json_of_error = J.to_string diff --git a/src/ligo/bin/cli.ml b/src/ligo/bin/cli.ml index 5d2cf802e..2c1cd6ffa 100644 --- a/src/ligo/bin/cli.ml +++ b/src/ligo/bin/cli.ml @@ -2,7 +2,7 @@ open Trace let toplevel x = match x with - | Trace.Ok () -> () + | Trace.Ok ((), annotations) -> ignore annotations; () | Errors ss -> Format.printf "Errors: %a\n%!" errors_pp @@ List.map (fun f -> f()) ss diff --git a/src/ligo/test/test_helpers.ml b/src/ligo/test/test_helpers.ml index f0769829a..e2aac4135 100644 --- a/src/ligo/test/test_helpers.ml +++ b/src/ligo/test/test_helpers.ml @@ -6,7 +6,7 @@ let test name f = trace (fun () -> error (thunk "running test") (fun () -> name) ()) @@ f () in match result with - | Ok () -> () + | Ok ((), annotations) -> ignore annotations; () | Errors errs -> Format.printf "Errors : {\n%a}\n%!" errors_pp (List.rev (List.rev_map (fun f -> f ()) errs)) ; raise Alcotest.Test_error