Merge branch '8-reporting-of-error-messages' into dev

src/ast_simplified/PP.ml

@@ -113,6 +113,22 @@ and matching : type a . (formatter -> a -> unit) -> formatter -> a matching -> u
     | Match_option {match_none ; match_some = (some, match_some)} ->
         fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none some f match_some
 
+(* Shows the type expected for the matched value *)
+and matching_type ppf m = match m with
+  | Match_tuple _ ->
+      fprintf ppf "tuple"
+  | Match_variant lst ->
+      fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
+  | Match_bool _ ->
+      fprintf ppf "boolean"
+  | Match_list _ ->
+      fprintf ppf "list"
+  | Match_option _ ->
+      fprintf ppf "option"
+
+and matching_variant_case_type ppf ((c,n),_a) =
+  fprintf ppf "| %s %s" c n
+
 let declaration ppf (d:declaration) = match d with
   | Declaration_type (type_name , te) ->
       fprintf ppf "type %s = %a" type_name type_expression te

src/ast_typed/misc.ml

@@ -204,7 +204,6 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
         @@ Assert.assert_list_same_size sa' sb' in
       trace (simple_error "sum type") @@
       bind_list_iter aux (List.combine sa' sb')
-
     )
   | T_sum _, _ -> fail @@ different_kinds a b
   | T_record ra, T_record rb -> (

src/bin/cli.ml

@@ -4,8 +4,8 @@ open Trace
 let toplevel x =
   match x with
   | Trace.Ok ((), annotations) -> ignore annotations; ()
-  | Errors ss ->
-      Format.printf "Errors: %a\n%!" errors_pp @@ List.map (fun f -> f()) ss
+  | Error ss ->
+      Format.printf "%a%!" error_pp (ss ())
 
 let main =
   let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in

src/main/run_source.ml

@@ -51,7 +51,7 @@ let transpile_value
   let%bind f =
     let open Transpiler in
     let (f , _) = functionalize e in
-    let%bind main = translate_main f in
+    let%bind main = translate_main f e.location in
     ok main
   in
 

src/main/run_typed.ml

@@ -5,7 +5,7 @@ let transpile_value
   let%bind f =
     let open Transpiler in
     let (f , _) = functionalize e in
-    let%bind main = translate_main f in
+    let%bind main = translate_main f e.location in
     ok main
   in
 

src/parser/ligodity.ml

@@ -94,5 +94,5 @@ let parse_expression (s:string) : AST.expr result =
               start.pos_fname s
           in
           simple_error str
-    ) @@ (fun () -> Parser.expr read lexbuf) >>? fun raw ->
+    ) @@ (fun () -> Parser.interactive_expr read lexbuf) >>? fun raw ->
   ok raw

src/parser/ligodity/AST.ml

@@ -346,7 +346,7 @@ and conditional = {
 
 let sprintf = Printf.sprintf
 
-let region_of_type_expr = function
+let type_expr_to_region = function
   TProd {region; _}
 | TSum {region; _}
 | TRecord {region; _}
@@ -355,12 +355,11 @@ let region_of_type_expr = function
 | TPar {region; _}
 | TAlias {region; _} -> region
 
-
-let region_of_list_pattern = function
+let list_pattern_to_region = function
   Sugar {region; _} | PCons {region; _} -> region
 
-let region_of_pattern = function
-  PList p -> region_of_list_pattern p
+let pattern_to_region = function
+  PList p -> list_pattern_to_region p
 | PTuple {region;_} | PVar {region;_}
 | PUnit {region;_} | PInt {region;_}
 | PTrue region | PFalse region
@@ -368,38 +367,38 @@ let region_of_pattern = function
 | PConstr {region; _} | PPar {region;_}
 | PRecord {region; _} | PTyped {region; _} -> region
 
-let region_of_bool_expr = function
+let bool_expr_to_region = function
   Or {region;_} | And {region;_}
 | True region | False region
 | Not {region;_} -> region
 
-let region_of_comp_expr = function
+let comp_expr_to_region = function
   Lt {region;_} | Leq {region;_}
 | Gt {region;_} | Geq {region;_}
 | Neq {region;_} | Equal {region;_} -> region
 
-let region_of_logic_expr = function
-  BoolExpr e -> region_of_bool_expr e
-| CompExpr e -> region_of_comp_expr e
+let logic_expr_to_region = function
+  BoolExpr e -> bool_expr_to_region e
+| CompExpr e -> comp_expr_to_region e
 
-let region_of_arith_expr = function
+let arith_expr_to_region = function
   Add {region;_} | Sub {region;_} | Mult {region;_}
 | Div {region;_} | Mod {region;_} | Neg {region;_}
 | Int {region;_} | Mtz {region; _}
 | Nat {region; _} -> region
 
-let region_of_string_expr = function
+let string_expr_to_region = function
   String {region;_} | Cat {region;_} -> region
 
-let region_of_list_expr = function
+let list_expr_to_region = function
   Cons {region; _} | List {region; _}
 (* | Append {region; _}*) -> region
 
-let region_of_expr = function
-  ELogic e -> region_of_logic_expr e
-| EArith e -> region_of_arith_expr e
-| EString e -> region_of_string_expr e
-| EList e -> region_of_list_expr e
+let expr_to_region = function
+  ELogic e -> logic_expr_to_region e
+| EArith e -> arith_expr_to_region e
+| EString e -> string_expr_to_region e
+| EList e -> list_expr_to_region e
 | EAnnot {region;_ } | ELetIn {region;_} | EFun {region;_}
 | ECond {region;_} | ETuple {region;_} | ECase {region;_}
 | ECall {region;_} | EVar {region; _} | EProj {region; _}

src/parser/ligodity/AST.mli

@@ -470,9 +470,9 @@ val print_tokens : (*?undo:bool ->*) ast -> unit
 (* Projecting regions from sundry nodes of the AST. See the first
    comment at the beginning of this file. *)
 
-val region_of_pattern   : pattern -> Region.t
-val region_of_expr      : expr -> Region.t
-val region_of_type_expr : type_expr -> Region.t
+val pattern_to_region   : pattern -> Region.t
+val expr_to_region      : expr -> Region.t
+val type_expr_to_region : type_expr -> Region.t
 
 (* Simplifications *)
 

src/parser/ligodity/Parser.mly

@@ -47,9 +47,9 @@ let rec mk_field_path (rank, tail) =
 
 (* Entry points *)
 
-%start program expr
+%start program interactive_expr
 %type <AST.t> program
-%type <AST.expr> expr
+%type <AST.expr> interactive_expr
 
 %%
 
@@ -382,6 +382,9 @@ tail:
 
 (* Expressions *)
 
+interactive_expr:
+  expr EOF                                                       { $1 }
+
 expr:
   base_cond__open(expr)                                    {       $1 }
 | reg(match_expr(base_cond))                               { ECase $1 }

src/parser/pascaligo/AST.ml

@@ -315,7 +315,8 @@ and statement =
 | Data  of data_decl
 
 and local_decl =
-  LocalLam   of lambda_decl
+  LocalFun  of fun_decl reg
+| LocalProc of proc_decl reg
 | LocalData of data_decl
 
 and data_decl =
@@ -785,9 +786,8 @@ let pattern_to_region = function
 | PTuple      {region; _} -> region
 
 let local_decl_to_region = function
-  LocalLam FunDecl     {region; _}
-| LocalLam ProcDecl    {region; _}
-| LocalLam EntryDecl   {region; _}
+  LocalFun             {region; _}
+| LocalProc            {region; _}
 | LocalData LocalConst {region; _}
 | LocalData LocalVar   {region; _} -> region
 

src/parser/pascaligo/AST.mli

@@ -299,7 +299,8 @@ and statement =
 | Data  of data_decl
 
 and local_decl =
-  LocalLam   of lambda_decl
+  LocalFun  of fun_decl reg
+| LocalProc of proc_decl reg
 | LocalData of data_decl
 
 and data_decl =

src/parser/pascaligo/Parser.mly

@@ -426,7 +426,8 @@ open_var_decl:
     in {region; value}}
 
 local_decl:
-  lambda_decl { LocalLam  $1 }
+  fun_decl  { LocalFun  $1 }
+| proc_decl { LocalProc $1 }
 | data_decl { LocalData $1 }
 
 data_decl:

src/parser/pascaligo/ParserLog.ml

@@ -251,7 +251,8 @@ and print_local_decls sequence =
   List.iter print_local_decl sequence
 
 and print_local_decl = function
