modify trace; oldify multifix

src/simplify/dune

@@ -7,7 +7,7 @@
     parser
     ast_simplified
     operators)
-  (modules ligodity pascaligo camligo simplify)
+  (modules ligodity pascaligo simplify)
   (preprocess
     (pps
       simple-utils.ppx_let_generalized

src/simplify/ligodity.ml

@@ -17,6 +17,18 @@ let pseq_to_list = function
   | Some lst -> npseq_to_list lst
 let get_value : 'a Raw.reg -> 'a = fun x -> x.value
 
+module Errors = struct
+  let wrong_pattern expected_name actual =
+    let title () = "wrong pattern" in
+    let message () = Format.asprintf "expected a %s, got something else" expected_name in
+    let data = [
+      ("actual_loc" , fun () -> Format.asprintf "%a" Location.pp_lift @@ Raw.region_of_pattern actual)
+    ] in
+    error ~data title message
+
+end
+
+open Errors
 open Operators.Simplify.Ligodity
 
 let r_split = Location.r_split
@@ -25,7 +37,7 @@ let rec pattern_to_var : Raw.pattern -> _ = fun p ->
   match p with
   | Raw.PPar p -> pattern_to_var p.value.inside
   | Raw.PVar v -> ok v
-  | _ -> simple_fail "not a var"
+  | _ -> fail @@ wrong_pattern "var" p
 
 let rec pattern_to_typed_var : Raw.pattern -> _ = fun p ->
   match p with
@@ -36,7 +48,7 @@ let rec pattern_to_typed_var : Raw.pattern -> _ = fun p ->
       ok (v , Some tp.type_expr)
     )
   | Raw.PVar v -> ok (v , None)
-  | _ -> simple_fail "not a var"
+  | _ -> fail @@ wrong_pattern "var" p
 
 let rec expr_to_typed_expr : Raw.expr -> _ = fun e ->
   match e with

src/simplify/simplify.ml

@@ -1,3 +1,2 @@
 module Pascaligo = Pascaligo
-module Camligo = Camligo
 module Ligodity = Ligodity

src/test/heap_tests.ml

@@ -106,9 +106,9 @@ let pop () : unit result =
     | Trace.Ok (output , _) -> (
         Format.printf "\nPop output on %d : %a\n" n Ast_typed.PP.annotated_expression output ;
       )
-    | Errors errs -> (
+    | Trace.Error err -> (
         Format.printf "\nPop output on %d : error\n" n) ;
-        Format.printf "Errors : {\n%a}\n%!" errors_pp (List.rev (List.rev_map (fun f -> f ()) errs)) ;
+        Format.printf "Errors : {\n%a}\n%!" error_pp (err ()) ;
     ) ;
     ok ()
   in

src/test/test.ml

@@ -3,7 +3,7 @@
 let () =
   (* Printexc.record_backtrace true ; *)
   Alcotest.run "LIGO" [
-    Multifix_tests.main ;
+    (* Multifix_tests.main ; *)
     Integration_tests.main ;
     Compiler_tests.main ;
     Transpiler_tests.main ;

src/test/test_helpers.ml

@@ -7,8 +7,8 @@ let test name f =
     f () in
   match result with
   | Ok ((), annotations) -> ignore annotations; ()
-  | Errors errs ->
-      Format.printf "Errors : {\n%a}\n%!" errors_pp (List.rev (List.rev_map (fun f -> f ()) errs)) ;
+  | Error err ->
+      Format.printf "Errors : {\n%a}\n%!" error_pp (err ()) ;
       raise Alcotest.Test_error
 
 open Ast_simplified.Combinators

vendors/ligo-utils/proto-alpha-utils/trace.ml

@@ -12,7 +12,7 @@ let of_alpha_tz_error err = of_tz_error (AE.Ecoproto_error err)
 let trace_alpha_tzresult err : 'a AE.Error_monad.tzresult -> 'a result =
   function
   | Result.Ok x -> ok x
-  | Error errs -> Errors (err :: List.map of_alpha_tz_error errs)
+  | Error errs -> fail @@ thunk @@ patch_children (List.map of_alpha_tz_error errs) (err ())
 
 let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ result =
   trace_alpha_tzresult error @@ Lwt_main.run x
@@ -20,21 +20,20 @@ let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ resul
 let trace_tzresult err =
   function
   | Result.Ok x -> ok x
-  | Error errs -> Errors (err :: List.map of_tz_error errs)
+  | Error errs -> fail @@ thunk @@ patch_children (List.map of_tz_error errs) (err ())
 
 (* TODO: should be a combination of trace_tzresult and trace_r *)
 let trace_tzresult_r err_thunk_may_fail =
   function
   | Result.Ok x -> ok x
-  | Error errs ->
-      let tz_errs = List.map of_tz_error errs in
+  | Error _errs ->
+      (* let tz_errs = List.map of_tz_error errs in *)
       match err_thunk_may_fail () with
-      | Simple_utils.Trace.Ok (err, annotations) -> ignore annotations; Errors (err :: tz_errs)
-      | Errors errors_while_generating_error ->
+      | Simple_utils.Trace.Ok (err, annotations) -> ignore annotations; Error (err)
+      | Error errors_while_generating_error ->
           (* TODO: the complexity could be O(n*n) in the worst case,
              this should use some catenable lists. *)
-          Errors (errors_while_generating_error
-                  @ tz_errs)
+          Error (errors_while_generating_error)
 
 let trace_tzresult_lwt err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result =
   trace_tzresult err @@ Lwt_main.run x

vendors/ligo-utils/simple-utils/location.ml

@@ -12,6 +12,12 @@ type t =
   | File of Region.t (* file_location *)
   | Virtual of virtual_location
 
+let pp = fun ppf t ->
+  match t with
+  | Virtual s -> Format.fprintf ppf "%s" s
+  | File f -> Format.fprintf ppf "%s" (f#to_string `Point)
+
+
 let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t =
   (* TODO: give correct unicode offsets (the random number is here so
      that searching for wrong souce locations appearing in messages
@@ -38,6 +44,7 @@ let pp_wrap f ppf { wrap_content ; _ } = Format.fprintf ppf "%a" f wrap_content
 let lift_region : 'a Region.reg -> 'a wrap = fun x ->
   wrap ~loc:(File x.region) x.value
 let lift : Region.region -> t = fun x -> File x
+let pp_lift = fun ppf r -> pp ppf @@ lift r
 
 let r_extract : 'a Region.reg -> t = fun x -> File x.region
 let r_split : 'a Region.reg -> ('a * t) = fun x -> x.value , File x.region

vendors/ligo-utils/simple-utils/trace.ml

@@ -3,8 +3,23 @@ module J = Yojson.Basic
 module JSON_string_utils = struct
   let member = J.Util.member
   let string = J.Util.to_string_option
+  let to_list_option = fun x ->
+    try ( Some (J.Util.to_list x))
+    with _ -> None
+  let to_assoc_option = fun x ->
+    try ( Some (J.Util.to_assoc x))
+    with _ -> None
+  let list = to_list_option
+  let assoc = to_assoc_option
   let int = J.Util.to_int_option
 
+  let patch j k v =
+    match assoc j with
+    | None -> j
+    | Some assoc -> `Assoc (
+        List.map (fun (k' , v') -> (k' , if k = k' then v else v')) assoc
+      )
+  
   let swap f l r = f r l
 
   let unit x = Some x
@@ -60,15 +75,15 @@ type annotation_thunk = annotation thunk
    point.
 *)
 type 'a result =
-    Ok of 'a * annotation_thunk list
-  | Errors of error_thunk list
+  | Ok of 'a * annotation_thunk list
+  | Error of error_thunk
 
 
 (**
    Constructors
 *)
 let ok x = Ok (x, [])
-let fail err = Errors [err]
+let fail err = Error err
 
 (**
    Monadic operators
@@ -77,12 +92,12 @@ let bind f = function
   | Ok (x, annotations) ->
       (match f x with
          Ok (x', annotations') -> Ok (x', annotations' @ annotations)
-       | Errors _ as e' -> ignore annotations; e')
-  | Errors _ as e -> e
+       | Error _ as e' -> ignore annotations; e')
+  | Error _ as e -> e
 
 let map f = function
   | Ok (x, annotations) -> Ok (f x, annotations)
-  | Errors _ as e -> e
+  | Error _ as e -> e
 
 (**
    Usual bind-syntax is `>>=`, but this is taken from the Tezos code base. Where
@@ -125,6 +140,7 @@ let thunk x () = x
 let mk_error
     ?(error_code : int thunk option) ?(message : string thunk option)
     ?(data : (string * string thunk) list option)
+    ?(children = []) ?(infos = [])
     ~(title : string thunk) () : error =
   let error_code' = X_option.map (fun x -> ("error_code" , `Int (x ()))) error_code in
   let title' = X_option.some ("title" , `String (title ())) in
@@ -132,14 +148,57 @@ let mk_error
     let aux (key , value) = (key , `String (value ())) in
     X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in
   let message' = X_option.map (fun x -> ("message" , `String (x ()))) message in
-  `Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ])
+  let type' = Some ("type" , `String "error") in
+  let children' = Some ("children" , `List children) in
+  let infos' = Some ("infos" , `List infos) in
+  `Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ; type' ; children' ; infos' ])
+
+let error ?data ?error_code ?children ?infos title message () = mk_error ?data ?error_code ?children ?infos ~title:(title) ~message:(message) ()
+
+let prepend_child = fun child err ->
+  let open JSON_string_utils in
+  let children_opt = err |> member "children" |> list in
+  let children = match children_opt with
+    | Some children -> (child ()) :: children
+    | None -> [ child () ] in
+  patch err "children" (`List children)
+
+let patch_children = fun children err ->
+  let open JSON_string_utils in
+  patch err "children" (`List (List.map (fun f -> f ()) children))
+
+(**
+   Build a standard info, with a title, a message, an info code and some data.
+*)
+let mk_info
+    ?(info_code : int thunk option) ?(message : string thunk option)
+    ?(data : (string * string thunk) list option)
+    ~(title : string thunk) () : error =
+  let error_code' = X_option.map (fun x -> ("error_code" , `Int (x ()))) info_code in
+  let title' = X_option.some ("title" , `String (title ())) in
+  let data' =
+    let aux (key , value) = (key , `String (value ())) in
+    X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in
+  let message' = X_option.map (fun x -> ("message" , `String (x ()))) message in
+  let type' = Some ("type" , `String "info") in
+  `Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ; type' ])
+
+let info ?data ?info_code title message () = mk_info ?data ?info_code ~title:(title) ~message:(message) ()
+
+let prepend_info = fun info err ->
+  let open JSON_string_utils in
+  let infos_opt = err |> member "infos" |> list in
+  let infos = match infos_opt with
+    | Some infos -> info :: infos
+    | None -> [ info ] in
+  patch err "infos" (`List infos)
 