-  LocalLam  decl -> print_lambda_decl decl
+  LocalFun  decl -> print_fun_decl  decl
+| LocalProc decl -> print_proc_decl decl
 | LocalData decl -> print_data_decl decl
 
 and print_data_decl = function

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,151 @@ 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 () = "" in
+    let data = [
+      ("expected", fun () -> expected_name);
+      ("actual_loc" , fun () -> Format.asprintf "%a" Location.pp_lift @@ Raw.pattern_to_region actual)
+    ] in
+    error ~data title message
+
+  let multiple_patterns construct (patterns: Raw.pattern list) =
+    let title () = "multiple patterns" in
+    let message () =
+      Format.asprintf "multiple patterns in \"%s\" are not supported yet" construct in
+    let patterns_loc =
+      List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p))
+        Region.min patterns in
+    let data = [
+      ("patterns_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ patterns_loc)
+    ] in
+    error ~data title message
+
+  let unknown_predefined_type name =
+    let title () = "type constants" in
+    let message () =
+      Format.asprintf "unknown predefined type \"%s\"" name.Region.value in
+    let data = [
+      ("typename_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_arith_op expr =
+    let title () = "arithmetic expressions" in
+    let message () =
+      Format.asprintf "this arithmetic operator is not supported yet" in
+    let expr_loc = Raw.expr_to_region expr in
+    let data = [
+      ("expr_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_string_catenation expr =
+    let title () = "string expressions" in
+    let message () =
+      Format.asprintf "string concatenation is not supported yet" in
+    let expr_loc = Raw.expr_to_region expr in
+    let data = [
+      ("expr_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc)
+    ] in
+    error ~data title message
+
+  let untyped_fun_param var =
+    let title () = "function parameter" in
+    let message () =
+      Format.asprintf "untyped function parameters are not supported yet" in
+    let param_loc = var.Region.region in
+    let data = [
+      ("param_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ param_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_tuple_pattern p =
+    let title () = "tuple pattern" in
+    let message () =
+      Format.asprintf "tuple patterns are not supported yet" in
+    let pattern_loc = Raw.pattern_to_region p in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_cst_constr p =
+    let title () = "constant constructor" in
+    let message () =
+      Format.asprintf "constant constructors are not supported yet" in
+    let pattern_loc = Raw.pattern_to_region p in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_non_var_pattern p =
+    let title () = "pattern is not a variable" in
+    let message () =
+      Format.asprintf "non-variable patterns in constructors \
+                       are not supported yet" in
+    let pattern_loc = Raw.pattern_to_region p in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
+    ] in
+    error ~data title message
+
+  let simplifying_expr t =
+    let title () = "simplifying expression" in
+    let message () = "" in
+    let data = [
+      ("expression" ,
+       thunk @@ Format.asprintf "%a" (PP_helpers.printer Raw.print_expr) t)
+    ] in
+    error ~data title message
+
+  let only_constructors p =
+    let title () = "constructors in patterns" in
+    let message () =
+      Format.asprintf "currently, only constructors are supported in patterns" in
+    let pattern_loc = Raw.pattern_to_region p in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_sugared_lists region =
+    let title () = "lists in patterns" in
+    let message () =
+      Format.asprintf "currently, only empty lists and constructors (::) \
+                       are supported in patterns" in
+    let data = [
+      ("pattern_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
+    ] in
+    error ~data title message
+
+  let corner_case ~loc message =
+    let title () = "corner case" in
+    let content () = "We don't have a good error message for this case. \
+                      We are striving find ways to better report them and \
+                      find the use-cases that generate them. \
+                      Please report this to the developers." in
+    let data = [
+      ("location" , fun () -> loc) ;
+      ("message" , fun () -> message) ;
+    ] in
+    error ~data title content
+end
+
+open Errors
+
 open Operators.Simplify.Ligodity
 
 let r_split = Location.r_split
@@ -25,7 +170,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 +181,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 "typed variable" p
 
 let rec expr_to_typed_expr : Raw.expr -> _ = fun e ->
   match e with
@@ -45,11 +190,13 @@ let rec expr_to_typed_expr : Raw.expr -> _ = fun e ->
   | _ -> ok (e , None)
 
 let patterns_to_var : Raw.pattern list -> _ = fun ps ->
-  let%bind () = Assert.assert_list_size ps 1 in
-  pattern_to_var @@ List.hd ps
+  match ps with
+  | [ pattern ] -> pattern_to_var pattern
+  | _ -> fail @@ multiple_patterns "let" ps
 
-let rec simpl_type_expression : Raw.type_expr -> type_expression result =
-  function
+let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te ->
+  trace (simple_info "simplifying this type expression...") @@
+  match te with
   | TPar x -> simpl_type_expression x.value.inside
   | TAlias v -> (
       match List.assoc_opt v.value type_constants with
@@ -59,26 +206,34 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result =
   | TFun x -> (
       let%bind (a , b) =
         let (a , _ , b) = x.value in
-        bind_map_pair simpl_type_expression (a , b) in
+        let%bind a = simpl_type_expression a in
+        let%bind b = simpl_type_expression b in
+        ok (a , b)
+      in
       ok @@ T_function (a , b)
     )
-  | TApp x ->
+  | TApp x -> (
       let (name, tuple) = x.value in
       let lst = npseq_to_list tuple.value.inside in
       let%bind cst =
-        trace_option (simple_error "unrecognized type constants") @@
-        List.assoc_opt name.value type_constants in
-      let%bind lst' = bind_list @@ List.map simpl_type_expression lst in
+        trace_option (unknown_predefined_type name) @@
+        List.assoc_opt name.value type_constants
+      in
+      let%bind lst' = bind_map_list simpl_type_expression lst in
       ok @@ T_constant (cst , lst')
-  | TProd p ->
-      let%bind tpl = simpl_list_type_expression
-        @@ npseq_to_list p.value in
+    )
+  | TProd p -> (
+      let%bind tpl = simpl_list_type_expression  @@ npseq_to_list p.value in
       ok tpl
+    )
   | TRecord r ->
       let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in
-      let%bind lst = bind_list
+      let apply (x:Raw.field_decl Raw.reg) =
+        (x.value.field_name.value, x.value.field_type) in
+      let%bind lst =
+        bind_list
         @@ List.map aux
-        @@ List.map (fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type))
+        @@ List.map apply
         @@ pseq_to_list r.value.elements in
       let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in
       ok @@ T_record m
@@ -104,7 +259,7 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
   | [] -> assert false
   | [hd] -> simpl_type_expression hd
   | lst ->
-      let%bind lst = bind_list @@ List.map simpl_type_expression lst in
+      let%bind lst = bind_map_list simpl_type_expression lst in
       ok @@ T_tuple lst
 
 let rec simpl_expression :
@@ -128,14 +283,7 @@ let rec simpl_expression :
     return @@ e_accessor ~loc var path'
   in
 
-  trace (
-    let title () = "simplifying expression" in
-    let message () = "" in
-    let data = [
-      ("expression" , thunk @@ Format.asprintf "%a" (PP_helpers.printer Raw.print_expr) t)
-    ] in
-    error ~data title message
-  ) @@
+  trace (simplifying_expr t) @@
   match t with
   | Raw.ELetIn e -> (
       let Raw.{binding ; body ; _} = e.value in
@@ -240,7 +388,8 @@ let rec simpl_expression :
       let n = Z.to_int @@ snd @@ n in
       return @@ e_literal ~loc (Literal_tez n)
     )
-  | EArith _ -> simple_fail "arith: not supported yet"
+  | EArith _ as e ->
+       fail @@ unsupported_arith_op e
   | EString (String s) -> (
       let (s , loc) = r_split s in
       let s' =
@@ -249,7 +398,8 @@ let rec simpl_expression :
       in
       return @@ e_literal ~loc (Literal_string s')
     )
-  | EString _ -> simple_fail "string: not supported yet"
+  | EString (Cat _) as e ->
+      fail @@ unsupported_string_catenation e
   | ELogic l -> simpl_logic_expression l
   | EList l -> simpl_list_expression l
   | ECase c -> (
@@ -321,7 +471,7 @@ and simpl_fun lamb' : expr result =
       | "storage" , None ->
         ok (var , T_variable "storage")
       | _ , None ->
-        simple_fail "untyped function parameter"
+          fail @@ untyped_fun_param var
       | _ , Some ty -> (
         let%bind ty' = simpl_type_expression ty in
         ok (var , ty')
@@ -411,21 +561,24 @@ and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result =
       let%bind lst = bind_list @@ List.map simpl_expression lst in
       return @@ e_tuple ?loc lst
 
-and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t ->
+and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
+  fun t ->
   let open! Raw in
-  let loc : 'a . 'a Raw.reg -> _ -> _ = fun x v -> Location.wrap ~loc:(File x.region) v in
+  let loc : 'a . 'a Raw.reg -> _ -> _ =
+    fun x v -> Location.wrap ~loc:(File x.region) v in
   match t with
   | TypeDecl x ->
       let {name;type_expr} : Raw.type_decl = x.value in
       let%bind type_expression = simpl_type_expression type_expr in
       ok @@ loc x @@ Declaration_type (name.value , type_expression)
-  | LetEntry x (* -> simple_fail "no entry point yet" *)
+  | LetEntry x
   | Let x -> (
       let _ , binding = x.value in
       let {bindings ; lhs_type ; let_rhs} = binding in
       let%bind (var , args) =
-        let%bind (hd , tl) = match bindings with
-          | [] -> simple_fail "let without bindgings"
+        let%bind (hd , tl) =
+          match bindings with
+          | [] -> fail @@ corner_case ~loc:__LOC__ "let without bindings"
           | hd :: tl -> ok (hd , tl)
         in
         let%bind var = pattern_to_var hd in
@@ -452,55 +605,58 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu
         )
     )
 
-and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t ->
+and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
+  fun t ->
   let open Raw in
-  let get_var (t:Raw.pattern) = match t with
+  let rec get_var (t:Raw.pattern) =
+    match t with
     | PVar v -> ok v.value
-    | _ ->
-        let error =
-          let title () = "not a var" in
-          let content () = Format.asprintf "%a" (PP_helpers.printer Raw.print_pattern) t in
-          error title content
+    | PPar p -> get_var p.value.inside
+    | _ -> fail @@ unsupported_non_var_pattern t
   in
-        fail error
-  in
-  let get_tuple (t:Raw.pattern) = match t with
+  let rec get_tuple (t:Raw.pattern) =
+    match t with
     | PTuple v -> npseq_to_list v.value
+    | PPar p -> get_tuple p.value.inside
     | x -> [ x ]
   in
   let get_single (t:Raw.pattern) =
     let t' = get_tuple t in
     let%bind () =
-      trace_strong (simple_error "not single") @@
+      trace_strong (unsupported_tuple_pattern t) @@
       Assert.assert_list_size t' 1 in
-    ok (List.hd t') in
-  let get_constr (t:Raw.pattern) = match t with
+    ok (List.hd t')
+  in
+  let rec get_constr (t:Raw.pattern) =
+    match t with
+    | PPar p -> get_constr p.value.inside
     | PConstr v -> (
         let (const , pat_opt) = v.value in
         let%bind pat =
-          trace_option (simple_error "No constructor without variable yet") @@
+          trace_option (unsupported_cst_constr t) @@
           pat_opt in
         let%bind single_pat = get_single pat in
         let%bind var = get_var single_pat in
         ok (const.value , var)
       )
-    | _ -> simple_fail "not a constr"
+    | _ -> fail @@ only_constructors t
   in
   let%bind patterns =
     let aux (x , y) =
       let xs = get_tuple x in
-      trace_strong (simple_error "no tuple in patterns yet") @@
+      trace_strong (unsupported_tuple_pattern x) @@
       Assert.assert_list_size xs 1 >>? fun () ->
       ok (List.hd xs , y)
     in
     bind_map_list aux t in
   match patterns with
   | [(PFalse _ , f) ; (PTrue _ , t)]
-  | [(PTrue _ , t) ; (PFalse _ , f)] -> ok @@ Match_bool {match_true = t ; match_false = f}
+  | [(PTrue _ , t) ; (PFalse _ , f)] ->
+      ok @@ Match_bool {match_true = t ; match_false = f}
   | [(PList (PCons c) , cons) ; (PList (Sugar sugar_nil) , nil)]
   | [(PList (Sugar sugar_nil) , nil) ; (PList (PCons c),  cons)] -> (
       let%bind () =
-        trace_strong (simple_error "Only empty list patterns and cons are allowed yet")
+        trace_strong (unsupported_sugared_lists sugar_nil.region)
         @@ Assert.assert_list_empty
         @@ pseq_to_list
         @@ sugar_nil.value.elements in
@@ -513,7 +669,8 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
       ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil}
     )
   | lst -> (
-      trace (simple_error "weird patterns not supported yet") @@
+      trace (simple_info "currently, only booleans, lists and constructors \
+                          are supported in patterns") @@
       let%bind constrs =
         let aux (x , y) =
           let error =

src/simplify/pascaligo.ml

@@ -14,6 +14,94 @@ 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 unsupported_entry_decl decl =
+    let title () = "entry point declarations" in
+    let message () =
+      Format.asprintf "entry points within the contract are not supported yet" in
+    let data = [
+      ("declaration",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ decl.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_proc_decl decl =
+    let title () = "procedure declarations" in
+    let message () =
+      Format.asprintf "procedures are not supported yet" in
+    let data = [
+      ("declaration",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ decl.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_local_proc region =
+    let title () = "local procedure declarations" in
+    let message () =
+      Format.asprintf "local procedures are not supported yet" in
+    let data = [
+      ("declaration",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
+    ] in
+    error ~data title message
+
+  let corner_case ~loc message =
+    let title () = "corner case" in
+    let content () = "We don't have a good error message for this case. \
+                      We are striving find ways to better report them and \
+                      find the use-cases that generate them. \
+                      Please report this to the developers." in
+    let data = [
+      ("location" , fun () -> loc) ;
+      ("message" , fun () -> message) ;
+    ] in
+    error ~data title content
+
+  let unknown_predefined_type name =
+    let title () = "type constants" in
+    let message () =
+      Format.asprintf "unknown predefined type \"%s\"" name.Region.value in
+    let data = [
+      ("typename_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region)
+    ] in
+    error ~data title message
+
+  let unsupported_arith_op expr =
+    let title () = "arithmetic expressions" in
+    let message () =
+      Format.asprintf "this arithmetic operator is not supported yet" in
+    let expr_loc = Raw.expr_to_region expr in
+    let data = [
+      ("expr_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_string_catenation expr =
+    let title () = "string expressions" in
+    let message () =
+      Format.asprintf "string concatenation is not supported yet" in
+    let expr_loc = Raw.expr_to_region expr in
+    let data = [
+      ("expr_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc)
+    ] in
+    error ~data title message
+
+  let unsupported_set_expr expr =
+    let title () = "set expressions" in
+    let message () =
+      Format.asprintf "set type is not supported yet" in
+     let expr_loc = Raw.expr_to_region expr in
+    let data = [
+      ("expr_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc)
+    ] in
+    error ~data title message
+end
+
+open Errors
 open Operators.Simplify.Pascaligo
 
 let r_split = Location.r_split
@@ -26,7 +114,7 @@ let return expr = ok @@ fun expr'_opt ->
 
 let return_let_in ?loc binder rhs = ok @@ fun expr'_opt ->
   match expr'_opt with
-  | None -> simple_fail "missing return" (* Hard to explain. Shouldn't happen in prod. *)
+  | None -> fail @@ corner_case ~loc:__LOC__ "missing return"
   | Some expr' -> ok @@ e_let_in ?loc binder rhs expr'
 
 let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
@@ -48,7 +136,7 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
       let lst = npseq_to_list tuple.value.inside in
       let%bind lst' = bind_list @@ List.map simpl_type_expression lst in
       let%bind cst =
-        trace_option (simple_error "unrecognized type constants") @@
+        trace_option (unknown_predefined_type name) @@
         List.assoc_opt name.value type_constants in
       ok @@ T_constant (cst , lst')
   | TProd p ->
@@ -57,9 +145,11 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
       ok tpl
   | TRecord r ->
       let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in
+      let apply =
+        fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type) in
       let%bind lst = bind_list
         @@ List.map aux
-        @@ List.map (fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type))
+        @@ List.map apply
         @@ pseq_to_list r.value.elements in
       let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in
       ok @@ T_record m
@@ -194,18 +284,20 @@ let rec simpl_expression (t:Raw.expr) : expr result =
       let n = Z.to_int @@ snd @@ n in
       return @@ e_literal ~loc (Literal_tez n)
     )
-  | EArith _ -> simple_fail "arith: not supported yet"
+  | EArith _ as e ->
+       fail @@ unsupported_arith_op e
   | EString (String s) ->
     let (s , loc) = r_split s in
       let s' =
         (* S contains quotes *)
-        String.(sub s 1 ((length s) - 2))
+        String.(sub s 1 (length s - 2))
       in
       return @@ e_literal ~loc (Literal_string s')
-  | EString _ -> simple_fail "string: not supported yet"
+  | EString (Cat _) as e ->
+      fail @@ unsupported_string_catenation e
   | ELogic l -> simpl_logic_expression l
   | EList l -> simpl_list_expression l
-  | ESet _ -> simple_fail "set: not supported yet"
+  | ESet _ -> fail @@ unsupported_set_expr t
   | ECase c -> (
       let (c , loc) = r_split c in
       let%bind e = simpl_expression c.expr in
@@ -224,7 +316,8 @@ let rec simpl_expression (t:Raw.expr) : expr result =
       let (mi , loc) = r_split mi in
       let%bind lst =
         let lst = List.map get_value @@ pseq_to_list mi.elements in
-        let aux : Raw.binding -> (expression * expression) result = fun b ->
+        let aux : Raw.binding -> (expression * expression) result =
+          fun b ->
             let%bind src = simpl_expression b.source in
             let%bind dst = simpl_expression b.image in
             ok (src, dst) in
@@ -309,26 +402,20 @@ and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result =
   match lst with
   | [] -> return @@ e_literal Literal_unit
   | [hd] -> simpl_expression hd
-  | lst -> (
+  | lst ->
       let%bind lst = bind_list @@ List.map simpl_expression lst in
       return @@ e_tuple ?loc lst
-    )
 
 and simpl_local_declaration : Raw.local_decl -> _ result = fun t ->
   match t with
-  | LocalData d -> simpl_data_declaration d
-  | LocalLam l -> simpl_lambda_declaration l
-
-and simpl_lambda_declaration : Raw.lambda_decl -> _ result = fun l ->
-  match l with
-  | FunDecl f -> (
+  | LocalData d ->
+      simpl_data_declaration d
+  | LocalFun f  ->
       let (f , loc) = r_split f in
       let%bind (name , e) = simpl_fun_declaration ~loc f in
       return_let_in ~loc name e
-    )
-  | ProcDecl _ -> simple_fail "no local procedure yet"
-  | EntryDecl _ -> simple_fail "no local entry-point yet"
-
+  | LocalProc d ->
+      fail @@ unsupported_local_proc d.Region.region
 and simpl_data_declaration : Raw.data_decl -> _ result = fun t ->
   match t with
   | LocalVar x ->
@@ -344,7 +431,8 @@ and simpl_data_declaration : Raw.data_decl -> _ result = fun t ->
       let%bind expression = simpl_expression x.init in
       return_let_in ~loc (name , Some t) expression
 
-and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t ->
+and simpl_param : Raw.param_decl -> (type_name * type_expression) result =
+  fun t ->
   match t with
   | ParamConst c ->
       let c = c.value in
@@ -357,11 +445,15 @@ and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t
       let%bind type_expression = simpl_type_expression c.param_type in
       ok (type_name , type_expression)
 
-and simpl_fun_declaration : loc:_ -> Raw.fun_decl -> ((name * type_expression option) * expression) result = fun ~loc x ->
+and simpl_fun_declaration :
+  loc:_ -> Raw.fun_decl -> ((name * type_expression option) * expression) result =
+  fun ~loc x ->
   let open! Raw in
   let {name;param;ret_type;local_decls;block;return} : fun_decl = x in
   (match npseq_to_list param.value.inside with
-   | [] -> simple_fail "function without parameters are not allowed"
+   | [] ->
+       fail @@
+       corner_case ~loc:__LOC__ "parameter-less function should not exist"
    | [a] -> (
        let%bind input = simpl_param a in
        let name = name.value in
@@ -407,12 +499,14 @@ and simpl_fun_declaration : loc:_ -> Raw.fun_decl -> ((name * type_expression op
        let%bind result =
          let aux prec cur = cur (Some prec) in
          bind_fold_right_list aux result body in
-       let expression = e_lambda ~loc binder (Some input_type) (Some output_type) result in
+       let expression =
+         e_lambda ~loc binder (Some input_type) (Some output_type) result in
        let type_annotation = Some (T_function (input_type, output_type)) in
        ok ((name.value , type_annotation) , expression)
      )
   )
-and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t ->
+and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
+  fun t ->
   let open! Raw in
   match t with
   | TypeDecl x -> (
@@ -434,15 +528,19 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu
       let%bind ((name , ty_opt) , expr) = simpl_fun_declaration ~loc x in
       ok @@ Location.wrap ~loc (Declaration_constant (name , ty_opt , expr))
     )
-  | LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet"
-  | LambdaDecl (EntryDecl _)-> simple_fail "no entry point yet"
+  | LambdaDecl (ProcDecl decl) ->
+      fail @@ unsupported_proc_decl decl
+  | LambdaDecl (EntryDecl decl) ->
+      fail @@ unsupported_entry_decl decl
 
-and simpl_statement : Raw.statement -> (_ -> expression result) result = fun s ->
+and simpl_statement : Raw.statement -> (_ -> expression result) result =
+  fun s ->
   match s with
   | Instr i -> simpl_instruction i
   | Data d -> simpl_data_declaration d
 
-and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) result = fun t ->
+and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) result =
+  fun t ->
   match t with
   | ProcCall _ -> simple_fail "no proc call"
   | Fail e -> (

src/simplify/simplify.ml

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

src/test/bin_tests.ml

@@ -8,6 +8,6 @@ let compile_contract_basic () : unit result =
   in
   ok ()
 
-let main = "Bin", [
+let main = test_suite "Bin" [
     test "compile contract basic" compile_contract_basic ;
 ]

src/test/coase_tests.ml

@@ -229,7 +229,7 @@ let sell () =
   ok ()
 
 
-let main = "Coase (End to End)", [
+let main = test_suite "Coase (End to End)" [
     test "buy" buy ;
     test "dispatch buy" dispatch_buy ;
     test "transfer" transfer ;

src/test/compiler_tests.ml

@@ -28,7 +28,7 @@ let multiple_vars () : unit result =
   let%bind _ = Assert.assert_equal_int ~msg:__LOC__ 42 result in
   ok ()
 
-let main = "Compiler (from Mini_C)", [
+let main = test_suite "Compiler (from Mini_C)" [
     test "identity" identity ;
     test "multiple_vars" multiple_vars ;
   ]

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
@@ -118,7 +118,7 @@ let pop () : unit result =
   simple_fail "display"
   (* ok () *)
 
-let main = "Heap (End to End)", [
+let main = test_suite "Heap (End to End)" [
     test "is_empty" is_empty ;
     test "get_top" get_top ;
     test "pop_switch" pop_switch ;

src/test/integration_tests.ml

@@ -456,7 +456,7 @@ let guess_the_hash_mligo () : unit result =
   let make_expected = fun n -> e_pair (e_typed_list [] t_operation) (e_int (42 + n)) in
   expect_eq_n program "main" make_input make_expected
 
-let main = "Integration (End to End)", [
+let main = test_suite "Integration (End to End)" [
     test "type alias" type_alias ;
     test "function" function_ ;
     test "assign" assign ;

src/test/test.ml

@@ -1,9 +1,50 @@
 (* -*- compile-command: "cd .. ; dune runtest" -*- *)
 
+open Test_helpers
+
+let rec test_height : test -> int = fun t ->
+  match t with
+  | Test _ -> 1
+  | Test_suite (_ , lst) -> (List.fold_left max 1 @@ List.map test_height lst) + 1
+
+let extract_test : test -> test_case = fun t ->
+  match t with
+  | Test tc -> tc
+  | _ -> assert false
+
+let extract_param : test -> (string * (string * test_case list) list) =
+  let extract_element = extract_test in
+  let extract_group : test -> (string * test_case list) = fun t ->
+    match t with
+    | Test tc -> ("isolated" , [ tc ])
+    | Test_suite (name , lst) -> (name , List.map extract_element lst) in
+  fun t ->
+      match t with
+      | Test tc -> ("" , [ ("isolated" , [ tc ] ) ])
+      | Test_suite (name , lst) -> (name , List.map extract_group lst)
+
+let x : _ -> (unit Alcotest.test) = fun x -> x
+
+(*
+  Alcotest.run parameters:
+  string * (string * f list) list
+*)
+
+let rec run_test ?(prefix = "") : test -> unit = fun t ->
+  match t with
+  | Test case -> Alcotest.run "isolated test" [ ("" , [ case ]) ]
+  | Test_suite (name , lst) -> (
+      if (test_height t <= 3) then (
+        let (name , tests) = extract_param t in
+        Alcotest.run (prefix ^ name) tests
+      ) else (
+        List.iter (run_test ~prefix:(prefix ^ name ^ "_")) lst
+      )
+    )
+
 let () =
   (* Printexc.record_backtrace true ; *)
-  Alcotest.run "LIGO" [
-    Multifix_tests.main ;
+  run_test @@ test_suite "LIGO" [
     Integration_tests.main ;
     Compiler_tests.main ;
     Transpiler_tests.main ;

src/test/test_helpers.ml

@@ -1,15 +1,24 @@
 open! Trace
 
+type test_case = unit Alcotest.test_case
+type test =
+  | Test_suite of (string * test list)
+  | Test of test_case
+
 let test name f =
+  Test (
     Alcotest.test_case name `Quick @@ fun () ->
     let result =
       trace (fun () -> error (thunk "running test") (thunk name) ()) @@
     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
+  )
+
+let test_suite name lst = Test_suite (name , lst)
         
 open Ast_simplified.Combinators
 

src/test/transpiler_tests.ml

@@ -1,12 +1,7 @@
 (* open Ligo_helpers.Trace
  * open Ligo.Mini_c
- * open Combinators
- * open Test_helpers *)
+ * open Combinators *)
+open Test_helpers
 
-(*
-  How should one test the transpiler?
-  I'm doing the dumb thing.
-*)
-
-let main = "Transpiler (from Ast_typed)", [
+let main = test_suite "Transpiler (from Ast_typed)" [
   ]

src/test/typer_tests.ml

@@ -65,7 +65,7 @@ end
 (* TODO: deep types (e.g. record of record)
    TODO: negative tests (expected type error) *)
 
-let main = "Typer (from simplified AST)", [
+let main = test_suite "Typer (from simplified AST)" [
     test "int" int ;
     test "unit"        TestExpressions.unit ;
     test "int2"        TestExpressions.int ;

src/transpiler/transpiler.ml

@@ -15,6 +15,76 @@ let map_of_kv_list lst =
   let open AST.SMap in
   List.fold_left (fun prev (k, v) -> add k v prev) empty lst
 
+module Errors = struct
+  let corner_case ~loc message =
+    let title () = "corner case" in
+    let content () = "we don't have a good error message for this case. we are
+striving find ways to better report them and find the use-cases that generate
+them. please report this to the developers." in
+    let data = [
+      ("location" , fun () -> loc) ;
+      ("message" , fun () -> message) ;
+    ] in
+    error ~data title content
+
+  let unrecognized_type_constant name =
+    let title () = "unrecognized type constant" in
+    let content () = name in
+    error title content
+
+  let unsupported_pattern_matching kind location =
+    let title () = "unsupported pattern-matching" in
+    let content () = Format.asprintf "%s patterns aren't supported yet" kind in
+    let data = [
+      ("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
+    ] in
+    error ~data title content
+
+  let not_functional_main location =
+    let title () = "not functional main" in
+    let content () = "main should be a function" in
+    let data = [
+      ("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
+    ] in
+    error ~data title content
+
+  let missing_entry_point name =
+    let title () = "missing entry point" in
+    let content () = "no entry point with the given name" in
+    let data = [
+      ("name" , fun () -> name) ;
+    ] in
+    error ~data title content
+
+  let wrong_mini_c_value expected_type actual =
+    let title () = "illed typed intermediary value" in
+    let content () = "type of intermediary value doesn't match what was expected" in
+    let data = [
+      ("expected_type" , fun () -> expected_type) ;
+      ("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ;
+    ] in
+    error ~data title content
+
+  let bad_untranspile bad_type value =
+    let title () = "untranspiling bad value" in
+    let content () = Format.asprintf "can not untranspile %s" bad_type in
+    let data = [
+      ("bad_type" , fun () -> bad_type) ;
+      ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
+    ] in
+    error ~data title content
+
+  let unknown_untranspile unknown_type value =
+    let title () = "untranspiling unknown value" in
+    let content () = Format.asprintf "can not untranspile %s" unknown_type in
+    let data = [
+      ("unknown_type" , fun () -> unknown_type) ;
+      ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
+    ] in
+    error ~data title content
+end
+open Errors
+
 let rec translate_type (t:AST.type_value) : type_value result =
   match t.type_value' with
   | T_constant ("bool", []) -> ok (T_base Base_bool)
@@ -37,12 +107,7 @@ let rec translate_type (t:AST.type_value) : type_value result =
   | T_constant ("option", [o]) ->
       let%bind o' = translate_type o in
       ok (T_option o')
-  | T_constant (name , lst) ->
-      let error =
-        let title () = "unrecognized type constant" in
-        let content () = Format.asprintf "%s (%d)" name (List.length lst) in
-        error title content in
-      fail error
+  | T_constant (name , _lst) -> fail @@ unrecognized_type_constant name
   | T_sum m ->
       let node = Append_tree.of_list @@ list_of_map m in
       let aux a b : type_value result =
@@ -77,23 +142,13 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [
   let node_tv = Append_tree.of_list @@ List.mapi (fun i a -> (i, a)) tys in
   let%bind path =
     let aux (i , _) = i = ind in
-    trace_option (simple_error "no leaf with given index") @@
+    trace_option (corner_case ~loc:__LOC__ "tuple access leaf") @@
     Append_tree.exists_path aux node_tv in
   let lr_path = List.map (fun b -> if b then `Right else `Left) path in
   let%bind (_ , lst) =
     let aux = fun (ty' , acc) cur ->
       let%bind (a , b) =
-        let error =
-          let title () = "expected a pair" in
-          let content () = Format.asprintf "Big: %a.\tGot: %a\tFull path: %a\tSmall path: %a"
-              Mini_c.PP.type_ ty
-              Mini_c.PP.type_ ty'
-              PP_helpers.(list_sep bool (const ".")) path
-              PP_helpers.(list_sep lr (const ".")) (List.map snd acc)
-          in
-          error title content
-        in
-        trace_strong error @@
+        trace_strong (corner_case ~loc:__LOC__ "tuple access pair") @@
         Mini_c.get_t_pair ty' in
       match cur with
       | `Left -> ok (a , acc @ [(a , `Left)])
@@ -107,12 +162,14 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -
   let node_tv = Append_tree.of_list tys in
   let%bind path =
     let aux (i , _) = i = ind in
-    trace_option (simple_error "no leaf with given index") @@
+    trace_option (corner_case ~loc:__LOC__ "record access leaf") @@
     Append_tree.exists_path aux node_tv in
   let lr_path = List.map (fun b -> if b then `Right else `Left) path in
   let%bind (_ , lst) =
     let aux = fun (ty , acc) cur ->
-      let%bind (a , b) = Mini_c.get_t_pair ty in
+      let%bind (a , b) =
+        trace_strong (corner_case ~loc:__LOC__ "recard access pair") @@
+        Mini_c.get_t_pair ty in
       match cur with
       | `Left -> ok (a , acc @ [(a , `Left)])
       | `Right -> ok (b , acc @ [(b , `Right)] ) in
@@ -147,7 +204,6 @@ and transpile_small_environment : AST.small_environment -> Environment.t result
     ok @@ Environment.add (name , tv') prec
   in
   let%bind result =
-    trace (simple_error "transpiling small environment") @@
     bind_fold_right_list aux Environment.empty x' in
   ok result
 
@@ -163,8 +219,12 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
   let%bind tv = translate_type ae.type_annotation in
   let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in
   let f = translate_annotated_expression in
+  let info =
+    let title () = "translating expression" in
+    let content () = Format.asprintf "%a" Location.pp ae.location in
+    info title content in
+  trace info @@
   match ae.expression with
-    (* Optimise immediate application as a let-in *)
   | E_let_in {binder; rhs; result} ->
     let%bind rhs' = translate_annotated_expression rhs in
     let%bind result' = translate_annotated_expression result in
@@ -176,7 +236,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
   | E_literal l -> return @@ E_literal (translate_literal l)
   | E_variable name -> (
       let%bind ele =
-        trace_option (simple_error "name not in environment") @@
+        trace_option (corner_case ~loc:__LOC__ "name not in environment") @@
         AST.Environment.get_opt name ae.environment in
       let%bind tv = transpile_environment_element_type ele in
       return ~tv @@ E_variable name
@@ -185,14 +245,16 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind a = translate_annotated_expression a in
       let%bind b = translate_annotated_expression b in
       return @@ E_application (a, b)
-  | E_constructor (m, param) ->
+  | E_constructor (m, param) -> (
       let%bind param' = translate_annotated_expression param in
       let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in
-      let%bind node_tv = tree_of_sum ae.type_annotation in
+      let%bind node_tv =
+        trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
+        tree_of_sum ae.type_annotation in
       let leaf (k, tv) : (expression' option * type_value) result =
         if k = m then (
           let%bind _ =
-            trace (simple_error "constructor parameter doesn't have expected type (shouldn't happen here)")
+            trace_strong (corner_case ~loc:__LOC__ "wrong type for constructor parameter")
             @@ AST.assert_type_value_eq (tv, param.type_annotation) in
           ok (Some (param'_expr), param'_tv)
         ) else (
@@ -204,16 +266,17 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
         let%bind b = b in
         match (a, b) with
         | (None, a), (None, b) -> ok (None, T_or (a, b))
-        | (Some _, _), (Some _, _) -> simple_fail "several identical constructors in the same variant (shouldn't happen here)"
+        | (Some _, _), (Some _, _) -> fail @@ corner_case ~loc:__LOC__ "multiple identical constructors in the same variant"
         | (Some v, a), (None, b) -> ok (Some (E_constant ("LEFT", [Combinators.Expression.make_tpl (v, a)])), T_or (a, b))
         | (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [Combinators.Expression.make_tpl (v, b)])), T_or (a, b))
       in
       let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in
       let%bind ae =
-        trace_option (simple_error "constructor doesn't exist in claimed type (shouldn't happen here)")
+        trace_option (corner_case ~loc:__LOC__ "inexistant constructor")
           ae_opt in
       return ~tv ae
-  | E_tuple lst ->
+    )
+  | E_tuple lst -> (
       let node = Append_tree.of_list lst in
       let aux (a:expression result) (b:expression result) : expression result =
         let%bind a = a in
@@ -224,11 +287,16 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
         return ~tv @@ E_constant ("PAIR", [a; b])
       in
       Append_tree.fold_ne (translate_annotated_expression) aux node
-  | E_tuple_accessor (tpl, ind) ->
+    )
+  | E_tuple_accessor (tpl, ind) -> (
       let%bind ty' = translate_type tpl.type_annotation in
-      let%bind ty_lst = get_t_tuple tpl.type_annotation in
+      let%bind ty_lst =
+        trace_strong (corner_case ~loc:__LOC__ "not a tuple") @@
+        get_t_tuple tpl.type_annotation in
       let%bind ty'_lst = bind_map_list translate_type ty_lst in
-      let%bind path = tuple_access_to_lr ty' ty'_lst ind in
+      let%bind path =
+        trace_strong (corner_case ~loc:__LOC__ "tuple access") @@
+        tuple_access_to_lr ty' ty'_lst ind in
       let aux = fun pred (ty, lr) ->
         let c = match lr with
           | `Left -> "CAR"
@@ -237,7 +305,8 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind tpl' = translate_annotated_expression tpl in
       let expr = List.fold_left aux tpl' path in
       ok expr
-  | E_record m ->
+    )
+  | E_record m -> (
       let node = Append_tree.of_list @@ list_of_map m in
       let aux a b : expression result =
         let%bind a = a in
@@ -247,12 +316,18 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
         let tv = T_pair (a_ty , b_ty) in
         return ~tv @@ E_constant ("PAIR", [a; b])
       in
+      trace_strong (corner_case ~loc:__LOC__ "record build") @@
       Append_tree.fold_ne (translate_annotated_expression) aux node
+    )
   | E_record_accessor (record, property) ->
       let%bind ty' = translate_type (get_type_annotation record) in
-      let%bind ty_smap = get_t_record (get_type_annotation record) in
+      let%bind ty_smap =
+        trace_strong (corner_case ~loc:__LOC__ "not a record") @@
+        get_t_record (get_type_annotation record) in
       let%bind ty'_smap = bind_map_smap translate_type ty_smap in
-      let%bind path = record_access_to_lr ty' ty'_smap property in
+      let%bind path =
+        trace_strong (corner_case ~loc:__LOC__ "record access") @@
+        record_access_to_lr ty' ty'_smap property in
       let aux = fun pred (ty, lr) ->
         let c = match lr with
           | `Left -> "CAR"
@@ -261,26 +336,35 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind record' = translate_annotated_expression record in
       let expr = List.fold_left aux record' path in
       ok expr
-  | E_constant (name, lst) ->
-      let%bind lst' = bind_list @@ List.map (translate_annotated_expression) lst in (
+  | E_constant (name, lst) -> (
+      let%bind lst' = bind_map_list (translate_annotated_expression) lst in
       match name, lst with
       | "NONE", [] ->
-            let%bind o = Mini_c.Combinators.get_t_option tv in
+        let%bind o =
+          trace_strong (corner_case ~loc:__LOC__ "not an option") @@
+          Mini_c.Combinators.get_t_option tv in
         return @@ E_make_none o
       | _ -> return @@ E_constant (name, lst')
     )
   | E_lambda l ->
-    let%bind env = transpile_environment ae.environment in
+    let%bind env =
+      trace_strong (corner_case ~loc:__LOC__ "environment") @@
+      transpile_environment ae.environment in
     translate_lambda env l
-  | E_list lst ->
-      let%bind t = Mini_c.Combinators.get_t_list tv in
+  | E_list lst -> (
+      let%bind t =
+        trace_strong (corner_case ~loc:__LOC__ "not a list") @@
+        Mini_c.Combinators.get_t_list tv in
       let%bind lst' = bind_map_list (translate_annotated_expression) lst in
       let aux : expression -> expression -> expression result = fun prev cur ->
         return @@ E_constant ("CONS", [cur ; prev]) in
       let%bind (init : expression) = return @@ E_make_empty_list t in
       bind_fold_list aux init lst'
-  | E_map m ->
-      let%bind (src, dst) = Mini_c.Combinators.get_t_map tv in
+    )
+  | E_map m -> (
+      let%bind (src, dst) =
+        trace_strong (corner_case ~loc:__LOC__ "not a map") @@
+        Mini_c.Combinators.get_t_map tv in
       let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) ->
         let%bind prev' = prev in
         let%bind (k', v') =
@@ -290,9 +374,11 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       in
       let init = return @@ E_make_empty_map (src, dst) in
       List.fold_left aux init m
-  | E_look_up dsi ->
+    )
+  | E_look_up dsi -> (
       let%bind (ds', i') = bind_map_pair f dsi in
       return @@ E_constant ("MAP_GET", [i' ; ds'])
+    )
   | E_sequence (a , b) -> (
       let%bind a' = translate_annotated_expression a in
       let%bind b' = translate_annotated_expression b in
@@ -309,27 +395,25 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
         fun (prev, acc) cur ->
           let%bind ty' = translate_type prev in
           match cur with
-          | Access_tuple ind ->
-              let%bind ty_lst = AST.Combinators.get_t_tuple prev in
+          | Access_tuple ind -> (
+              let%bind ty_lst =
+                trace_strong (corner_case ~loc:__LOC__ "not a tuple") @@
+                AST.Combinators.get_t_tuple prev in
               let%bind ty'_lst = bind_map_list translate_type ty_lst in
               let%bind path = tuple_access_to_lr ty' ty'_lst ind in
               let path' = List.map snd path in
               ok (List.nth ty_lst ind, acc @ path')
-          | Access_record prop ->
+            )
+          | Access_record prop -> (
             let%bind ty_map =
-                let error =
-                  let title () = "accessing property on not a record" in
-                  let content () = Format.asprintf "%s on %a in %a"
-                    prop Ast_typed.PP.type_value prev Ast_typed.PP.annotated_expression expr in
-                  error title content
-                in
-                trace error @@
+                trace_strong (corner_case ~loc:__LOC__ "not a record") @@
                 AST.Combinators.get_t_record prev in
               let%bind ty'_map = bind_map_smap translate_type ty_map in
               let%bind path = record_access_to_lr ty' ty'_map prop in
               let path' = List.map snd path in
             ok (Map.String.find prop ty_map, acc @ path')
-          | Access_map _k -> simple_fail "no patch for map yet"
+          )
+          | Access_map _k -> fail (corner_case ~loc:__LOC__ "no patch for map yet")
       in
       let%bind (_, path) = bind_fold_right_list aux (ty, []) path in
       let%bind expr' = translate_annotated_expression expr in
@@ -349,9 +433,11 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
             ok (tv' , s') in
           return @@ E_if_none (expr' , n , ((name , tv') , s'))
       | Match_variant (lst , variant) -> (
-          let%bind tree = tree_of_sum variant in
+          let%bind tree =
+            trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
+            tree_of_sum variant in
           let%bind tree' = match tree with
-            | Empty -> simple_fail "match empty variant"
+            | Empty -> fail (corner_case ~loc:__LOC__ "match empty variant")
             | Full x -> ok x in
           let%bind tree'' =
             let rec aux t =
@@ -371,7 +457,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
             match t with
             | ((`Leaf constructor_name) , tv) -> (
                 let%bind ((_ , name) , body) =
-                  trace_option (simple_error "not supposed to happen here: missing match clause") @@
+                  trace_option (corner_case ~loc:__LOC__ "missing match clause") @@
                   List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
                 let%bind body' = translate_annotated_expression body in
                 return @@ E_let_in ((name , tv) , top , body')
@@ -391,10 +477,11 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
                 in
                 return @@ E_if_left (top , a' , b')
           in
+          trace_strong (corner_case ~loc:__LOC__ "building constructor") @@
           aux expr' tree''
         )
-      | AST.Match_list _ | AST.Match_tuple (_, _) ->
-          simple_fail "only match bool, option and variants are translated yet"
+      | AST.Match_list _ -> fail @@ unsupported_pattern_matching "list" ae.location
+      | AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location
     )
 
 and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l ->
@@ -433,7 +520,6 @@ and translate_lambda env l =
     | [] -> (
         let%bind result' = translate_annotated_expression result in
         let result' = ez_e_return result' in
-        trace (simple_error "translate quote") @@
         let%bind input = translate_type input_type in
         let%bind output = translate_type output_type in
         let tv = Combinators.t_function input output in
@@ -441,7 +527,6 @@ and translate_lambda env l =
         ok @@ Combinators.Expression.make_tpl (E_literal content, tv)
       )
     | _ -> (
-        trace (simple_error "translate lambda deep") @@
         translate_lambda_deep env l
       ) in
   ok result
@@ -463,11 +548,11 @@ let translate_program (lst:AST.program) : program result =
   let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in
   ok statements
 
-let translate_main (l:AST.lambda) : anon_function result =
+let translate_main (l:AST.lambda) loc : anon_function result =
   let%bind expr = translate_lambda Environment.empty l in
   match Combinators.Expression.get_content expr with
   | E_literal (D_function f) -> ok f
-  | _ -> simple_fail "main is not a function"
+  | _ -> fail @@ not_functional_main loc
 
 (* From an expression [expr], build the expression [fun () -> expr] *)
 let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value =
@@ -484,7 +569,7 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
   let rec aux acc (lst:AST.program) =
     let%bind acc = acc in
     match lst with
-    | [] -> simple_fail "no entry point with given name"
+    | [] -> fail @@ missing_entry_point name
     | hd :: tl -> (
         let (AST.Declaration_constant (an , (pre_env , _))) = temp_unwrap_loc hd in
         match an.name = name with
@@ -498,11 +583,11 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
             match an.annotated_expression.expression with
             | E_lambda l ->
               let l' = { l with result = acc l.result } in
-              translate_main l'
+              translate_main l' an.annotated_expression.location
             | _ ->
               let (l , _) = functionalize an.annotated_expression in
               let l' = { l with result = acc l.result } in
-              translate_main l'
+              translate_main l' an.annotated_expression.location
           )
       )
   in
@@ -553,36 +638,62 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
   let open! AST in
   let return e = ok (make_a_e_empty e t) in
   match t.type_value' with
-  | T_constant ("unit", []) ->
-      let%bind () = get_unit v in
+  | T_constant ("unit", []) -> (
+      let%bind () =
+        trace_strong (wrong_mini_c_value "unit" v) @@
+        get_unit v in
       return (E_literal Literal_unit)
-  | T_constant ("bool", []) ->
-      let%bind b = get_bool v in
+    )
+  | T_constant ("bool", []) -> (
+      let%bind b =
+        trace_strong (wrong_mini_c_value "bool" v) @@
+        get_bool v in
       return (E_literal (Literal_bool b))
-  | T_constant ("int", []) ->
-      let%bind n = get_int v in
+    )
+  | T_constant ("int", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "int" v) @@
+        get_int v in
       return (E_literal (Literal_int n))
-  | T_constant ("nat", []) ->
-      let%bind n = get_nat v in
+    )
+  | T_constant ("nat", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "nat" v) @@
+        get_nat v in      
       return (E_literal (Literal_nat n))
-  | T_constant ("tez", []) ->
-      let%bind n = get_nat v in
+    )
+  | T_constant ("tez", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "tez" v) @@
+        get_nat v in
       return (E_literal (Literal_tez n))
-  | T_constant ("string", []) ->
-      let%bind n = get_string v in
+    )
+  | T_constant ("string", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "string" v) @@
+        get_string v in
       return (E_literal (Literal_string n))
-  | T_constant ("address", []) ->
-      let%bind n = get_string v in
+    )
+  | T_constant ("address", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "address" v) @@
+        get_string v in
       return (E_literal (Literal_address n))
+    )
   | T_constant ("option", [o]) -> (
-      match%bind get_option v with
+      let%bind opt =
+        trace_strong (wrong_mini_c_value "option" v) @@
+        get_option v in
+      match opt with
       | None -> ok (e_a_empty_none o)
       | Some s ->
           let%bind s' = untranspile s o in
           ok (e_a_empty_some s')
     )
   | T_constant ("map", [k_ty;v_ty]) -> (
-      let%bind lst = get_map v in
+      let%bind lst =
+        trace_strong (wrong_mini_c_value "map" v) @@
+        get_map v in
       let%bind lst' =
         let aux = fun (k, v) ->
           let%bind k' = untranspile k k_ty in
@@ -592,48 +703,55 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
       return (E_map lst')
     )
   | T_constant ("list", [ty]) -> (
-      let%bind lst = get_list v in
+      let%bind lst =
+        trace_strong (wrong_mini_c_value "list" v) @@
+        get_list v in
       let%bind lst' =
         let aux = fun e -> untranspile e ty in
         bind_map_list aux lst in
       return (E_list lst')
     )
   | T_constant ("contract" , [_ty]) ->
-      simple_fail "can't untranspile contract"
-  | T_constant ("operation" , []) ->
-      let%bind op = get_operation v in
+    fail @@ bad_untranspile "contract" v
+  | T_constant ("operation" , []) -> (
+      let%bind op =
+        trace_strong (wrong_mini_c_value "operation" v) @@
+        get_operation v in
       return (E_literal (Literal_operation op))
-  | T_constant (name , lst) ->
-      let error =
-        let title () = "unknown type_constant" in
-        let content () = Format.asprintf "%s (%d)" name (List.length lst) in
-        error title content in
-      fail error
+    )
+  | T_constant (name , _lst) ->
+    fail @@ unknown_untranspile name v
   | T_sum m ->
       let lst = kv_list_of_map m in
       let%bind node = match Append_tree.of_list lst with
-        | Empty -> simple_fail "empty sum type"
+        | Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type"
         | Full t -> ok t
       in
-      let%bind (name, v, tv) = extract_constructor v node in
+      let%bind (name, v, tv) =
+        trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@
+        extract_constructor v node in
       let%bind sub = untranspile v tv in
       return (E_constructor (name, sub))
   | T_tuple lst ->
       let%bind node = match Append_tree.of_list lst with
-        | Empty -> simple_fail "empty tuple"
+        | Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple"
         | Full t -> ok t in
-      let%bind tpl = extract_tuple v node in
+      let%bind tpl =
+        trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@
+        extract_tuple v node in
       let%bind tpl' = bind_list
         @@ List.map (fun (x, y) -> untranspile x y) tpl in
       return (E_tuple tpl')
   | T_record m ->
       let lst = kv_list_of_map m in
       let%bind node = match Append_tree.of_list lst with
-        | Empty -> simple_fail "empty record"
+        | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
         | Full t -> ok t in
-      let%bind lst = extract_record v node in
+      let%bind lst =
+        trace_strong (corner_case ~loc:__LOC__ "record extract") @@
+        extract_record v node in
       let%bind lst = bind_list
         @@ List.map (fun (x, (y, z)) -> let%bind yz = untranspile y z in ok (x, yz)) lst in
       let m' = map_of_kv_list lst in
       return (E_record m')
-  | T_function _ -> simple_fail "no untranspilation for functions yet"
+  | T_function _ -> fail @@ bad_untranspile "function" v

src/typer/typer.ml

@@ -13,39 +13,199 @@ type environment = Environment.t
 module Errors = struct
   let unbound_type_variable (e:environment) (n:string) () =
     let title = (thunk "unbound type variable") in
-    let full () = Format.asprintf "%s in %a" n Environment.PP.full_environment e in
-    error title full ()
+    let message () = "" in
+    let data = [
+      ("variable" , fun () -> Format.asprintf "%s" n) ;
+      (* TODO: types don't have srclocs for now. *)
+      (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
+      ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
+    ] in
+    error ~data title message ()
 
-  let unbound_variable (e:environment) (n:string) () =
+  let unbound_variable (e:environment) (n:string) (loc:Location.t) () =
     let title = (thunk "unbound variable") in
-    let full () = Format.asprintf "%s in %a" n Environment.PP.full_environment e in
-    error title full ()
+    let message () = "" in
+    let data = [
+      ("variable" , fun () -> Format.asprintf "%s" n) ;
+      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
 
-  let unrecognized_constant (n:string) () =
+  let match_empty_variant : type a . a I.matching -> Location.t -> unit -> _ =
+    fun matching loc () ->
+    let title = (thunk "match with no cases") in
+    let message () = "" in
+    let data = [
+      ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
+
+  let match_missing_case : type a . a I.matching -> Location.t -> unit -> _ =
+    fun matching loc () ->
+    let title = (thunk "missing case in match") in
+    let message () = "" in
+    let data = [
+      ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
+
+  let match_redundant_case : type a . a I.matching -> Location.t -> unit -> _ =
+    fun matching loc () ->
+    let title = (thunk "missing case in match") in
+    let message () = "" in
+    let data = [
+      ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
+
+  let unbound_constructor (e:environment) (n:string) (loc:Location.t) () =
+    let title = (thunk "unbound constructor") in
+    let message () = "" in
+    let data = [
+      ("constructor" , fun () -> Format.asprintf "%s" n) ;
+      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
+
+  let unrecognized_constant (n:string) (loc:Location.t) () =
     let title = (thunk "unrecognized constant") in
-    let full () = n in
-    error title full ()
+    let message () = "" in
+    let data = [
+      ("constant" , fun () -> Format.asprintf "%s" n) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
 
-  let wrong_arity (n:string) (expected:int) (actual:int) () =
+  let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
     let title () = "wrong arity" in
-    let full () =
-      Format.asprintf "Wrong number of args passed to [%s]. Expected was %d, received was %d"
-        n expected actual
-    in
-    error title full ()
+    let message () = "" in
+    let data = [
+      ("function" , fun () -> Format.asprintf "%s" n) ;
+      ("expected" , fun () -> Format.asprintf "%d" expected) ;
+      ("actual" , fun () -> Format.asprintf "%d" actual) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
 
+  let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () =
+    let title () = "matching tuple of different size" in
+    let message () = "" in
+    let data = [
+      ("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ;
+      ("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
+
+  (* TODO: this should be a trace_info? *)
   let program_error (p:I.program) () =
+    let message () = "" in
     let title = (thunk "typing program") in
-    let full () = Format.asprintf "%a" I.PP.program p in
-    error title full ()
+    let data = [
+      ("program" , fun () -> Format.asprintf "%a" I.PP.program p)
+    ] in
+    error ~data title message ()
 
-  let constant_declaration_error (name:string) (ae:I.expr) () =
+  let constant_declaration_error (name:string) (ae:I.expr) (expected: O.type_value option) () =
     let title = (thunk "typing constant declaration") in
-    let full () =
-      Format.asprintf "%s = %a" name
-        I.PP.expression ae
-    in
-    error title full ()
+    let message () = "" in
+    let data = [
+      ("constant" , fun () -> Format.asprintf "%s" name) ;
+      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
+      ("expected" , fun () ->
+          match expected with
+            None -> "(no annotation for the expected type)"
+          | Some expected -> Format.asprintf "%a" O.PP.type_value expected) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
+    ] in
+    error ~data title message ()
+
+  let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
+    fun ?(msg = "") ~expected ~actual loc () ->
+    let title = (thunk "typing match") in
+    let message () = msg in
+    let data = [
+      ("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected);
+      ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
+
+  let needs_annotation (e : I.expression) (case : string) () =
+    let title = (thunk "this expression must be annotated with its type") in
+    let message () = Format.asprintf "%s needs an annotation" case in
+    let data = [
+      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
+    ] in
+    error ~data title message ()
+
+  let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : O.value) (loc:Location.t) () =
+    let title = (thunk "type error") in
+    let message () = msg in
+    let data = [
+      ("expected"   , fun () -> Format.asprintf "%s" expected);
+      ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_value actual);
+      ("expression" , fun () -> Format.asprintf "%a" O.PP.value expression) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
+
+  let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : O.value) (loc:Location.t) () =
+    let title = (thunk "type error") in
+    let message () = msg in
+    let data = [
+      ("expected"   , fun () -> Format.asprintf "%a" O.PP.type_value expected);
+      ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_value actual);
+      ("expression" , fun () -> Format.asprintf "%a" O.PP.value expression) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
+
+  let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
+    let title = (thunk "invalid tuple index") in
+    let message () = "" in
+    let data = [
+      ("index" , fun () -> Format.asprintf "%d" index) ;
+      ("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
+      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
+
+  let bad_record_access (field : string) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
+    let title = (thunk "invalid record field") in
+    let message () = "" in
+    let data = [
+      ("field" , fun () -> Format.asprintf "%s" field) ;
+      ("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
+      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
+    ] in
+    error ~data title message ()
+
+  let not_supported_yet (message : string) (ae : I.expression) () =
+    let title = (thunk "not suported yet") in
+    let message () = message in
+    let data = [
+      ("expression" , fun () -> Format.asprintf "%a"  I.PP.expression ae) ;
+      ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
+    ] in
+    error ~data title message ()
+
+  let not_supported_yet_untranspile (message : string) (ae : O.expression) () =
+    let title = (thunk "not suported yet") in
+    let message () = message in
+    let data = [
+      ("expression" , fun () -> Format.asprintf "%a"  O.PP.expression ae)
+    ] in
+    error ~data title message ()
+
 end
 open Errors
 
@@ -71,24 +231,24 @@ and type_declaration env : I.declaration -> (environment * O.declaration option)
   | Declaration_constant (name , tv_opt , expression) -> (
       let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
       let%bind ae' =
-        trace (constant_declaration_error name expression) @@
+        trace (constant_declaration_error name expression tv'_opt) @@
         type_expression ?tv_opt:tv'_opt env expression in
       let env' = Environment.add_ez_ae name ae' env in
       ok (env', Some (O.Declaration_constant ((make_n_e name ae') , (env , env'))))
     )
 
-and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> o O.matching result =
-  fun f e t i -> match i with
+and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> Location.t -> o O.matching result =
+  fun f e t i loc -> match i with
     | Match_bool {match_true ; match_false} ->
       let%bind _ =
-        trace_strong (simple_error "Matching bool on not-a-bool")
+        trace_strong (match_error ~expected:i ~actual:t loc)
         @@ get_t_bool t in
       let%bind match_true = f e match_true in
       let%bind match_false = f e match_false in
       ok (O.Match_bool {match_true ; match_false})
   | Match_option {match_none ; match_some} ->
       let%bind t_opt =
-        trace_strong (simple_error "Matching option on not-an-option")
+        trace_strong (match_error ~expected:i ~actual:t loc)
         @@ get_t_option t in
       let%bind match_none = f e match_none in
       let (n, b) = match_some in
@@ -98,7 +258,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
       ok (O.Match_option {match_none ; match_some = (n', b')})
   | Match_list {match_nil ; match_cons} ->
       let%bind t_list =
-        trace_strong (simple_error "Matching list on not-an-list")
+        trace_strong (match_error ~expected:i ~actual:t loc)
         @@ get_t_list t in
       let%bind match_nil = f e match_nil in
       let (hd, tl, b) = match_cons in
@@ -108,10 +268,10 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
       ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')})
   | Match_tuple (lst, b) ->
       let%bind t_tuple =
-        trace_strong (simple_error "Matching tuple on not-a-tuple")
+        trace_strong (match_error ~expected:i ~actual:t loc)
         @@ get_t_tuple t in
       let%bind lst' =
-        generic_try (simple_error "Matching tuple of different size")
+        generic_try (match_tuple_wrong_arity t_tuple lst loc)
         @@ (fun () -> List.combine lst t_tuple) in
       let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
       let e' = List.fold_left aux e lst' in
@@ -121,7 +281,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
       let%bind variant_opt =
         let aux acc ((constructor_name , _) , _) =
           let%bind (_ , variant) =
-            trace_option (simple_error "bad constructor") @@
+            trace_option (unbound_constructor e constructor_name loc) @@
             Environment.get_constructor constructor_name e in
           let%bind acc = match acc with
             | None -> ok (Some variant)
@@ -130,30 +290,32 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
                 ok (Some variant)
               ) in
           ok acc in
-        trace (simple_error "in match variant") @@
+        trace (simple_info "in match variant") @@
         bind_fold_list aux None lst in
       let%bind variant =
-        trace_option (simple_error "empty variant") @@
+        trace_option (match_empty_variant i loc) @@
         variant_opt in
       let%bind () =
-        let%bind variant_cases' = Ast_typed.Combinators.get_t_sum variant in
+        let%bind variant_cases' =
+          trace (match_error ~expected:i ~actual:t loc)
+          @@ Ast_typed.Combinators.get_t_sum variant in
         let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in
         let match_cases = List.map (Function.compose fst fst) lst in
         let test_case = fun c ->
           Assert.assert_true (List.mem c match_cases)
         in
         let%bind () =
-          trace (simple_error "missing case match") @@
+          trace_strong (match_missing_case i loc) @@
           bind_iter_list test_case variant_cases in
         let%bind () =
-          trace_strong (simple_error "redundant case match") @@
+          trace_strong (match_redundant_case i loc) @@
           Assert.assert_true List.(length variant_cases = length match_cases) in
         ok ()
       in
       let%bind lst' =
         let aux ((constructor_name , name) , b) =
           let%bind (constructor , _) =
-            trace_option (simple_error "bad constructor??") @@
+            trace_option (unbound_constructor e constructor_name loc) @@
             Environment.get_constructor constructor_name e in
           let e' = Environment.add_ez_binder name constructor e in
           let%bind b' = f e' b in
@@ -219,10 +381,10 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
   trace main_error @@
   match Location.unwrap ae with
   (* Basic *)
-  | E_failwith _ -> simple_fail "can't type failwith in isolation"
+  | E_failwith _ -> fail @@ needs_annotation ae "the failwith keyword"
   | E_variable name ->
       let%bind tv' =
-        trace_option (unbound_variable e name)
+        trace_option (unbound_variable e name ae.location)
         @@ Environment.get_opt name e in
       return (E_variable name) tv'.type_value
   | E_literal (Literal_bool b) ->
@@ -252,33 +414,33 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
       let%bind lst' = bind_list @@ List.map (type_expression e) lst in
       let tv_lst = List.map get_type_annotation lst' in
       return (E_tuple lst') (t_tuple tv_lst ())
-  | E_accessor (ae, path) ->
-      let%bind e' = type_expression e ae in
+  | E_accessor (ae', path) ->
+      let%bind e' = type_expression e ae' in
       let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result =
         match a with
         | Access_tuple index -> (
             let%bind tpl_tv = get_t_tuple prev.type_annotation in
             let%bind tv =
-              generic_try (simple_error "bad tuple index")
+              generic_try (bad_tuple_index index ae' prev.type_annotation ae.location)
               @@ (fun () -> List.nth tpl_tv index) in
             return (E_tuple_accessor (prev , index)) tv
           )
         | Access_record property -> (
             let%bind r_tv = get_t_record prev.type_annotation in
             let%bind tv =
-              generic_try (simple_error "bad record index")
+              generic_try (bad_record_access property ae' prev.type_annotation ae.location)
               @@ (fun () -> SMap.find property r_tv) in
             return (E_record_accessor (prev , property)) tv
           )
-        | Access_map ae -> (
-            let%bind ae' = type_expression e ae in
+        | Access_map ae' -> (
+            let%bind ae'' = type_expression e ae' in
             let%bind (k , v) = get_t_map prev.type_annotation in
             let%bind () =
-              Ast_typed.assert_type_value_eq (k , get_type_annotation ae') in
-            return (E_look_up (prev , ae')) v
+              Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in
+            return (E_look_up (prev , ae'')) v
           )
       in
-      trace (simple_error "accessing") @@
+      trace (simple_info "accessing") @@
       bind_fold_list aux e' path
 
   (* Sum *)
@@ -322,7 +484,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
         let%bind ty =
           let%bind opt = bind_fold_list aux init
           @@ List.map get_type_annotation lst' in
-          trace_option (simple_error "empty list expression without annotation") opt in
+          trace_option (needs_annotation ae "empty list") opt in
         ok (t_list ty ())
       in
       return (E_list lst') tv
@@ -341,7 +503,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
             @@ List.map get_type_annotation
             @@ List.map fst lst' in
           let%bind annot = bind_map_option get_t_map_key tv_opt in
-          trace (simple_error "untyped empty map expression") @@
+          trace (simple_info "empty map expression without a type annotation") @@
           O.merge_annotation annot sub
         in
         let%bind value_type =
@@ -350,7 +512,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
             @@ List.map get_type_annotation
             @@ List.map snd lst' in
           let%bind annot = bind_map_option get_t_map_value tv_opt in
-          trace (simple_error "untyped empty map expression") @@
+          trace (simple_info "empty map expression without a type annotation") @@
           O.merge_annotation annot sub
         in
         ok (t_map key_type value_type ())
@@ -365,7 +527,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
       let%bind input_type =
         let%bind input_type =
           (* Hack to take care of let_in introduced by `simplify/ligodity.ml` in ECase's hack *)
-          let default_action () = simple_fail "no input type provided" in
+          let default_action e () = fail @@ (needs_annotation e "the returned value") in
           match input_type with
           | Some ty -> ok ty
           | None -> (
@@ -375,11 +537,11 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
                   | I.E_variable name when name = (fst binder) -> (
                       match snd li.binder with
                       | Some ty -> ok ty
-                      | None -> default_action ()
+                      | None -> default_action li.rhs ()
                     )
-                  | _ -> default_action ()
+                  | _ -> default_action li.rhs ()
                 )
-              | _ -> default_action ()
+              | _ -> default_action result ()
             )
         in
         evaluate_type e input_type in
@@ -394,7 +556,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
   | E_constant (name, lst) ->
       let%bind lst' = bind_list @@ List.map (type_expression e) lst in
       let tv_lst = List.map get_type_annotation lst' in
-      let%bind (name', tv) = type_constant name tv_lst tv_opt in
+      let%bind (name', tv) = type_constant name tv_lst tv_opt ae.location in
       return (E_constant (name' , lst')) tv
   | E_application (f, arg) ->
       let%bind f = type_expression e f in
@@ -403,7 +565,12 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
         | T_function (param, result) ->
             let%bind _ = O.assert_type_value_eq (param, arg.type_annotation) in
             ok result
-        | _ -> simple_fail "applying to not-a-function"
+        | _ ->
+          fail @@ type_error_approximate
+            ~expected:"should be a function type"
+            ~expression:f
+            ~actual:f.type_annotation
+            f.location
       in
       return (E_application (f , arg)) tv
   | E_look_up dsi ->
@@ -420,11 +587,16 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
           let%bind fw = I.get_e_failwith match_true in
           let%bind fw' = type_expression e fw in
           let%bind mf' = type_expression e match_false in
+          let t = get_type_annotation ex' in
           let%bind () =
-            trace_strong (simple_error "Matching bool on not-a-bool")
-            @@ assert_t_bool (get_type_annotation ex') in
+            trace_strong (match_error ~expected:m ~actual:t ae.location)
+            @@ assert_t_bool t in
           let%bind () =
-            trace_strong (simple_error "Matching not-unit on an assert")
+            trace_strong (match_error
+                            ~msg:"matching not-unit on an assert"
+                            ~expected:m
+                            ~actual:t
+                            ae.location)
             @@ assert_t_unit (get_type_annotation mf') in
           let mt' = make_a_e
               (E_constant ("ASSERT" , [ex' ; fw']))
@@ -435,7 +607,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
           return (O.E_matching (ex' , m')) (t_unit ())
         )
       | _ -> (
-          let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m in
+          let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m ae.location in
           let tvs =
             let aux (cur:O.value O.matching) =
               match cur with
@@ -453,7 +625,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
             ok (Some cur) in
           let%bind tv_opt = bind_fold_list aux None tvs in
           let%bind tv =
-            trace_option (simple_error "empty matching") @@
+            trace_option (match_empty_variant m ae.location) @@
             tv_opt in
           return (O.E_matching (ex', m')) tv
         )
@@ -461,19 +633,37 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
   | E_sequence (a , b) ->
     let%bind a' = type_expression e a in
     let%bind b' = type_expression e b in
+    let a'_type_annot = get_type_annotation a' in
     let%bind () =
-      trace_strong (simple_error "first part of the sequence isn't of unit type") @@
-      Ast_typed.assert_type_value_eq (t_unit () , get_type_annotation a') in
+      trace_strong (type_error
+                      ~msg:"first part of the sequence should be of unit type"
+                      ~expected:(O.t_unit ())
+                      ~actual:a'_type_annot
+                      ~expression:a'
+                      a'.location) @@
+      Ast_typed.assert_type_value_eq (t_unit () , a'_type_annot) in
     return (O.E_sequence (a' , b')) (get_type_annotation b')
   | E_loop (expr , body) ->
     let%bind expr' = type_expression e expr in
     let%bind body' = type_expression e body in
+    let t_expr' = get_type_annotation expr' in
     let%bind () =
-      trace_strong (simple_error "while condition isn't of type bool") @@
-      Ast_typed.assert_type_value_eq (t_bool () , get_type_annotation expr') in
+      trace_strong (type_error
+                      ~msg:"while condition isn't of type bool"
+                      ~expected:(O.t_bool ())
+                      ~actual:t_expr'
+                      ~expression:expr'
+                      expr'.location) @@
+      Ast_typed.assert_type_value_eq (t_bool () , t_expr') in
+    let t_body' = get_type_annotation body' in
     let%bind () =
-      trace_strong (simple_error "while body isn't of unit type") @@
-      Ast_typed.assert_type_value_eq (t_unit () , get_type_annotation body') in
+      trace_strong (type_error
+                     ~msg:"while body isn't of unit type"
+                     ~expected:(O.t_unit ())
+                     ~actual:t_body'
+                     ~expression:body'
+                     body'.location) @@
+      Ast_typed.assert_type_value_eq (t_unit () , t_body') in
     return (O.E_loop (expr' , body')) (t_unit ())
   | E_assign (name , path , expr) ->
     let%bind typed_name =
@@ -485,24 +675,31 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
         | Access_tuple index -> (
             let%bind tpl = get_t_tuple prec_tv in
             let%bind tv' =
-              trace_option (simple_error "tuple too small") @@
+              trace_option (bad_tuple_index index ae prec_tv ae.location) @@
               List.nth_opt tpl index in
             ok (tv' , prec_path @ [O.Access_tuple index])
           )
         | Access_record property -> (
             let%bind m = get_t_record prec_tv in
             let%bind tv' =
-              trace_option (simple_error "tuple too small") @@
+              trace_option (bad_record_access property ae prec_tv ae.location) @@
               Map.String.find_opt property m in
             ok (tv' , prec_path @ [O.Access_record property])
           )
-        | Access_map _ -> simple_fail "no assign expressions with maps yet"
+        | Access_map _ ->
+          fail @@ not_supported_yet "assign expressions with maps are not supported yet" ae
       in
       bind_fold_list aux (typed_name.type_value , []) path in
     let%bind expr' = type_expression e expr in
+    let t_expr' = get_type_annotation expr' in
     let%bind () =
-      trace_strong (simple_error "assign type doesn't match left-hand-side") @@
-      Ast_typed.assert_type_value_eq (assign_tv , get_type_annotation expr') in
+      trace_strong (type_error
+                     ~msg:"type of the expression to assign doesn't match left-hand-side"
+                     ~expected:assign_tv
+                     ~actual:t_expr'
+                     ~expression:expr'
+                     expr'.location) @@
+      Ast_typed.assert_type_value_eq (assign_tv , t_expr') in
     return (O.E_assign (typed_name , path' , expr')) (t_unit ())
   | E_let_in {binder ; rhs ; result} ->
     let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in
@@ -517,11 +714,11 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
     ok {expr' with type_annotation}
 
 
-and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) : (string * O.type_value) result =
+and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) (loc : Location.t) : (string * O.type_value) result =
   (* Constant poorman's polymorphism *)
   let ct = Operators.Typer.constant_typers in
   let%bind typer =
-    trace_option (unrecognized_constant name) @@
+    trace_option (unrecognized_constant name loc) @@
     Map.String.find_opt name ct in
   typer lst tv_opt
 
@@ -599,7 +796,7 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
       return (e_failwith ae')
   | E_sequence _
   | E_loop _
-  | E_assign _ -> simple_fail "not possible to untranspile statements yet"
+  | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression
   | E_let_in {binder;rhs;result} ->
       let%bind tv = untype_type_value rhs.type_annotation in
       let%bind rhs = untype_expression rhs in

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,31 +235,62 @@ 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 (fun () -> prepend_info (info ()) (err ()))
 
 (**
    Erase the current error stack, and replace it by the given error. It's useful
-   when using `Asserts` and you want to discard its auto-generated message.
+   when using `Assert` and you want to discard its auto-generated message.
 *)
 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) =