-let error ?data ?error_code title message () = mk_error ?data ?error_code ~title:(title) ~message:(message) ()
 
 (**
    Helpers that ideally shouldn't be used in production.
 *)
 let simple_error str () = mk_error ~title:(thunk str) ()
+let simple_info str () = mk_info ~title:(thunk str) ()
 let simple_fail str = fail @@ simple_error str
 
 (**
@@ -176,9 +235,9 @@ let dummy_fail = simple_fail "dummy"
    ```
    And this will pass along the error triggered by "get key map".
 *)
-let trace err = function
+let trace info = function
   | Ok _ as o -> o
-  | Errors errs -> Errors (err :: errs)
+  | Error err -> Error (thunk @@ prepend_info (info ()) (err ()))
 
 (**
    Erase the current error stack, and replace it by the given error. It's useful
@@ -186,21 +245,52 @@ let trace err = function
 *)
 let trace_strong err = function
   | Ok _ as o -> o
-  | Errors _ -> Errors [err]
+  | Error _ -> Error err
+
+(**
+   Sometimes, when you have a list of potentially erroneous elements, you need
+   to retrieve all the errors, instead of just the first one. In that case, do:
+   ```
+   let type_list lst =
+     let%bind lst' =
+       trace_list (simple_error "Error while typing a list") @@
+       List.map type_element lst in
+     ...
+   ```
+   Where before you would have written:
+   ```
+   let type_list lst =
+     let%bind lst' = bind_map_list type_element lst in
+     ...
+   ```
+*)
+let trace_list err lst =
+  let oks =
+    let aux = function
+      | Ok (x , _) -> Some x
+      | _ -> None in
+    X_list.filter_map aux lst in
+  let errs =
+    let aux = function
+      | Error x -> Some x
+      | _ -> None in
+    X_list.filter_map aux lst in
+  match errs with
+  | [] -> ok oks
+  | errs -> fail (fun () -> patch_children errs err)
 
 (**
    Trace, but with an error which generation may itself fail.
 *)
 let trace_r err_thunk_may_fail = function
   | Ok _ as o -> o
-  | Errors errs -> (
+  | Error _ -> (
       match err_thunk_may_fail () with
-      | Ok (err, annotations) -> ignore annotations; Errors (err :: errs)
-      | Errors errors_while_generating_error ->
+      | Ok (err, annotations) -> ignore annotations; Error (err)
+      | Error errors_while_generating_error ->
           (* TODO: the complexity could be O(n*n) in the worst case,
              this should use some catenable lists. *)
-          Errors (errors_while_generating_error
-                  @ errs)
+          Error (errors_while_generating_error)
     )
 
 (**
@@ -231,11 +321,11 @@ let trace_f_2_ez f name =
 *)
 let to_bool = function
   | Ok _ -> true
-  | Errors _ -> false
+  | Error _ -> false
 
 let to_option = function
   | Ok (o, annotations) -> ignore annotations; Some o
-  | Errors _ -> None
+  | Error _ -> None
 
 (**
    Convert an option to a result, with a given error if the parameter is None.
@@ -268,6 +358,7 @@ let rec bind_list = function
       bind_list tl >>? fun tl ->
       ok @@ hd :: tl
     )  
+
 let bind_ne_list = fun (hd , tl) ->
   hd >>? fun hd ->
   bind_list tl >>? fun tl ->
@@ -341,7 +432,7 @@ let bind_find_map_list error f lst =
     | [] -> fail error
     | hd :: tl -> (
         match f hd with
-        | Errors _ -> aux tl
+        | Error _ -> aux tl
         | o -> o
       )
   in
@@ -360,7 +451,7 @@ let bind_lr (type a b) ((a : a result), (b:b result)) : [`Left of a | `Right of
   match (a, b) with
   | (Ok _ as o), _ -> map (fun x -> `Left x) o
   | _, (Ok _ as o) -> map (fun x -> `Right x) o
-  | _, Errors b -> Errors b
+  | _, Error b -> Error 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
@@ -368,7 +459,7 @@ let bind_lr_lazy (type a b) ((a : a result), (b:unit -> b result)) : [`Left of a
   | _ -> (
       match b() with
       | Ok _ as o -> map (fun x -> `Right x) o
-      | Errors b -> Errors b
+      | Error b -> Error b
     )
 
 let bind_and (a, b) =