Merge branch 'dev' of gitlab.com:ligolang/ligo into rinderknecht@code_inclusion

src/bin/cli.ml

@@ -106,14 +106,15 @@ let predecessor_timestamp =
 
 let display_format =
   let open Arg in
+  let open Display in
   let info  =
     let docv = "DISPLAY_FORMAT" in
     let doc = "$(docv) is the format that will be used by the CLI. Available formats are 'dev', 'json', and 'human-readable' (default). When human-readable lacks details (we are still tweaking it), please contact us and use another format in the meanwhile." in
     info ~docv ~doc ["format" ; "display-format"] in
   value @@
   opt
-    (enum [("human-readable", `Human_readable); ("dev", `Dev); ("json", `Json)])
+    (enum [("human-readable", human_readable); ("dev", dev); ("json", json)])
-    `Human_readable
+    human_readable
     info
 
 let michelson_code_format =
@@ -127,110 +128,6 @@ let michelson_code_format =
     (enum [("text", `Text); ("json", `Json); ("hex", `Hex)])
     `Text info
 
-module Helpers = Ligo.Compile.Helpers
-module Compile = Ligo.Compile
-module Uncompile = Ligo.Uncompile
-module Run = Ligo.Run.Of_michelson
-
-let compile_file =
-  let f source_file entry_point syntax display_format disable_typecheck michelson_format =
-    toplevel ~display_format @@
-    let%bind typed,_    = Compile.Utils.type_file source_file syntax (Contract entry_point) in
-    let%bind mini_c     = Compile.Of_typed.compile typed in
-    let%bind michelson  = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in
-    let%bind contract   = Compile.Of_michelson.build_contract ~disable_typecheck michelson in
-    ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) contract
-  in
-  let term =
-    Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format $ disable_michelson_typechecking $ michelson_code_format) in
-  let cmdname = "compile-contract" in
-  let doc = "Subcommand: Compile a contract." in
-  (Term.ret term , Term.info ~doc cmdname)
-
-let preprocess =
-  let f source_file syntax display_format = (
-    toplevel ~display_format @@
-      let%bind pp =
-        Compile.Of_source.preprocess source_file (Syntax_name syntax) in
-      ok @@ Format.asprintf "%s \n" (Buffer.contents pp)
-  ) in
-  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
-  let cmdname = "preprocess" in
-  let doc = "Subcommand: Preprocess the source file.\nWarning: Intended for development of LIGO and can break at any time." in
-  (Term.ret term, Term.info ~doc cmdname)
-
-let pretty_print =
-  let f source_file syntax display_format = (
-    toplevel ~display_format @@
-      let%bind pp =
-        Compile.Of_source.pretty_print source_file (Syntax_name syntax) in
-      ok @@ Buffer.contents pp
-  ) in
-  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
-  let cmdname = "pretty-print" in
-  let doc = "Subcommand: Pretty-print the source file."
-  in (Term.ret term, Term.info ~doc cmdname)
-
-let print_cst =
-  let f source_file syntax display_format = (
-    toplevel ~display_format @@
-    let%bind pp = Compile.Of_source.pretty_print_cst source_file (Syntax_name syntax) in
-    ok @@ Format.asprintf "%s \n" (Buffer.contents pp)
-  )
-  in
-  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
-  let cmdname = "print-cst" in
-  let doc = "Subcommand: Print the CST.\nWarning: Intended for development of LIGO and can break at any time." in
-  (Term.ret term, Term.info ~doc cmdname)
-
-let print_ast =
-  let f source_file syntax display_format  = (
-    toplevel ~display_format @@
-    let%bind imperative = Compile.Utils.to_imperatve source_file syntax in
-    ok @@ Format.asprintf "%a\n" Compile.Of_imperative.pretty_print imperative
-  )
-  in
-  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
-  let cmdname = "print-ast" in
-  let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
-  (Term.ret term, Term.info ~doc cmdname)
-
-let print_ast_sugar =
-  let f source_file syntax display_format  = (
-    toplevel ~display_format @@
-    let%bind sugar = Compile.Utils.to_sugar source_file syntax in
-    ok @@ Format.asprintf "%a\n" Compile.Of_sugar.pretty_print sugar
-  )
-  in
-  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
-  let cmdname = "print-ast-sugar" in
-  let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
-  (Term.ret term, Term.info ~doc cmdname)
-
-let print_ast_core =
-  let f source_file syntax display_format  = (
-    toplevel ~display_format @@
-    let%bind core = Compile.Utils.to_core source_file syntax in
-    ok @@ Format.asprintf "%a\n" Compile.Of_core.pretty_print core
-  )
-  in
-  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
-  let cmdname = "print-ast-core" in
-  let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
-  (Term.ret term, Term.info ~doc cmdname)
-
-let print_ast_typed =
-  let f source_file syntax display_format  = (
-    toplevel ~display_format @@
-    let%bind typed,_    = Compile.Utils.type_file source_file syntax Env in
-    ok @@ Format.asprintf "%a\n" Compile.Of_typed.pretty_print typed
-  )
-  in
-  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
-  let cmdname = "print-ast-typed" in
-  let doc = "Subcommand: Print the typed AST.\n Warning: Intended for development of LIGO and can break at any time." in
-  (Term.ret term, Term.info ~doc cmdname)
-
 let optimize =
   let open Arg in
   let docv = "ENTRY_POINT" in
@@ -239,17 +136,108 @@ let optimize =
     info ~docv ~doc ["optimize"] in
   value @@ opt (some string) None info
 
+
+module Helpers = Ligo.Compile.Helpers
+module Compile = Ligo.Compile
+module Uncompile = Ligo.Uncompile
+module Run = Ligo.Run.Of_michelson
+
+let compile_file =
+  let f source_file entry_point syntax display_format disable_typecheck michelson_format =
+    return_result ~display_format (Tezos_utils.Michelson.michelson_format michelson_format) @@
+      let%bind typed,_    = Compile.Utils.type_file source_file syntax (Contract entry_point) in
+      let%bind mini_c     = Compile.Of_typed.compile typed in
+      let%bind michelson  = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in
+      Compile.Of_michelson.build_contract ~disable_typecheck michelson
+  in
+  let term =
+    Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format $ disable_michelson_typechecking $ michelson_code_format) in
+  let cmdname = "compile-contract" in
+  let doc = "Subcommand: Compile a contract." in
+  (Term.ret term , Term.info ~doc cmdname)
+
+let preprocess =
+  let f source_file syntax display_format =
+    return_result ~display_format (Parser.Formatter.ppx_format) @@
+      Compile.Of_source.preprocess source_file (Syntax_name syntax)
+  in
+  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
+  let cmdname = "preprocess" in
+  let doc = "Subcommand: Preprocess the source file.\nWarning: Intended for development of LIGO and can break at any time." in
+  (Term.ret term, Term.info ~doc cmdname)
+
+let pretty_print =
+  let f source_file syntax display_format =
+    return_result ~display_format (Parser.Formatter.ppx_format) @@
+        Compile.Of_source.pretty_print source_file (Syntax_name syntax)
+  in
+  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
+  let cmdname = "pretty-print" in
+  let doc = "Subcommand: Pretty-print the source file."
+  in (Term.ret term, Term.info ~doc cmdname)
+
+let print_cst =
+  let f source_file syntax display_format =
+    return_result ~display_format (Parser.Formatter.ppx_format) @@
+      Compile.Of_source.pretty_print_cst source_file (Syntax_name syntax)
+  in
+  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
+  let cmdname = "print-cst" in
+  let doc = "Subcommand: Print the CST.\nWarning: Intended for development of LIGO and can break at any time." in
+  (Term.ret term, Term.info ~doc cmdname)
+
+let print_ast =
+  let f source_file syntax display_format  =
+    return_result ~display_format (Ast_imperative.Formatter.program_format) @@
+      Compile.Utils.to_imperatve source_file syntax
+  in
+  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
+  let cmdname = "print-ast" in
+  let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
+  (Term.ret term, Term.info ~doc cmdname)
+
+ 
+let print_ast_sugar =
+  let f source_file syntax display_format  =
+    return_result ~display_format (Ast_sugar.Formatter.program_format) @@
+      Compile.Utils.to_sugar source_file syntax
+  in
+  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
+  let cmdname = "print-ast-sugar" in
+  let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
+  (Term.ret term, Term.info ~doc cmdname)
+
+let print_ast_core =
+  let f source_file syntax display_format  =
+    return_result ~display_format (Ast_core.Formatter.program_format) @@
+      Compile.Utils.to_core source_file syntax
+  in
+  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
+  let cmdname = "print-ast-core" in
+  let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in
+  (Term.ret term, Term.info ~doc cmdname) 
+
+let print_ast_typed =
+  let f source_file syntax display_format =
+    return_result ~display_format (Ast_typed.Formatter.program_format) @@
+      let%bind typed,_    = Compile.Utils.type_file source_file syntax Env in
+      ok typed
+  in
+  let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
+  let cmdname = "print-ast-typed" in
+  let doc = "Subcommand: Print the typed AST.\n Warning: Intended for development of LIGO and can break at any time." in
+  (Term.ret term, Term.info ~doc cmdname)
+
 let print_mini_c =
-  let f source_file syntax display_format optimize = (
+  let f source_file syntax display_format optimize =
-    toplevel ~display_format @@
+    return_result ~display_format (Mini_c.Formatter.program_format) @@
       let%bind typed,_    = Compile.Utils.type_file source_file syntax Env in
       let%bind mini_c     = Compile.Of_typed.compile typed in
       match optimize with
-    | None -> ok @@ Format.asprintf "%a\n" Compile.Of_mini_c.pretty_print mini_c
+        | None -> ok @@ Mini_c.Formatter.Raw mini_c
         | Some entry_point ->
-      let%bind mini_c = Compile.Of_mini_c.aggregate_contract mini_c entry_point in
+          let%bind o = Compile.Of_mini_c.aggregate_contract mini_c entry_point in
-      ok @@ Format.asprintf "%a\n" Mini_c.PP.expression mini_c
+          ok @@ Mini_c.Formatter.Optimized o
-  )
   in
   let term = Term.(const f $ source_file 0 $ syntax $ display_format $ optimize) in
   let cmdname = "print-mini-c" in
@@ -258,10 +246,11 @@ let print_mini_c =
 
 let measure_contract =
   let f source_file entry_point syntax display_format =
-    toplevel ~display_format @@
+    let value =
       let%bind contract   = Compile.Utils.compile_file source_file syntax entry_point in
-    let open Tezos_utils in
+      ok @@ Tezos_utils.Michelson.measure contract in
-    ok @@ Format.asprintf "%d bytes\n" (Michelson.measure contract)
+    let format = Display.bind_format Formatter.contract_size_format Main.Formatter.error_format in
+    toplevel ~display_format (Display.Displayable { value ; format }) (returned_value value)
   in
   let term =
     Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format) in
@@ -271,7 +260,7 @@ let measure_contract =
 
 let compile_parameter =
   let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format =
-    toplevel ~display_format @@
+    return_result ~display_format (Tezos_utils.Michelson.michelson_format michelson_format) @@
       let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
       let%bind mini_c_prg      = Compile.Of_typed.compile typed_prg in
       let%bind michelson_prg   = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
@@ -286,8 +275,7 @@ let compile_parameter =
       let%bind ()               = Compile.Of_typed.assert_equal_contract_type Check_parameter entry_point typed_prg typed_param in
       let%bind ()               = Compile.Of_michelson.assert_equal_contract_type Check_parameter michelson_prg compiled_param in
       let%bind options          = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
-    let%bind value            = Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty in
+      Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty
-    ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value
     in
   let term =
     Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format $ michelson_code_format) in
@@ -297,7 +285,7 @@ let compile_parameter =
 
 let interpret =
   let f expression init_file syntax amount balance sender source predecessor_timestamp display_format =
-    toplevel ~display_format @@
+    return_result ~display_format (Uncompile.Formatter.expression_format) @@
       let%bind (decl_list,state,env) = match init_file with
         | Some init_file ->
           let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in
@@ -311,13 +299,7 @@ let interpret =
       let%bind compiled_exp   = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in
       let%bind options        = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
       let%bind runres         = Run.run_expression ~options compiled_exp.expr compiled_exp.expr_ty in
-    match runres with
+      Uncompile.uncompile_expression typed_exp.type_expression runres
-      | Fail fail_res ->
-        let%bind failstring = Run.failwith_to_string fail_res in
-        ok @@ Format.asprintf "%s" failstring
-      | Success value' ->
-        let%bind core_output = Uncompile.uncompile_expression typed_exp.type_expression value' in
-        ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
   in
   let term =
     Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format ) in
@@ -327,10 +309,9 @@ let interpret =
 
 let temp_ligo_interpreter =
   let f source_file syntax display_format =
-    toplevel ~display_format @@
+    return_result ~display_format (Ligo_interpreter.Formatter.program_format) @@
       let%bind typed,_    = Compile.Utils.type_file source_file syntax Env in
-    let%bind res = Compile.Of_typed.some_interpret typed in
+      Compile.Of_typed.some_interpret typed
-    ok @@ Format.asprintf "%s\n" res
   in
   let term =
     Term.(const f $ source_file 0 $ syntax $ display_format ) in
@@ -340,7 +321,7 @@ let temp_ligo_interpreter =
 
 let compile_storage =
   let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format =
-    toplevel ~display_format @@
+    return_result ~display_format (Tezos_utils.Michelson.michelson_format michelson_format) @@
       let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
       let%bind mini_c_prg      = Compile.Of_typed.compile typed_prg in
       let%bind michelson_prg   = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
@@ -355,9 +336,7 @@ let compile_storage =
       let%bind ()               = Compile.Of_typed.assert_equal_contract_type Check_storage entry_point typed_prg typed_param in
       let%bind ()               = Compile.Of_michelson.assert_equal_contract_type Check_storage michelson_prg compiled_param in
       let%bind options          = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
-    let%bind value            = Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty in
+      Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty in
-    ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value
-  in
   let term =
     Term.(const f $ source_file 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format $ michelson_code_format) in
   let cmdname = "compile-storage" in
@@ -366,7 +345,7 @@ let compile_storage =
 
 let dry_run =
   let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format =
-    toplevel ~display_format @@
+    return_result ~display_format (Uncompile.Formatter.expression_format) @@
       let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
       let      env             = Ast_typed.program_environment Environment.default typed_prg in
       let%bind mini_c_prg      = Compile.Of_typed.compile typed_prg in
@@ -380,13 +359,7 @@ let dry_run =
 
       let%bind options           = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
       let%bind runres  = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in
-    match runres with
+      Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres
-      | Fail fail_res ->
-        let%bind failstring = Run.failwith_to_string fail_res in
-        ok @@ Format.asprintf "%s" failstring
-      | Success michelson_output ->
-        let%bind core_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in
-        ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
     in
   let term =
     Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@@ -396,7 +369,7 @@ let dry_run =
 
 let run_function =
   let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format =
-    toplevel ~display_format @@
+    return_result ~display_format (Uncompile.Formatter.expression_format) @@
       let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in
       let      env             = Ast_typed.program_environment Environment.default typed_prg in
       let%bind mini_c_prg      = Compile.Of_typed.compile typed_prg in
@@ -413,13 +386,7 @@ let run_function =
       let%bind michelson        = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in
       let%bind options          = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
       let%bind runres           = Run.run_expression ~options michelson.expr michelson.expr_ty in
-    match runres with
+      Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres
-      | Fail fail_res ->
-        let%bind failstring = Run.failwith_to_string fail_res in
-        ok @@ Format.asprintf "%s" failstring
-      | Success michelson_output ->
-        let%bind core_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in
-        ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
     in
   let term =
     Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@@ -429,15 +396,14 @@ let run_function =
 
 let evaluate_value =
   let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format =
-    toplevel ~display_format @@
+    return_result ~display_format Uncompile.Formatter.expression_format @@
       let%bind typed_prg,_ = Compile.Utils.type_file source_file syntax Env in
       let%bind mini_c      = Compile.Of_typed.compile typed_prg in
-    let%bind (exp,_)           = Mini_c.get_entry mini_c entry_point in
+      let%bind (exp,_)     = trace_option Main_errors.entrypoint_not_found @@ Mini_c.get_entry mini_c entry_point in
       let%bind compiled    = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
       let%bind options     = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
-    let%bind michelson_output  = Run.run_no_failwith ~options compiled.expr compiled.expr_ty in
+      let%bind runres      = Run.run_expression ~options compiled.expr compiled.expr_ty in
-    let%bind core_output       = Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point michelson_output in
+      Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point runres
-    ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
     in
   let term =
     Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@@ -447,12 +413,11 @@ let evaluate_value =
 
 let compile_expression =
   let f expression syntax display_format michelson_format =
-    toplevel ~display_format @@
+    return_result ~display_format (Tezos_utils.Michelson.michelson_format michelson_format) @@
       let env = Environment.default in
       let state = Typer.Solver.initial_state in
       let%bind compiled_exp  = Compile.Utils.compile_expression None syntax expression env state in
-    let%bind value         = Run.evaluate_expression compiled_exp.expr compiled_exp.expr_ty in
+      Run.evaluate_expression compiled_exp.expr compiled_exp.expr_ty
-    ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value
     in
   let term =
     Term.(const f $ expression "" 1 $ req_syntax 0 $ display_format $ michelson_code_format) in
@@ -461,7 +426,10 @@ let compile_expression =
   (Term.ret term , Term.info ~doc cmdname)
 
 let dump_changelog =
-  let f display_format = toplevel ~display_format @@ (ok @@ [%blob "../../CHANGELOG.md"]) in
+  let f display_format =
+    let value = [%blob "../../CHANGELOG.md"] in
+    let format = Formatter.changelog_format in
+    toplevel ~display_format (Display.Displayable {value ; format}) (returned_value (ok ())) in
   let term =
     Term.(const f $ display_format) in
   let cmdname = "changelog" in
@@ -469,14 +437,14 @@ let dump_changelog =
   (Term.ret term , Term.info ~doc cmdname)
 
 let list_declarations =
-  let f source_file syntax =
+  let f source_file syntax display_format =
-    toplevel ~display_format:(`Human_readable) @@
+    return_result ~display_format Formatter.declarations_format @@
         let%bind core_prg     = Compile.Utils.to_core source_file syntax in
-    let json_decl = List.map (fun decl -> `String decl) @@ Compile.Of_core.list_declarations core_prg in
+        let declarations = Compile.Of_core.list_declarations core_prg in
-    ok @@ J.to_string @@ `Assoc [ ("source_file", `String source_file) ; ("declarations", `List json_decl) ]
+        ok (source_file, declarations)
   in
   let term =
-    Term.(const f $ source_file 0 $ syntax ) in
+    Term.(const f $ source_file 0 $ syntax $ display_format ) in
   let cmdname = "list-declarations" in
   let doc = "Subcommand: List all the top-level declarations." in
   (Term.ret term , Term.info ~doc cmdname)

src/bin/cli_helpers.ml

@@ -1,23 +1,23 @@
 open Cmdliner
-open Trace
 open Main.Display
 
-let error_suggest: string = "\n If you're not sure how to fix this error, you can
+let returned_value : (_,_) result -> unit -> unit Term.ret = 
- do one of the following:
+  fun v () -> match v with
+  | Ok _ -> `Ok ()
+  | Error _ -> `Error (false, "error")
 
-* Visit our documentation: https://ligolang.org/docs/intro/introduction
+let toplevel : display_format:ex_display_format -> displayable -> (unit -> unit Term.ret) -> unit Term.ret =
-* Ask a question on our Discord: https://discord.gg/9rhYaEt
+  fun ~display_format disp return ->
-* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
+  let (Ex_display_format t) = display_format in
-* Check the changelog by running 'ligo changelog'\n"
+  let as_str : string =
+    match t with
+    | Human_readable -> convert ~display_format:t disp ;
+    | Dev -> convert ~display_format:t disp ;
+    | Json -> Yojson.Basic.to_string @@ convert ~display_format:t disp in
+  Format.printf "%s\n" as_str ;
+  return ()
 
-let toplevel ~(display_format : display_format) (x : string result) : unit Term.ret =
+let return_result : display_format:ex_display_format -> 'value format -> ('value, Main_errors.Types.all) result -> unit Term.ret =
-  match x with
+  fun ~display_format value_format value ->
-  | Ok _ -> Format.printf "%a%!" (formatted_string_result_pp display_format) x;
+    let format = Display.bind_format value_format Main.Formatter.error_format in
-            `Ok ()
+    toplevel ~display_format (Display.Displayable {value ; format}) (returned_value value)
-  | Error _ ->
-    begin
-    match display_format with 
-    | `Human_readable -> print_string error_suggest ;
-    | _ -> () 
-    end ;       
-    `Error (false, Format.asprintf "%a%!" (formatted_string_result_pp display_format) x)

src/bin/cli_helpers.mli

@@ -1,4 +1,6 @@
 open Cmdliner
-open Trace
+open Display
 
-val toplevel : display_format : Main.Display.display_format -> string result -> unit Term.ret
+val toplevel : display_format:ex_display_format -> displayable -> (unit -> unit Term.ret) -> unit Term.ret
+val returned_value : (_,_) Trace.result -> unit -> unit Term.ret
+val return_result : display_format:ex_display_format -> 'value format -> ('value, Main_errors.Types.all) result -> unit Term.ret

src/bin/dune

@@ -5,7 +5,7 @@
     cmdliner
     ligo
   )
-  (modules cli cli_helpers version)
+  (modules cli cli_helpers formatter version)
   (preprocess
     (pps ppx_let ppx_blob bisect_ppx --conditional)
   )

src/bin/expect_tests/code_insertion.ml

@@ -8,7 +8,9 @@ let bad_contract basename =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_insertion_1.ligo" ; "main" ] ;
   [%expect{|
-    ligo: generated Michelson contract failed to typecheck: bad contract type
+    ligo: error
+    generated Michelson contract failed to typecheck : bad contract type
+    code:
      { parameter nat ;
       storage nat ;
       code { DUP ;
@@ -19,8 +21,8 @@ let%expect_test _ =
              PAIR ;
              DIP { DROP } } }
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -30,11 +32,13 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_insertion_2.ligo" ; "main" ] ;
   [%expect{|
-    ligo: in file "bad_michelson_insertion_2.ligo", line 5, characters 32-40. different kinds:  {"a":"nat","b":"( nat * nat )"}
+    ligo: error
+    in file "bad_michelson_insertion_2.ligo", line 3, character 0 to line 5, character 41
+    Constant declaration 'main'
+    Bad types: expected nat got ( nat * nat )
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt

src/bin/expect_tests/contract_tests.ml

@@ -29,11 +29,17 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ;
   [%expect {|
-    ligo: different kinds:  {"a":"record[card_patterns -> (type_operator: Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n       cards -> (type_operator: Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n       next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] ,\n    Sell_single -> record[card_to_sell -> nat] ,\n    Transfer_single -> record[card_to_transfer -> nat ,\n                              destination -> address]]"}
+    ligo: error
+    Provided storage type does not match contract storage type
+    Bad types: expected record[card_patterns -> (type_operator: Map (nat,record[coefficient -> mutez , quantity -> nat])) ,
+                               cards -> (type_operator: Map (nat,record[card_owner -> address , card_pattern -> nat])) ,
+                               next_id -> nat] got sum[Buy_single -> record[card_to_buy -> nat] ,
+                                                       Sell_single -> record[card_to_sell -> nat] ,
+                                                       Transfer_single -> record[card_to_transfer -> nat ,
+                                                                        destination -> address]]
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -42,11 +48,17 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ;
   [%expect {|
-    ligo: different kinds:  {"a":"sum[Buy_single -> record[card_to_buy -> nat] ,\n    Sell_single -> record[card_to_sell -> nat] ,\n    Transfer_single -> record[card_to_transfer -> nat ,\n                              destination -> address]]","b":"record[card_patterns -> (type_operator: Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n       cards -> (type_operator: Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n       next_id -> nat]"}
+    ligo: error
+    Provided parameter type does not match contract parameter type
+    Bad types: expected sum[Buy_single -> record[card_to_buy -> nat] ,
+                            Sell_single -> record[card_to_sell -> nat] ,
+                            Transfer_single -> record[card_to_transfer -> nat ,
+                                                      destination -> address]] got record[card_patterns -> (type_operator: Map (nat,record[coefficient -> mutez , quantity -> nat])) ,
+                                                                        cards -> (type_operator: Map (nat,record[card_owner -> address , card_pattern -> nat])) ,
+                                                                        next_id -> nat]
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1321,10 +1333,12 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; contract "bad_type_operator.ligo" ; "main" ] ;
   [%expect {|
-    ligo: bad type operator (type_operator: Map (binding)):
+    ligo: error
+    in file "bad_type_operator.ligo", line 4, characters 16-29
+    unrecognized type operator (type_operator: Map (binding))
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1334,11 +1348,12 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; contract "bad_address_format.religo" ; "main" ] ;
   [%expect {|
-    ligo: in file "bad_address_format.religo", line 2, characters 26-48. Badly formatted literal: @"KT1badaddr" {"location":"in file \"bad_address_format.religo\", line 2, characters 26-48"}
+    ligo: error
+    in file "bad_address_format.religo", line 2, characters 26-48
+    Badly formatted literal: @"KT1badaddr"
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1348,11 +1363,12 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; contract "bad_timestamp.ligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "bad_timestamp.ligo", line 7, characters 30-44. Badly formatted timestamp "badtimestamp":  {"location":"in file \"bad_timestamp.ligo\", line 7, characters 30-44"}
+    ligo: error
+    in file "bad_timestamp.ligo", line 7, characters 30-44
+    Badly formatted timestamp 'badtimestamp'
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1385,10 +1401,11 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; bad_contract "self_in_lambda.mligo" ; "main" ] ;
   [%expect {|
-    ligo: Wrong SELF_ADDRESS location: SELF_ADDRESS is only allowed at top-level
+    ligo: error
+    SELF_ADDRESS is only allowed at top-level
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1410,10 +1427,13 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; bad_contract "long_sum_type_names.ligo" ; "main" ] ;
   [%expect {|
-    ligo: Too long constructor 'Incrementttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt': names length is limited to 32 (tezos limitation)
+    ligo: error
+    in file "long_sum_type_names.ligo", line 2, character 2 to line 4, character 18
+    Too long constructor 'Incrementttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt'
+    names length are limited to 32 (tezos limitation)
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1428,11 +1448,15 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; bad_contract "redundant_constructors.mligo" ; "main" ] ;
   [%expect {|
-    ligo: redundant constructor:  {"constructor":"Add","environment":"- E[]\tT[union_a -> sum[Add -> int , Remove -> int]\nbool -> sum[false -> unit , true -> unit]]"}
+    ligo: error
+    in file "redundant_constructors.mligo", line 7, character 2 to line 9, character 15
+    Redundant constructor:
+    Add
+    - Env:[]	Type env:[union_a -> sum[Add -> int , Remove -> int]
+    bool -> sum[false -> unit , true -> unit]]
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1442,11 +1466,14 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ;
   [%expect {|
-ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return\n                let rhs#2 = #P in\n                let p = rhs#2.0 in\n                let s = rhs#2.1 in\n                ( LIST_EMPTY() : (type_operator: list(operation)) , store ) ,\n                NONE() : (type_operator: option(key_hash)) ,\n                300000000mutez ,\n                \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
+ligo: error
+in file "create_contract_toplevel.mligo", line 3, characters 0-3
+Constant declaration 'main'
+in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8
+Free variable 'store' is not allowed in CREATE_CONTRACT lambda
 
 
- If you're not sure how to fix this error, you can
+If you're not sure how to fix this error, you can do one of the following:
- do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1455,11 +1482,14 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8,
 
   run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ;
   [%expect {|
-ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return\n                let rhs#2 = #P in\n                let p = rhs#2.0 in\n                let s = rhs#2.1 in\n                ( LIST_EMPTY() : (type_operator: list(operation)) , a ) ,\n                NONE() : (type_operator: option(key_hash)) ,\n                300000000mutez ,\n                1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
+ligo: error
+in file "create_contract_var.mligo", line 5, characters 0-3
+Constant declaration 'main'
+in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5
+Free variable 'a' is not allowed in CREATE_CONTRACT lambda
 
 
- If you're not sure how to fix this error, you can
+If you're not sure how to fix this error, you can do one of the following:
- do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1468,11 +1498,13 @@ ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, char
 
   run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_no_inline.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "create_contract_no_inline.mligo", line 3, characters 40-46. unbound type variable:  {"variable":"return","location":"in file \"create_contract_no_inline.mligo\", line 3, characters 40-46","in":"- E[foo -> int]\tT[bool -> sum[false -> unit , true -> unit]]","did_you_mean":"no suggestion"}
+    ligo: error
+    in file "create_contract_no_inline.mligo", line 3, characters 40-46
+    Unbound type variable 'return'
+    - Env:[foo -> int]	Type env:[bool -> sum[false -> unit , true -> unit]]
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1522,11 +1554,14 @@ ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, char
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; bad_contract "self_type_annotation.ligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "self_type_annotation.ligo", line 8, characters 41-64. bad self type: expected (type_operator: Contract (int)) but got (type_operator: Contract (nat)) {"location":"in file \"self_type_annotation.ligo\", line 8, characters 41-64"}
+    ligo: error
+    in file "self_type_annotation.ligo", line 8, characters 41-64
+    Bad self type
+    expected (type_operator: Contract (int))
+    got (type_operator: Contract (nat))
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1549,11 +1584,13 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "bad_contract.mligo", line 4, characters 0-3. badly typed contract: unexpected entrypoint type {"location":"in file \"bad_contract.mligo\", line 4, characters 0-3","entrypoint":"main","entrypoint_type":"( nat * int ) -> int"}
+    ligo: error
+    in file "bad_contract.mligo", line 4, characters 0-3
+    Badly typed contract:
+    unexpected entrypoint type ( nat * int ) -> int
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1562,11 +1599,13 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract2.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "bad_contract2.mligo", line 5, characters 0-3. bad return type: expected (type_operator: list(operation)), got string {"location":"in file \"bad_contract2.mligo\", line 5, characters 0-3","entrypoint":"main"}
+    ligo: error
+    in file "bad_contract2.mligo", line 5, characters 0-3
+    Badly typed contract:
+    expected (type_operator: list(operation)) but got string
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1575,11 +1614,15 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract3.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "bad_contract3.mligo", line 5, characters 0-3. badly typed contract: expected {int} and {string} to be the same in the entrypoint type {"location":"in file \"bad_contract3.mligo\", line 5, characters 0-3","entrypoint":"main","entrypoint_type":"( nat * int ) -> ( (type_operator: list(operation)) * string )"}
+    ligo: error
+    in file "bad_contract3.mligo", line 5, characters 0-3
+    Badly typed contract main:
+    expected storage type as right member of a pair in the input and output, but got:
+    - int in the input
+    - string in the output
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1631,11 +1674,13 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; bad_contract "self_bad_entrypoint_format.ligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "self_bad_entrypoint_format.ligo", line 8, characters 52-58. bad entrypoint format: entrypoint "Toto" is badly formatted. We expect "%bar" for entrypoint Bar and "%default" when no entrypoint used {"location":"in file \"self_bad_entrypoint_format.ligo\", line 8, characters 52-58"}
+    ligo: error
+    in file "self_bad_entrypoint_format.ligo", line 8, characters 52-58
+    Bad entrypoint format 'Toto'
+    We expect '%bar' for entrypoint Bar and '%default' when no entrypoint used
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1644,11 +1689,12 @@ let%expect_test _ =
 
   run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_1.religo"; "main"];
   [%expect {|
-    ligo: It looks like you have nested a big map inside another big map. This is not supported. :  {}
+    ligo: error
+    in file "nested_bigmap_1.religo", line 1, characters 11-29
+    It looks like you have nested a big map inside another big map, this is not supported
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1657,11 +1703,12 @@ let%expect_test _ =
 
   run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_2.religo"; "main"];
   [%expect {|
-    ligo: It looks like you have nested a big map inside another big map. This is not supported. :  {}
+    ligo: error
+    in file "nested_bigmap_2.religo", line 2, characters 29-50
+    It looks like you have nested a big map inside another big map, this is not supported
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1670,11 +1717,12 @@ let%expect_test _ =
   
   run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_3.religo"; "main"];
   [%expect {|
-    ligo: It looks like you have nested a big map inside another big map. This is not supported. :  {}
+    ligo: error
+    in file "nested_bigmap_3.religo", line 1, characters 11-29
+    It looks like you have nested a big map inside another big map, this is not supported
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -1683,11 +1731,12 @@ let%expect_test _ =
 
   run_ligo_bad ["compile-contract"; bad_contract "nested_bigmap_4.religo"; "main"];
   [%expect {|
-    ligo: It looks like you have nested a big map inside another big map. This is not supported. :  {}
+    ligo: error
+    in file "nested_bigmap_4.religo", line 2, characters 39-60
+    It looks like you have nested a big map inside another big map, this is not supported
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt

src/bin/expect_tests/error_messages_tests.ml

@@ -3,18 +3,18 @@ open Cli_expect
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/gitlab_111.religo" ; "main" ] ;
   [%expect {|
-    ligo: : Parse error in file "gitlab_111.religo", line 2, characters 0-3 at "let", after "=":
+    ligo: error
+    Parse error in file "gitlab_111.religo", line 2, characters 0-3 at "let", after "=":
     This is an incorrect let binding.
     -
     Examples of correct let bindings:
     let a: int = 4;
     let (a: int, b: int) = (1, 2);
     let func = (a: int, b: int) => a + b;
-           {}
 
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -23,13 +23,13 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/missing_rpar.religo" ; "main" ] ;
   [%expect {|
-    ligo: : Parse error in file "missing_rpar.religo", line 5, characters 0-3 at "let", after "m":
+    ligo: error
+    Parse error in file "missing_rpar.religo", line 5, characters 0-3 at "let", after "m":
     Missing `)`.
-           {}
 
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt

src/bin/expect_tests/failwith_tests.ml

@@ -12,7 +12,7 @@ let%expect_test _ =
 
   run_ligo_good [ "run-function" ; contract "failwith.ligo" ; "failer" ; "1" ; "--format=json" ] ;
   [%expect {|
-    {"status":"ok","content":"failwith(42)"} |}];
+    {"value":null,"failure":"failwith(42)"} |}];
 
 
   run_ligo_good [ "dry-run" ; contract "subtle_nontail_fail.mligo" ; "main" ; "()" ; "()" ] ;

src/bin/expect_tests/lexer_tests.ml

@@ -3,14 +3,14 @@ open Cli_expect
 let%expect_test _ =
     run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.ligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "broken_string.ligo", line 1, characters 18-19:
+ligo: error
-      The string starting here is interrupted by a line break.
+Lexical error in file "broken_string.ligo", line 1, characters 18-19:
-      Hint: Remove the break, close the string before or insert a backslash.
+The string starting here is interrupted by a line break.
-       {}
+Hint: Remove the break, close the string before or insert a backslash.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -20,14 +20,14 @@ ligo: : Lexical error in file "broken_string.ligo", line 1, characters 18-19:
 
     run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.mligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "broken_string.mligo", line 1, characters 8-9:
+ligo: error
-      The string starting here is interrupted by a line break.
+Lexical error in file "broken_string.mligo", line 1, characters 8-9:
-      Hint: Remove the break, close the string before or insert a backslash.
+The string starting here is interrupted by a line break.
-       {}
+Hint: Remove the break, close the string before or insert a backslash.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -37,14 +37,14 @@ ligo: : Lexical error in file "broken_string.mligo", line 1, characters 8-9:
 
  run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.religo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "broken_string.religo", line 1, characters 8-9:
+ligo: error
-      The string starting here is interrupted by a line break.
+Lexical error in file "broken_string.religo", line 1, characters 8-9:
-      Hint: Remove the break, close the string before or insert a backslash.
+The string starting here is interrupted by a line break.
-       {}
+Hint: Remove the break, close the string before or insert a backslash.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -54,14 +54,14 @@ ligo: : Lexical error in file "broken_string.religo", line 1, characters 8-9:
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.ligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "negative_byte_sequence.ligo", line 1, characters 18-31:
+ligo: error
-      Negative byte sequence.
+Lexical error in file "negative_byte_sequence.ligo", line 1, characters 18-31:
-      Hint: Remove the leading minus sign.
+Negative byte sequence.
-       {}
+Hint: Remove the leading minus sign.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -71,14 +71,14 @@ ligo: : Lexical error in file "negative_byte_sequence.ligo", line 1, characters
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.mligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "negative_byte_sequence.mligo", line 1, characters 8-21:
+ligo: error
-      Negative byte sequence.
+Lexical error in file "negative_byte_sequence.mligo", line 1, characters 8-21:
-      Hint: Remove the leading minus sign.
+Negative byte sequence.
-       {}
+Hint: Remove the leading minus sign.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -88,14 +88,14 @@ ligo: : Lexical error in file "negative_byte_sequence.mligo", line 1, characters
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.religo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "negative_byte_sequence.religo", line 1, characters 8-21:
+ligo: error
-      Negative byte sequence.
+Lexical error in file "negative_byte_sequence.religo", line 1, characters 8-21:
-      Hint: Remove the leading minus sign.
+Negative byte sequence.
-       {}
+Hint: Remove the leading minus sign.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -124,14 +124,14 @@ ligo: : Lexical error in file "reserved_name.ligo", line 1, characters 4-13:
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/reserved_name.religo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "reserved_name.religo", line 1, characters 4-7:
+ligo: error
-      Reserved name: "end".
+Lexical error in file "reserved_name.religo", line 1, characters 4-7:
-      Hint: Change the name.
+Reserved name: "end".
-       {}
+Hint: Change the name.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -141,14 +141,14 @@ ligo: : Lexical error in file "reserved_name.religo", line 1, characters 4-7:
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/reserved_name.mligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "reserved_name.mligo", line 1, characters 4-10:
+ligo: error
-      Reserved name: "object".
+Lexical error in file "reserved_name.mligo", line 1, characters 4-10:
-      Hint: Change the name.
+Reserved name: "object".
-       {}
+Hint: Change the name.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -158,13 +158,13 @@ ligo: : Lexical error in file "reserved_name.mligo", line 1, characters 4-10:
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.ligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "unexpected_character.ligo", line 1, characters 18-19:
+ligo: error
-      Unexpected character '\239'.
+Lexical error in file "unexpected_character.ligo", line 1, characters 18-19:
-       {}
+Unexpected character '\239'.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -174,13 +174,13 @@ ligo: : Lexical error in file "unexpected_character.ligo", line 1, characters 18
 
  run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.mligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "unexpected_character.mligo", line 1, characters 8-9:
+ligo: error
-      Unexpected character '\239'.
+Lexical error in file "unexpected_character.mligo", line 1, characters 8-9:
-       {}
+Unexpected character '\239'.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -190,13 +190,13 @@ ligo: : Lexical error in file "unexpected_character.mligo", line 1, characters 8
 
  run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.religo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "unexpected_character.religo", line 1, characters 8-9:
+ligo: error
-      Unexpected character '\239'.
+Lexical error in file "unexpected_character.religo", line 1, characters 8-9:
-       {}
+Unexpected character '\239'.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -206,13 +206,13 @@ ligo: : Lexical error in file "unexpected_character.religo", line 1, characters
 
  run_ligo_bad [ "compile-contract" ; "../../test/lexer/unterminated_comment.mligo" ; "main" ] ;
   [%expect {|
-ligo: : Preprocessing error in file "../../test/lexer/unterminated_comment.mligo", line 1, characters 0-2:
+ligo: error
-      Unterminated comment.
+Preprocessing error in file "../../test/lexer/unterminated_comment.mligo", line 1, characters 0-2:
-      Hint: Close with "*)". {}
+Unterminated comment.
+Hint: Close with "*)".
 
 
- If you're not sure how to fix this error, you can
+If you're not sure how to fix this error, you can do one of the following:
- do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -222,14 +222,14 @@ ligo: : Preprocessing error in file "../../test/lexer/unterminated_comment.mligo
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.ligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "invalid_symbol.ligo", line 1, characters 17-20:
+ligo: error
-      Invalid symbol.
+Lexical error in file "invalid_symbol.ligo", line 1, characters 17-20:
-      Hint: Check the LIGO syntax you use.
+Invalid symbol.
-       {}
+Hint: Check the LIGO syntax you use.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -239,14 +239,14 @@ ligo: : Lexical error in file "invalid_symbol.ligo", line 1, characters 17-20:
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.mligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "invalid_symbol.mligo", line 1, characters 10-13:
+ligo: error
-      Invalid symbol.
+Lexical error in file "invalid_symbol.mligo", line 1, characters 10-13:
-      Hint: Check the LIGO syntax you use.
+Invalid symbol.
-       {}
+Hint: Check the LIGO syntax you use.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -256,14 +256,14 @@ ligo: : Lexical error in file "invalid_symbol.mligo", line 1, characters 10-13:
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.religo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "invalid_symbol.religo", line 1, characters 10-11:
+ligo: error
-      Invalid symbol.
+Lexical error in file "invalid_symbol.religo", line 1, characters 10-11:
-      Hint: Check the LIGO syntax you use.
+Invalid symbol.
-       {}
+Hint: Check the LIGO syntax you use.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -273,14 +273,14 @@ ligo: : Lexical error in file "invalid_symbol.religo", line 1, characters 10-11:
 
  run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.ligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "missing_break.ligo", line 1, characters 18-18:
+ligo: error
-      Missing break.
+Lexical error in file "missing_break.ligo", line 1, characters 18-18:
-      Hint: Insert some space.
+Missing break.
-       {}
+Hint: Insert some space.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -290,14 +290,14 @@ ligo: : Lexical error in file "missing_break.ligo", line 1, characters 18-18:
 
  run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.mligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "missing_break.mligo", line 1, characters 11-11:
+ligo: error
-      Missing break.
+Lexical error in file "missing_break.mligo", line 1, characters 11-11:
-      Hint: Insert some space.
+Missing break.
-       {}
+Hint: Insert some space.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -307,14 +307,14 @@ ligo: : Lexical error in file "missing_break.mligo", line 1, characters 11-11:
 
  run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.religo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "missing_break.religo", line 1, characters 11-11:
+ligo: error
-      Missing break.
+Lexical error in file "missing_break.religo", line 1, characters 11-11:
-      Hint: Insert some space.
+Missing break.
-       {}
+Hint: Insert some space.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -324,14 +324,14 @@ ligo: : Lexical error in file "missing_break.religo", line 1, characters 11-11:
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.ligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "invalid_character_in_string.ligo", line 1, characters 19-20:
+ligo: error
-      Invalid character in string.
+Lexical error in file "invalid_character_in_string.ligo", line 1, characters 19-20:
-      Hint: Remove or replace the character.
+Invalid character in string.
-       {}
+Hint: Remove or replace the character.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -341,14 +341,14 @@ ligo: : Lexical error in file "invalid_character_in_string.ligo", line 1, charac
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.mligo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "invalid_character_in_string.mligo", line 1, characters 9-10:
+ligo: error
-      Invalid character in string.
+Lexical error in file "invalid_character_in_string.mligo", line 1, characters 9-10:
-      Hint: Remove or replace the character.
+Invalid character in string.
-       {}
+Hint: Remove or replace the character.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -358,14 +358,14 @@ ligo: : Lexical error in file "invalid_character_in_string.mligo", line 1, chara
 
 run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.religo" ; "main" ] ;
   [%expect {|
-ligo: : Lexical error in file "invalid_character_in_string.religo", line 1, characters 9-10:
+ligo: error
-      Invalid character in string.
+Lexical error in file "invalid_character_in_string.religo", line 1, characters 9-10:
-      Hint: Remove or replace the character.
+Invalid character in string.
-       {}
+Hint: Remove or replace the character.
 
 
- If you're not sure how to fix this error, you can
+
- do one of the following:
+If you're not sure how to fix this error, you can do one of the following:
 
 * Visit our documentation: https://ligolang.org/docs/intro/introduction
 * Ask a question on our Discord: https://discord.gg/9rhYaEt

src/bin/expect_tests/literals.ml

@@ -7,11 +7,12 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ;
   [%expect {|
-    ligo: in file "", line 0, characters 0-33. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 0-33"}
+    ligo: error
+    in file "", line 0, characters 0-33
+    Badly formatted literal: Signature thisisnotasignature
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -25,11 +26,12 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad ["interpret" ; "(\"thisisnotapublickey\":key)" ; "--syntax=pascaligo"] ;
   [%expect {|
-    ligo: in file "", line 0, characters 0-27. Badly formatted literal: key thisisnotapublickey {"location":"in file \"\", line 0, characters 0-27"}
+    ligo: error
+    in file "", line 0, characters 0-27
+    Badly formatted literal: key thisisnotapublickey
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt

src/bin/expect_tests/michelson_converter.ml

@@ -8,10 +8,13 @@ let bad_contract basename =
 let%expect_test _ =
   run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_no_annotation.mligo") ; "l4"] ;
   [%expect {|
-    ligo: in file "michelson_converter_no_annotation.mligo", line 4, characters 9-39. can't retrieve type declaration order in the converted record, you need to annotate it
+    ligo: error
+    in file "michelson_converter_no_annotation.mligo", line 4, characters 9-39
+    Constant declaration 'l4'
+    Can't retrieve type declaration order in the converted record, you need to annotate it
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -20,10 +23,14 @@ let%expect_test _ =
 
   run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_short_record.mligo") ; "l1"] ;
   [%expect {|
-    ligo: in file "michelson_converter_short_record.mligo", line 4, characters 9-44. converted record must have at least two elements
+    ligo: error
+    in file "michelson_converter_short_record.mligo", line 4, characters 9-44
+    Constant declaration 'l1'
+    in file "michelson_converter_short_record.mligo", line 1, characters 10-23
+    Converted record must have at least two elements
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt

src/bin/expect_tests/michelson_or_tests.ml

@@ -29,11 +29,14 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_or.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "bad_michelson_or.mligo", line 6, characters 12-27. michelson_or types must be annotated:  {"constructor":"M_right","location":"in file \"bad_michelson_or.mligo\", line 6, characters 12-27"}
+    ligo: error
+    in file "bad_michelson_or.mligo", line 5, characters 0-3
+    Constant declaration 'main'
+    in file "bad_michelson_or.mligo", line 6, characters 12-27
+    michelson_or contructor M_right must be annotated with a sum type
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt

src/bin/expect_tests/misc_cli_commands.ml

@@ -13,10 +13,46 @@ let%expect_test _ =
 (* list-declarations *)
 let%expect_test _ =
   run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.ligo" ] ;
-  [%expect {| {"source_file":"../../test/contracts/loop.ligo","declarations":["inner_capture_in_conditional_block","dummy","nested_for_collection_local_var","nested_for_collection","for_collection_map_k","for_collection_map_kv","for_collection_empty","for_collection_with_patches","for_collection_comp_with_acc","for_collection_proc_call","for_collection_rhs_capture","for_collection_if_and_local_var","for_collection_set","for_collection_list","for_sum_step","for_sum","while_sum","counter"]} |} ];
+  [%expect {|
+    ../../test/contracts/loop.ligo declarations:
+    inner_capture_in_conditional_block
+    dummy
+    nested_for_collection_local_var
+    nested_for_collection
+    for_collection_map_k
+    for_collection_map_kv
+    for_collection_empty
+    for_collection_with_patches
+    for_collection_comp_with_acc
+    for_collection_proc_call
+    for_collection_rhs_capture
+    for_collection_if_and_local_var
+    for_collection_set
+    for_collection_list
+    for_sum_step
+    for_sum
+    while_sum
+    counter |} ];
+
+  run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.mligo" ; "--format=json" ] ;
+  [%expect {|
+    {"source_file":"../../test/contracts/loop.mligo","declarations":["counter_nest","aux_nest","counter","counter_simple","aux_simple"]} |} ];
+
 
   run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.mligo" ] ;
-  [%expect {| {"source_file":"../../test/contracts/loop.mligo","declarations":["counter_nest","aux_nest","counter","counter_simple","aux_simple"]} |} ];
+  [%expect {|
+    ../../test/contracts/loop.mligo declarations:
+    counter_nest
+    aux_nest
+    counter
+    counter_simple
+    aux_simple |} ];
 
   run_ligo_good [ "list-declarations" ; "../../test/contracts/loop.religo" ] ;
-  [%expect {| {"source_file":"../../test/contracts/loop.religo","declarations":["counter_nest","aux_nest","counter","counter_simple","aux_simple"]} |} ];
+  [%expect {|
+    ../../test/contracts/loop.religo declarations:
+    counter_nest
+    aux_nest
+    counter
+    counter_simple
+    aux_simple |} ];

src/bin/expect_tests/syntax_error_tests.ml

@@ -3,12 +3,12 @@ open Cli_expect
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_syntax.ligo" ; "main" ] ;
   [%expect {|
-    ligo: : Parse error in file "error_syntax.ligo", line 1, characters 16-17 at "-", after "bar":
+    ligo: error
-          16: <syntax error> {}
+    Parse error in file "error_syntax.ligo", line 1, characters 16-17 at "-", after "bar":
+    16: <syntax error>
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -17,17 +17,18 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_arguments.religo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_function_arguments.religo", line 1, characters 14-27. : It looks like you are defining a function, however we do not
+    ligo: error
+    in file "error_function_arguments.religo", line 1, characters 14-27
+    It looks like you are defining a function, however we do not
     understand the parameters declaration.
     Examples of valid functions:
     let x = (a: string, b: int) : int => 3;
     let tuple = ((a, b): (int, int)) => a + b;
     let x = (a: string) : string => "Hello, " ++ a;
-           {"location":"in file \"error_function_arguments.religo\", line 1, characters 14-27"}
 
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt

src/bin/expect_tests/typer_error_tests.ml

@@ -3,11 +3,13 @@ open Cli_expect
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_annotation_1.mligo"; "main"];
   [%expect {|
-    ligo: in file "error_function_annotation_1.mligo", line 1, characters 0-3. different type constructors: Expected these two constant type constructors to be the same, but they're different {"a":"unit","b":"int"}
+    ligo: error
+    in file "error_function_annotation_1.mligo", line 1, characters 0-3
+    Constant declaration 'main'
+    Bad types: expected int -> unit got int -> int
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -16,11 +18,13 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_annotation_2.mligo"; "f"];
   [%expect {|
-    ligo: in file "error_function_annotation_2.mligo", line 1, characters 14-43. different kinds:  {"a":"int","b":"( int * int ) -> int"}
+    ligo: error
+    in file "error_function_annotation_2.mligo", line 1, characters 14-43
+    Constant declaration 'f'
+    Bad types: expected int got ( int * int ) -> int
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -29,11 +33,18 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_function_annotation_3.mligo"; "f"];
   [%expect {|
-    ligo: in file "error_function_annotation_3.mligo", line 6, characters 0-3. different kinds:  {"a":"( (type_operator: list(operation)) * sum[Add -> int , Sub -> int] )","b":"sum[Add -> int , Sub -> int]"}
+    ligo: error
+    in file "error_function_annotation_3.mligo", line 6, characters 0-3
+    Constant declaration 'main'
+    Bad types: expected ( int * sum[Add -> int , Sub -> int] ) -> ( (type_operator: list(operation)) *
+                                                                    sum[Add -> int ,
+                                                                        Sub -> int] ) got ( int *
+                                                                        sum[Add -> int ,
+                                                                        Sub -> int] ) -> sum[Add -> int ,
+                                                                        Sub -> int]
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -42,11 +53,12 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_no_tail_recursive_function.mligo"; "f"];
   [%expect {|
-    ligo: in file "error_no_tail_recursive_function.mligo", line 2, characters 14-21. Recursion must be achieved through tail-calls only:  {"function":"unvalid","location":"in file \"error_no_tail_recursive_function.mligo\", line 2, characters 14-21"}
+    ligo: error
+    in file "error_no_tail_recursive_function.mligo", line 2, characters 14-21
+    Recursion must be achieved through tail-calls only
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -55,10 +67,15 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_type.ligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_type.ligo", line 3, characters 18-28. Adding modulo with wrong types: Expected arguments with one of the following combinations of types: add(nat , nat) or add(int , int) or add(mutez , mutez) or add(nat , int) or add(int , nat) or add(timestamp , int) or add(int , timestamp) but got this combination instead: add(int , string)
+    ligo: error
+    in file "error_type.ligo", line 3, characters 18-28
+    Constant declaration 'foo'
+    Expected arguments with one of the following combinations of type:
+    (nat , nat) or (int , int) or (mutez , mutez) or (nat , int) or (int , nat) or (timestamp , int) or (int , timestamp)
+    but got int , string
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -67,11 +84,13 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_1.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_typer_1.mligo", line 3, characters 19-27. different type constructors: Expected these two constant type constructors to be the same, but they're different {"a":"string","b":"int"}
+    ligo: error
+    in file "error_typer_1.mligo", line 3, characters 19-27
+    Constant declaration 'foo'
+    Bad types: expected string got int
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -80,11 +99,13 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_2.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_typer_2.mligo", line 3, characters 24-39. different type constructors: Expected these two n-ary type constructors to be the same, but they're different {"a":"(type_operator: list(string))","b":"(type_operator: option(int))"}
+    ligo: error
+    in file "error_typer_2.mligo", line 3, characters 24-39
+    Constant declaration 'foo'
+    Bad types: expected (type_operator: list(string)) got (type_operator: option(int))
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -93,11 +114,14 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_3.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_typer_3.mligo", line 3, characters 34-53. tuples have different sizes: Expected these two types to be the same, but they're different (both are tuples, but with a different number of arguments) {"a":"( int * string * sum[false -> unit , true -> unit] )","b":"( int * string )"}
+    ligo: error
+    in file "error_typer_3.mligo", line 3, characters 34-53
+    Constant declaration 'foo'
+    Bad types: expected ( int * string * sum[false -> unit , true -> unit] ) got ( int *
+                                                                        string )
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -106,11 +130,18 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_4.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_typer_4.mligo", line 4, characters 17-56. different keys in records:  {"key_a":"c","key_b":"b","a":"record[a -> int , c -> sum[false -> unit , true -> unit] , d -> string]","b":"record[a -> int , b -> string , c -> sum[false -> unit , true -> unit]]"}
+    ligo: error
+    in file "error_typer_4.mligo", line 4, characters 17-56
+    Constant declaration 'foo'
+    Bad types: expected record[a -> int ,
+                               c -> sum[false -> unit , true -> unit] ,
+                               d -> string] got record[a -> int ,
+                                                       b -> string ,
+                                                       c -> sum[false -> unit ,
+                                                                true -> unit]]
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -119,11 +150,13 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_5.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_typer_5.mligo", line 1, characters 10-17. unbound type variable:  {"variable":"boolean","location":"in file \"error_typer_5.mligo\", line 1, characters 10-17","in":"- E[]\tT[bool -> sum[false -> unit , true -> unit]]","did_you_mean":"bool"}
+    ligo: error
+    in file "error_typer_5.mligo", line 1, characters 10-17
+    Unbound type variable 'boolean'
+    - Env:[]	Type env:[bool -> sum[false -> unit , true -> unit]]
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -132,11 +165,13 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_6.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_typer_6.mligo", line 1, characters 30-64. different kinds:  {"a":"string","b":"sum[false -> unit , true -> unit]"}
+    ligo: error
+    in file "error_typer_6.mligo", line 1, characters 30-64
+    Constant declaration 'foo'
+    Bad types: expected (type_operator: Map (int,string)) got (type_operator: Map (int,sum[false -> unit , true -> unit]))
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -145,11 +180,16 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_7.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_typer_7.mligo", line 4, characters 18-48. records have different sizes: Expected these two types to be the same, but they're different (both are records, but with a different number of arguments) {"a":"record[a -> int , b -> string]","b":"record[a -> int , b -> string , c -> sum[false -> unit , true -> unit]]"}
+    ligo: error
+    in file "error_typer_7.mligo", line 4, characters 17-56
+    Constant declaration 'foo'
+    Bad types: expected record[a -> int , b -> string] got record[a -> int ,
+                                                                  b -> string ,
+                                                                  c -> sum[false -> unit ,
+                                                                        true -> unit]]
 
 
-     If you're not sure how to fix this error, you can
+    If you're not sure how to fix this error, you can do one of the following:
-     do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -158,12 +198,16 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address ,
+    ligo: error
+    in file "id.mligo", line 28, characters 0-3
+    Constant declaration 'buy'
+    in file "id.mligo", line 3, character 18 to line 7, character 1
+    Expected an option but got record[controller -> address ,
                                       owner -> address ,
                                       profile -> bytes]
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -181,10 +225,11 @@ let%expect_test _ =
 
   run_ligo_bad [ "interpret" ; "Set.literal [ (1,2,3) ; (2,3,4) ]" ; "--syntax=cameligo" ] ;
   [%expect {|
-    ligo: not a comparable type: pair (use (a,(b,c)) instead of (a,b,c))
+    ligo: error
+    pair does not have a comparable structure. (hint: use (a,(b,c)) instead of (a,b,c))
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt
@@ -194,10 +239,15 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/failwith_wrong_type.ligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "failwith_wrong_type.ligo", line 2, characters 19-46. Failwith with disallowed type: Expected arguments with one of the following combinations of types: failwith(string) or failwith(nat) or failwith(int) but got this combination instead: failwith((type_operator: list(int)))
+    ligo: error
+    in file "failwith_wrong_type.ligo", line 2, characters 19-46
+    Constant declaration 'bad'
+    Expected arguments with one of the following combinations of type:
+    (string) or (nat) or (int)
+    but got (type_operator: list(int))
 
-     If you're not sure how to fix this error, you can
+
-     do one of the following:
+    If you're not sure how to fix this error, you can do one of the following:
 
     * Visit our documentation: https://ligolang.org/docs/intro/introduction
     * Ask a question on our Discord: https://discord.gg/9rhYaEt

src/bin/formatter.ml

@@ -0,0 +1,42 @@
+open Display
+
+let declarations_ppformat ~display_format f ((source_file,decls),_) =
+  match display_format with
+  | Human_readable | Dev ->
+    Format.fprintf f "%s declarations:\n" source_file ;
+    List.iter (fun decl -> Format.fprintf f "%s\n" decl) decls
+
+let declarations_jsonformat ((source_file,decls),_) : json =
+  let json_decl = List.map (fun decl -> `String decl) decls in
+  `Assoc [ ("source_file", `String source_file) ; ("declarations", `List json_decl) ]
+
+let declarations_format : 'a format = {
+  pp = declarations_ppformat;
+  to_json = declarations_jsonformat;
+}
+
+let changelog_ppformat ~display_format f changelog =
+  match display_format with
+  | Human_readable | Dev ->
+    Format.fprintf f "%s" changelog
+
+let changelog_jsonformat changelog : json =
+  `String changelog
+
+let changelog_format : 'a format = {
+  pp = changelog_ppformat;
+  to_json = changelog_jsonformat;
+}
+
+let contract_size_ppformat ~display_format f (contract_size,_) =
+  match display_format with
+  | Human_readable | Dev ->
+    Format.fprintf f "%d bytes" contract_size
+
+let contract_size_jsonformat (contract_size,_) : json =
+  `Int contract_size
+
+let contract_size_format : 'a format = {
+  pp = contract_size_ppformat;
+  to_json = contract_size_jsonformat;
+}

src/main/compile/dune

@@ -2,6 +2,7 @@
   (name compile)
   (public_name ligo.compile)
   (libraries
+    main_errors
     simple-utils
     tezos-utils
     parser

src/main/compile/helpers.ml

@@ -1,4 +1,5 @@
 open Trace
+open Main_errors
 
 type s_syntax = Syntax_name of string
 type v_syntax = PascaLIGO | CameLIGO | ReasonLIGO
@@ -10,78 +11,65 @@ let syntax_to_variant (Syntax_name syntax) source =
          ".ligo" | ".pligo" -> ok PascaLIGO
        | ".mligo"           -> ok CameLIGO
        | ".religo"          -> ok ReasonLIGO
-       | _ -> simple_fail "Cannot auto-detect the syntax.\n\
+       | ext                -> fail (syntax_auto_detection ext))
-                          Hint: Use -s <name of syntax>\n")
   | ("pascaligo" | "PascaLIGO"),   _ -> ok PascaLIGO
   | ("cameligo" | "CameLIGO"),     _ -> ok CameLIGO
   | ("reasonligo" | "ReasonLIGO"), _ -> ok ReasonLIGO
-  | _ -> simple_fail "Invalid syntax name.\n\
+  | _ -> fail (invalid_syntax syntax) 
-                     Hint: Use \"pascaligo\", \"cameligo\" \
+
-                     or \"reasonligo\".\n"
 
 let parsify_pascaligo source =
-  let%bind raw =
+  let%bind raw = trace parser_tracer @@
-    trace (simple_error "parsing") @@
     Parser.Pascaligo.parse_file source in
-  let%bind imperative =
+  let%bind imperative = trace cit_pascaligo_tracer @@
-    trace (simple_error "abstracting") @@
     Concrete_to_imperative.Pascaligo.compile_program raw
   in ok imperative
 
 let parsify_expression_pascaligo source =
-  let%bind raw =
+  let%bind raw = trace parser_tracer @@
-    trace (simple_error "parsing expression") @@
     Parser.Pascaligo.parse_expression source in
-  let%bind imperative =
+  let%bind imperative = trace cit_pascaligo_tracer @@
-    trace (simple_error "abstracting expression") @@
     Concrete_to_imperative.Pascaligo.compile_expression raw
   in ok imperative
 
 let parsify_cameligo source =
-  let%bind raw =
+  let%bind raw = trace parser_tracer @@
-    trace (simple_error "parsing") @@
     Parser.Cameligo.parse_file source in
-  let%bind imperative =
+  let%bind imperative = trace cit_cameligo_tracer @@
-    trace (simple_error "abstracting") @@
     Concrete_to_imperative.Cameligo.compile_program raw
   in ok imperative
 
 let parsify_expression_cameligo source =
-  let%bind raw =
+  let%bind raw = trace parser_tracer @@
-    trace (simple_error "parsing expression") @@
     Parser.Cameligo.parse_expression source in
-  let%bind imperative =
+  let%bind imperative = trace cit_cameligo_tracer @@
-    trace (simple_error "abstracting expression") @@
     Concrete_to_imperative.Cameligo.compile_expression raw
   in ok imperative
 
 let parsify_reasonligo source =
-  let%bind raw =
+  let%bind raw = trace parser_tracer @@
-    trace (simple_error "parsing") @@
     Parser.Reasonligo.parse_file source in
-  let%bind imperative =
+  let%bind imperative = trace cit_cameligo_tracer @@
-    trace (simple_error "abstracting") @@
     Concrete_to_imperative.Cameligo.compile_program raw
   in ok imperative
 
 let parsify_expression_reasonligo source =
-  let%bind raw =
+  let%bind raw = trace parser_tracer @@
-    trace (simple_error "parsing expression") @@
     Parser.Reasonligo.parse_expression source in
-  let%bind imperative =
+  let%bind imperative = trace cit_cameligo_tracer @@
-    trace (simple_error "abstracting expression") @@
     Concrete_to_imperative.Cameligo.compile_expression raw
   in ok imperative
 
-let parsify syntax source =
+let parsify syntax source : (Ast_imperative.program, _) Trace.result =
   let%bind parsify =
     match syntax with
       PascaLIGO  -> ok parsify_pascaligo
     | CameLIGO   -> ok parsify_cameligo
     | ReasonLIGO -> ok parsify_reasonligo in
   let%bind parsified = parsify source in
-  let%bind applied = Self_ast_imperative.all_program parsified
+  let%bind applied = trace self_ast_imperative_tracer @@
-  in ok applied
+    Self_ast_imperative.all_program parsified in
+  ok applied
 
 let parsify_expression syntax source =
   let%bind parsify = match syntax with
@@ -89,33 +77,28 @@ let parsify_expression syntax source =
   | CameLIGO   -> ok parsify_expression_cameligo
   | ReasonLIGO -> ok parsify_expression_reasonligo in
   let%bind parsified = parsify source in
-  let%bind applied = Self_ast_imperative.all_expression parsified
+  let%bind applied = trace self_ast_imperative_tracer @@
+    Self_ast_imperative.all_expression parsified
   in ok applied
 
 let parsify_string_reasonligo source =
-  let%bind raw =
+  let%bind raw = trace parser_tracer @@
-    trace (simple_error "parsing") @@
     Parser.Reasonligo.parse_string source in
-  let%bind imperative =
+  let%bind imperative = trace cit_cameligo_tracer @@
-    trace (simple_error "abstracting") @@
     Concrete_to_imperative.Cameligo.compile_program raw
   in ok imperative
 
 let parsify_string_pascaligo source =
-  let%bind raw =
+  let%bind raw = trace parser_tracer @@
-    trace (simple_error "parsing") @@
     Parser.Pascaligo.parse_string source in
-  let%bind imperative =
+  let%bind imperative = trace cit_pascaligo_tracer @@
-    trace (simple_error "abstracting") @@
     Concrete_to_imperative.Pascaligo.compile_program raw
   in ok imperative
 
 let parsify_string_cameligo source =
-  let%bind raw =
+  let%bind raw = trace parser_tracer @@
-    trace (simple_error "parsing") @@
     Parser.Cameligo.parse_string source in
-  let%bind imperative =
+  let%bind imperative = trace cit_cameligo_tracer @@
-    trace (simple_error "abstracting") @@
     Concrete_to_imperative.Cameligo.compile_program raw
   in ok imperative
 
@@ -126,11 +109,12 @@ let parsify_string syntax source =
     | CameLIGO   -> ok parsify_string_cameligo
     | ReasonLIGO -> ok parsify_string_reasonligo in
   let%bind parsified = parsify source in
-  let%bind applied = Self_ast_imperative.all_program parsified
+  let%bind applied = trace self_ast_imperative_tracer @@
+    Self_ast_imperative.all_program parsified
   in ok applied
 
 let pretty_print_pascaligo_cst source =
-  let%bind ast = Parser.Pascaligo.parse_file source in
+  let%bind ast = trace parser_tracer @@ Parser.Pascaligo.parse_file source in
   let buffer = Buffer.create 59 in
   let state =
     Parser_pascaligo.ParserLog.mk_state
@@ -141,7 +125,7 @@ let pretty_print_pascaligo_cst source =
   ok buffer
 
 let pretty_print_cameligo_cst source =
-  let%bind ast = Parser.Cameligo.parse_file source in
+  let%bind ast = trace parser_tracer @@ Parser.Cameligo.parse_file source in
   let buffer = Buffer.create 59 in
   let state = (* TODO: Should flow from the CLI *)
     Parser_cameligo.ParserLog.mk_state
@@ -152,7 +136,7 @@ let pretty_print_cameligo_cst source =
   ok buffer
 
 let pretty_print_reasonligo_cst source =
-  let%bind ast = Parser.Reasonligo.parse_file source in
+  let%bind ast = trace parser_tracer @@ Parser.Reasonligo.parse_file source in
   let buffer = Buffer.create 59 in
   let state = (* TODO: Should flow from the CLI *)
     Parser_cameligo.ParserLog.mk_state
@@ -179,6 +163,7 @@ let preprocess_reasonligo = Parser.Reasonligo.preprocess
 let preprocess syntax source =
   let%bind v_syntax =
     syntax_to_variant syntax (Some source) in
+  trace parser_tracer @@
   match v_syntax with
     PascaLIGO  -> preprocess_pascaligo  source
   | CameLIGO   -> preprocess_cameligo   source
@@ -221,6 +206,6 @@ let pretty_print syntax source =
   let%bind v_syntax =
     syntax_to_variant syntax (Some source) in
   match v_syntax with
-    PascaLIGO  -> pretty_print_pascaligo  source
+    PascaLIGO  -> trace parser_tracer @@ pretty_print_pascaligo  source
-  | CameLIGO   -> pretty_print_cameligo   source
+  | CameLIGO   -> trace parser_tracer @@ pretty_print_cameligo   source
-  | ReasonLIGO -> pretty_print_reasonligo source
+  | ReasonLIGO -> trace parser_tracer @@ pretty_print_reasonligo source

src/main/compile/of_core.ml

@@ -1,26 +1,28 @@
+open Main_errors
 open Trace
 
 type form = 
   | Contract of string
   | Env
 
-let compile (cform: form) (program : Ast_core.program) : (Ast_typed.program * Typesystem.Solver_types.typer_state) result =
+let compile (cform: form) (program : Ast_core.program) : (Ast_typed.program * Typesystem.Solver_types.typer_state , _) result =
-  let%bind (prog_typed , state) = Typer.type_program program in
+  let%bind (prog_typed , state) = trace typer_tracer @@ Typer.type_program program in
   let () = Typer.Solver.discard_state state in
-  let%bind applied = Self_ast_typed.all_program prog_typed in
+  let%bind applied = trace self_ast_typed_tracer @@
-  let%bind applied' = match cform with
+    let%bind selfed = Self_ast_typed.all_program prog_typed in
-    | Contract entrypoint -> Self_ast_typed.all_contract entrypoint applied
+    match cform with
-    | Env -> ok applied in
+    | Contract entrypoint -> Self_ast_typed.all_contract entrypoint selfed
-  ok @@ (applied', state)
+    | Env -> ok selfed in
+  ok @@ (applied, state)
 
 let compile_expression ?(env = Ast_typed.Environment.empty) ~(state : Typesystem.Solver_types.typer_state) (e : Ast_core.expression)
-    : (Ast_typed.expression * Typesystem.Solver_types.typer_state) result =
+    : (Ast_typed.expression * Typesystem.Solver_types.typer_state , _) result =
-  let%bind (ae_typed,state) = Typer.type_expression_subst env state e in
+  let%bind (ae_typed,state) = trace typer_tracer @@ Typer.type_expression_subst env state e in
   let () = Typer.Solver.discard_state state in
-  let%bind ae_typed' = Self_ast_typed.all_expression ae_typed in
+  let%bind ae_typed' = trace self_ast_typed_tracer @@ Self_ast_typed.all_expression ae_typed in
   ok @@ (ae_typed',state)
 
-let apply (entry_point : string) (param : Ast_core.expression) : Ast_core.expression result =
+let apply (entry_point : string) (param : Ast_core.expression) : (Ast_core.expression , _) result =
   let name = Var.of_name entry_point in
   let entry_point_var : Ast_core.expression =
     { expression_content = Ast_core.E_variable name ;
@@ -30,9 +32,6 @@ let apply (entry_point : string) (param : Ast_core.expression) : Ast_core.expres
       location = Virtual "generated application" } in
   ok applied
 
-let pretty_print formatter (program : Ast_core.program) = 
-  Ast_core.PP.program formatter program
-
 let list_declarations (program : Ast_core.program) : string list =
   List.fold_left
     (fun prev el -> 

src/main/compile/of_imperative.ml

@@ -1,3 +1,4 @@
+open Main_errors
 open Trace
 open Ast_imperative
 open Imperative_to_sugar
@@ -6,11 +7,11 @@ type form =
   | Contract of string
   | Env
 
-let compile (program : program) : Ast_sugar.program result =
+let compile (program : program) : (Ast_sugar.program, _) result =
-  compile_program program
+  trace imperative_to_sugar_tracer @@ compile_program program
 
-let compile_expression (e : expression) : Ast_sugar.expression result =
+let compile_expression (e : expression) : (Ast_sugar.expression , _) result =
-  compile_expression e
+  trace imperative_to_sugar_tracer @@ compile_expression e
 
 let pretty_print formatter (program : program) = 
   PP.program formatter program

src/main/compile/of_michelson.ml

@@ -1,71 +1,43 @@
+open Main_errors
 open Tezos_utils
 open Proto_alpha_utils
 open Trace
 
-module Errors = struct
+let build_contract : ?disable_typecheck:bool -> Compiler.compiled_expression -> (Michelson.michelson , _) result =
-(*
-  TODO: those errors should have been caught in the earlier stages on the ligo pipeline
-  build_contract is a kind of security net
-*)
-  let title_type_check_msg () = "generated Michelson contract failed to typecheck"
-  let bad_parameter c () =
-    let message () =
-      let code = Format.asprintf "%a" Michelson.pp c in
-      "bad contract parameter type (some michelson types are forbidden as contract parameter):\n"^code in
-    error title_type_check_msg message
-  let bad_storage c () =
-    let message () =
-      let code = Format.asprintf "%a" Michelson.pp c in
-      "bad storage type (some michelson types are forbidden as contract storage):\n"^code in
-    error title_type_check_msg message
-  let bad_contract c () =
-    let message () =
-      let code = Format.asprintf "%a" Michelson.pp c in
-      "bad contract type\n"^code in
-    error title_type_check_msg message
-  let ran_out_of_gas () =
-    let message () = "Ran out of gas!" in
-    error title_type_check_msg message
-  let unknown () =
-    let message () =
-      "unknown error" in
-    error title_type_check_msg message
-end
-
-let build_contract : ?disable_typecheck:bool -> Compiler.compiled_expression -> Michelson.michelson result =
   fun ?(disable_typecheck= false) compiled ->
-  let%bind ((Ex_ty _param_ty),(Ex_ty _storage_ty)) = Self_michelson.fetch_contract_inputs compiled.expr_ty in
+  let%bind ((Ex_ty _param_ty),(Ex_ty _storage_ty)) = trace_option (entrypoint_not_a_function) @@
+    Self_michelson.fetch_contract_inputs compiled.expr_ty in
   let%bind param_michelson =
-    Trace.trace_tzresult_lwt (simple_error "Could not unparse parameter") @@
+    Trace.trace_tzresult_lwt unparse_tracer @@
     Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _param_ty in
   let%bind storage_michelson =
-    Trace.trace_tzresult_lwt (simple_error "Could not unparse storage") @@
+    Trace.trace_tzresult_lwt unparse_tracer @@
     Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _storage_ty in
   let contract = Michelson.contract param_michelson storage_michelson compiled.expr in
   if disable_typecheck then
     ok contract
   else
     let%bind res =
-      Trace.trace_tzresult_lwt (simple_error "Could not typecheck the code") @@
+      Trace.trace_tzresult_lwt (typecheck_contract_tracer contract) @@
       Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in
     match res with
     | Type_checked  -> ok contract
-    | Err_parameter -> fail @@ Errors.bad_parameter contract ()
+    | Err_parameter -> fail @@ bad_parameter contract
-    | Err_storage   -> fail @@ Errors.bad_storage contract ()
+    | Err_storage   -> fail @@ bad_storage contract
-    | Err_contract  -> fail @@ Errors.bad_contract contract ()
+    | Err_contract  -> fail @@ bad_contract contract
-    | Err_gas       -> fail @@ Errors.ran_out_of_gas ()
+    | Err_gas       -> fail @@ gas_exhaustion
-    | Err_unknown   -> fail @@ Errors.unknown ()
+    | Err_unknown   -> fail @@ unknown
 
-type check_type = Check_parameter | Check_storage
+let assert_equal_contract_type : Simple_utils.Runned_result.check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> (unit , _) result =
-let assert_equal_contract_type : check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> unit result =
   fun c compiled_prg compiled_param ->
     let%bind (Ex_ty expected_ty) =
-      let%bind (c_param_ty,c_storage_ty) = Self_michelson.fetch_contract_inputs compiled_prg.expr_ty in
+      let%bind (c_param_ty,c_storage_ty) = trace_option (entrypoint_not_a_function) @@
+        Self_michelson.fetch_contract_inputs compiled_prg.expr_ty in
       match c with
       | Check_parameter -> ok c_param_ty
       | Check_storage -> ok c_storage_ty in
     let (Ex_ty actual_ty) = compiled_param.expr_ty in
     let%bind _ = 
-      Trace.trace_tzresult (simple_error "Passed parameter does not match the contract type") @@
+      Trace.trace_tzresult typecheck_parameters_tracer @@
       Proto_alpha_utils.Memory_proto_alpha.assert_equal_michelson_type expected_ty actual_ty in
     ok ()

src/main/compile/of_mini_c.ml

@@ -1,31 +1,33 @@
+open Main_errors
 open Mini_c
 open Proto_alpha_utils
 open Trace
 
-let compile_contract : expression -> Compiler.compiled_expression result = fun e ->
+let compile_contract : expression -> (Compiler.compiled_expression , _) result = fun e ->
-  let%bind e = Self_mini_c.contract_check e in
+  let%bind e = trace self_mini_c_tracer @@ Self_mini_c.contract_check e in
-  let%bind (input_ty , _) = get_t_function e.type_expression in
+  let%bind (input_ty , _) = trace self_mini_c_tracer @@ Self_mini_c.get_t_function e.type_expression in
-  let%bind body = get_function e in
+  let%bind body = trace self_mini_c_tracer @@ Self_mini_c. get_function e in
-  let%bind body = Compiler.Program.translate_function_body body [] input_ty in
+  let%bind body = trace compiler_tracer @@ Compiler.Program.translate_function_body body [] input_ty in
   let expr = Self_michelson.optimize body in
-  let%bind expr_ty = Compiler.Type.Ty.type_ e.type_expression in
+  let%bind expr_ty = trace compiler_tracer @@ Compiler.Type.Ty.type_ e.type_expression in
   ok ({ expr_ty ; expr } : Compiler.Program.compiled_expression)
 
-let compile_expression : expression -> Compiler.compiled_expression result = fun e ->
+let compile_expression : expression -> (Compiler.compiled_expression, _) result = fun e ->
+  trace compiler_tracer @@
   let%bind expr = Compiler.Program.translate_expression e Compiler.Environment.empty in
   let expr = Self_michelson.optimize expr in
   let%bind expr_ty = Compiler.Type.Ty.type_ e.type_expression in
   ok ({ expr_ty ; expr } : Compiler.Program.compiled_expression)
 
-let aggregate_and_compile = fun program form ->
+let aggregate_and_compile : program -> form_t -> (Compiler.compiled_expression, _) result = fun program form ->
-  let%bind aggregated = aggregate_entry program form in
+  let%bind aggregated = trace self_mini_c_tracer @@ Self_mini_c.aggregate_entry program form in
   let aggregated' = Self_mini_c.all_expression aggregated in
   match form with
   | ContractForm _ -> compile_contract aggregated'
   | ExpressionForm _ -> compile_expression aggregated'
 
-let aggregate_and_compile_contract = fun (program : Types.program) name ->
+let aggregate_and_compile_contract : program -> string -> (Compiler.compiled_expression, _) result = fun program name ->
-  let%bind (exp, idx) = get_entry program name in
+  let%bind (exp, idx) = trace_option entrypoint_not_found @@ Mini_c.get_entry program name in
   let program' = List.take idx program in
   aggregate_and_compile program' (ContractForm exp)
 
@@ -39,10 +41,11 @@ let pretty_print program =
 (* TODO refactor? *)
 
 let aggregate = fun program form ->
-  let%bind aggregated = aggregate_entry program form in
+  trace self_mini_c_tracer @@
+  let%bind aggregated = Self_mini_c.aggregate_entry program form in
   ok @@ Self_mini_c.all_expression aggregated
 
 let aggregate_contract = fun (program : Types.program) name ->
-  let%bind (exp, idx) = get_entry program name in
+  let%bind (exp, idx) = trace_option entrypoint_not_found @@ get_entry program name in
   let program' = List.take idx program in
   aggregate program' (ContractForm exp)

src/main/compile/of_source.ml

@@ -1,20 +1,20 @@
 open Trace
 open Helpers
 
-let compile (source_filename:string) syntax : Ast_imperative.program result =
+let compile (source_filename:string) syntax : (Ast_imperative.program , _) result =
   let%bind syntax = syntax_to_variant syntax (Some source_filename) in
   let%bind abstract = parsify syntax source_filename in
   ok abstract
 
-let compile_string (source:string) syntax : Ast_imperative.program result =
+let compile_string (source:string) syntax : (Ast_imperative.program , _) result =
   let%bind abstract = parsify_string syntax source in
   ok abstract
 
-let compile_expression : v_syntax -> string -> Ast_imperative.expression result =
+let compile_expression : v_syntax -> string -> (Ast_imperative.expression , _) result =
     fun syntax exp ->
   parsify_expression syntax exp
 
-let compile_contract_input : string -> string -> v_syntax -> Ast_imperative.expression result =
+let compile_contract_input : string -> string -> v_syntax -> (Ast_imperative.expression , _) result =
     fun storage parameter syntax ->
   let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in
   ok @@ Ast_imperative.e_pair storage parameter

src/main/compile/of_sugar.ml

@@ -1,19 +1,17 @@
 open Trace
 open Ast_sugar
 open Sugar_to_core
+open Main_errors
 
 type form = 
   | Contract of string
   | Env
 
-let compile (program : program) : Ast_core.program result =
+let compile (program : program) : (Ast_core.program , _) result =
-  compile_program program
+  trace sugar_to_core_tracer @@ compile_program program
 
-let compile_expression (e : expression) : Ast_core.expression result =
+let compile_expression (e : expression) : (Ast_core.expression , _) result =
-  compile_expression e
+  trace sugar_to_core_tracer @@ compile_expression e
-
-let pretty_print formatter (program : program) = 
-  PP.program formatter program
 
 let list_declarations (program : program) : string list =
   List.fold_left

src/main/compile/of_typed.ml

@@ -1,16 +1,17 @@
+open Main_errors
 open Trace
 open Ast_typed
 
-let compile : Ast_typed.program -> Mini_c.program result = fun p ->
+let compile : Ast_typed.program -> (Mini_c.program, _) result = fun p ->
-  Transpiler.transpile_program p
+  trace transpiler_tracer @@ Transpiler.transpile_program p
 
-let compile_expression : expression -> Mini_c.expression result = fun e ->
+let compile_expression : expression -> (Mini_c.expression, _) result = fun e ->
-  Transpiler.transpile_annotated_expression e
+  trace transpiler_tracer @@ Transpiler.transpile_annotated_expression e
 
-type check_type = Check_parameter | Check_storage
+let assert_equal_contract_type : Simple_utils.Runned_result.check_type -> string -> Ast_typed.program -> Ast_typed.expression -> (unit , _) result =
-let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> Ast_typed.expression -> unit result =
+    fun c entry contract param ->
-    fun c entry contract param -> Trace.trace (simple_info "Check argument type against contract type") (
+  let%bind entry_point = trace_option entrypoint_not_found (Ast_typed.get_entry contract entry) in
-  let%bind entry_point = Ast_typed.get_entry contract entry in
+  trace (arguments_check_tracer c) (
     match entry_point.type_expression.type_content with
     | T_arrow {type1=args} -> (
         match args.type_content with
@@ -18,14 +19,11 @@ let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> As
           let {field_type=param_exp;_} = LMap.find (Label "0") m in
           let {field_type=storage_exp;_} = LMap.find (Label "1") m in
             match c with
-          | Check_parameter -> assert_type_expression_eq (param_exp,   param.type_expression)
+            | Check_parameter -> trace typer_tracer @@ Typer.assert_type_expression_eq (param_exp,   param.type_expression)
-          | Check_storage   -> assert_type_expression_eq (storage_exp, param.type_expression)
+            | Check_storage   -> trace typer_tracer @@ Typer.assert_type_expression_eq (storage_exp, param.type_expression)
         )
-      | _ -> dummy_fail
+        | _ -> fail @@ entrypoint_not_a_function )
+    | _ -> fail @@ entrypoint_not_a_function
   )
-  | _ -> dummy_fail )
 
-let pretty_print ppf program =
+let some_interpret x = trace interpret_tracer @@ Interpreter.eval x
-  Ast_typed.PP.program ppf program
-
-let some_interpret = Interpreter.dummy

src/main/compile/utils.ml

@@ -14,7 +14,7 @@ let to_core f stx =
   let%bind core   = Of_sugar.compile sugar in
   ok @@ core
 
-let type_file f stx env =
+let type_file f stx env : (Ast_typed.program * Typesystem.Solver_types.typer_state, _) result =
   let%bind core        = to_core f stx in
   let%bind typed,state = Of_core.compile env core in
   ok @@ (typed,state)
@@ -24,7 +24,7 @@ let to_mini_c f stx env =
   let%bind mini_c     = Of_typed.compile typed in
   ok @@ mini_c
 
-let compile_file f stx ep =
+let compile_file f stx ep : (Michelson.michelson, _) result =
   let%bind typed, _ = type_file f stx @@ Contract ep in
   let%bind mini_c     = Of_typed.compile typed in
   let%bind michelson  = Of_mini_c.aggregate_and_compile_contract mini_c ep in

src/main/display.ml

@@ -1,105 +0,0 @@
-open Trace
-
-let rec error_pp ?(dev = false) out (e : error) =
-  let open JSON_string_utils in
-  let message =
-    let opt = e |> member "message" |> string in
-    match opt with
-    | Some msg -> ": " ^ msg
-    | None -> "" in
-  let error_code =
-    let error_code = e |> member "error_code" in
-    match error_code with
-    | `Null -> ""
-    | _ -> " (" ^ (J.to_string error_code) ^ ")" in
-  let title =
-    let opt = e |> member "title" |> string in
-    Option.unopt ~default:"" opt in
-  let data =
-    let data = e |> member "data" in
-    match data with
-    | `Null -> ""
-    | _ -> " " ^ (J.to_string data) ^ "\n" in
-  let infos =
-    let infos = e |> member "infos" in
-    match infos with
-    | `List lst -> lst
-    | `Null -> []
-    | x -> [ x ] in
-  let children =
-    let infos = e |> member "children" in
-    match infos with
-    | `List lst -> lst
-    | `Null -> []
-    | x -> [ x ] in
-  let location =
-    let opt = e |> member "data" |> member "location" |> string in
-    let aux cur prec =
-      match prec with
-      | None -> cur |> member "data" |> member "location" |> string
-      | Some s -> Some s
-    in
-    match List.fold_right aux infos opt with
-    | None -> ""
-    | Some s -> s ^ ". "
-  in
-  let print x = Format.fprintf out x in
-  if not dev then (
-    print "%s%s%s%s%s" location title error_code message data
-  ) else (
-    print "%s%s%s.\n%s%s\n%a\n%a\n" title error_code message data location
-      (Format.pp_print_list (error_pp ~dev)) infos
-      (Format.pp_print_list (error_pp ~dev)) children
-  )
-
-let result_pp_hr f out (r : _ result) =
-  match r with
-  | Ok (s , _) -> Format.fprintf out "%a" f s
-  | Error e -> Format.fprintf out "%a" (error_pp ~dev:false) (e ())
-
-let string_result_pp_hr = result_pp_hr (fun out s -> Format.fprintf out "%s\n" s)
-
-let result_pp_dev f out (r : _ result) =
-  match r with
-  | Ok (s , _) -> Format.fprintf out "%a" f s
-  | Error e -> Format.fprintf out "%a" (error_pp ~dev:true) (e ())
-
-let string_result_pp_dev = result_pp_hr (fun out s -> Format.fprintf out "%s\n" s)
-
-let json_pp out x = Format.fprintf out "%s" (J.to_string x)
-
-let string_result_pp_json out (r : string result) =
-  let status_json status content : J.t = `Assoc ([
-      ("status" , `String status) ;
-      ("content" , content) ;
-    ]) in
-  match r with
-  | Ok (x , _) -> (
-      Format.fprintf out "%a\n" json_pp (status_json "ok" (`String x))
-    )
-  | Error e -> (
-      Format.fprintf out "%a\n" json_pp (status_json "error" (e ()))
-    )
-
-type display_format = [
-  | `Human_readable
-  | `Json
-  | `Dev
-]
-
-let formatted_string_result_pp (display_format : display_format) =
-  match display_format with
-  | `Human_readable -> string_result_pp_hr
-  | `Dev -> string_result_pp_dev
-  | `Json -> string_result_pp_json
-
-type michelson_format = [
-  | `Text
-  | `Json
-  | `Hex
-]
-
-let michelson_pp (mf : michelson_format) = match mf with
-  | `Text -> Michelson.pp
-  | `Json -> Michelson.pp_json
-  | `Hex -> Michelson.pp_hex

src/main/display.mli

@@ -1,32 +0,0 @@
-open Trace
-
-val error_pp : ?dev:bool -> Format.formatter -> error -> unit
-
-val result_pp_hr : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a Simple_utils.Trace.result -> unit
-
-val string_result_pp_hr : Format.formatter -> string Simple_utils.Trace.result -> unit
-
-
-val result_pp_dev : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a Simple_utils.Trace.result -> unit
-
-val string_result_pp_dev : Format.formatter -> string Simple_utils.Trace.result -> unit
-
-val json_pp : Format.formatter -> Simple_utils.Trace.J.t -> unit
-
-val string_result_pp_json : Format.formatter -> string result -> unit
-
-type display_format = [
-  | `Human_readable
-  | `Json
-  | `Dev
-]
-
-val formatted_string_result_pp : display_format -> Format.formatter -> string Simple_utils.Trace.result -> unit
-
-type michelson_format = [
-  | `Text
-  | `Json
-  | `Hex
-]
-
-val michelson_pp : michelson_format -> Format.formatter -> Tezos_utils.Michelson.michelson -> unit

src/main/dune

@@ -5,6 +5,7 @@
     run
     compile
     uncompile
+    main_errors
   )
   (preprocess
     (pps ppx_let bisect_ppx --conditional)

src/main/main.ml

@@ -2,3 +2,4 @@ module Run = Run
 module Compile = Compile
 module Uncompile = Uncompile
 module Display = Display
+module Formatter = Main_errors.Formatter

src/main/main_errors/dune

@@ -0,0 +1,26 @@
+(library
+  (name main_errors)
+  (public_name ligo.main_errors)
+  (libraries
+    simple-utils
+    parser
+    concrete_to_imperative
+    self_ast_imperative
+    interpreter
+    imperative_to_sugar
+    ast_sugar
+    self_ast_sugar
+    sugar_to_core
+    self_ast_core
+    typer
+    self_ast_typed
+    transpiler
+    self_mini_c
+    compiler
+    self_michelson
+  )
+  (preprocess
+    (pps ppx_let bisect_ppx --conditional)
+  )
+  (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
+)

src/main/main_errors/formatter.ml

@@ -0,0 +1,294 @@
+open Trace
+open Display
+
+let error_suggest: string = "\n
+If you're not sure how to fix this error, you can do one of the following:
+
+* Visit our documentation: https://ligolang.org/docs/intro/introduction
+* Ask a question on our Discord: https://discord.gg/9rhYaEt
+* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
+* Check the changelog by running 'ligo changelog'"
+
+let rec error_ppformat' : display_format:string display_format ->
+  Format.formatter -> Types.all -> unit =
+  fun ~display_format f a ->
+  match display_format with
+  | Human_readable | Dev -> (
+    match a with 
+    | `Test_err_tracer (name,err) ->
+      Format.fprintf f "@[<hv>Test '%s'@ %a@]"
+        name (error_ppformat' ~display_format) err
+    | `Test_run_tracer (ep, err) ->
+      Format.fprintf f "@[<hv>Running entrypoint '%s'@ %a@]"
+        ep (error_ppformat' ~display_format) err
+    | `Test_expect_tracer (expected, actual) ->
+      Format.fprintf f "@[<hv>Expected:@ %a@ got:@ %a@]"
+        Ast_core.PP.expression expected
+        Ast_core.PP.expression actual
+    | `Test_expect_n_tracer (i,err) ->
+      Format.fprintf f "@[<hv>Expect n=%d@ %a@]"
+        i (error_ppformat' ~display_format) err
+    | `Test_expect_exp_tracer (e,err) ->
+      Format.fprintf f "@[<hv>Expect %a@ %a@]"
+        Ast_core.PP.expression e
+        (error_ppformat' ~display_format) err
+    | `Test_expect_eq_n_tracer (i,err) ->
+      Format.fprintf f "@[<hv>Expected eq_n=%d@ %a@]"
+        i (error_ppformat' ~display_format) err
+    | `Test_internal t ->
+      Format.fprintf f "@[<hv>Internal error:@ %s@]" t
+    | `Test_md_file_tracer (md_file,s,grp,prg,err) ->
+      Format.fprintf f "@[<hv>Failed to compile %s@ syntax: %s@ group: %s@ program: %s@ %a@]"
+      md_file s grp prg (error_ppformat' ~display_format) err
+    | `Test_bad_code_block arg ->
+      Format.fprintf f "@[<hv>Bad code block argument '%s'@ only 'group=NAME' or 'skip' are allowed@]"
+        arg
+    | `Test_expected_to_fail -> Format.fprintf f "test was expected to fail but did not"
+    | `Test_not_expected_to_fail -> Format.fprintf f "test was not expected to fail but did"
+
+    | `Main_invalid_syntax_name syntax ->
+      Format.fprintf f
+        "@[<hv>Invalid syntax name '%s'@ Hint: Use 'pascaligo', 'cameligo' or 'reasonligo'@]"
+          syntax
+
+    | `Main_invalid_extension extension ->
+      Format.fprintf f
+        "@[<hv>Invalid extension '%s'@ Hint: Use '.ligo', '.mligo', '.religo' or the --syntax option@]"
+        extension
+
+    | `Main_bad_michelson_parameter c ->
+      let s = Format.asprintf
+        "generated Michelson contract failed to typecheck : bad contract parameter type\n\
+        code:\n %a" Michelson.pp c in
+      Format.pp_print_string f s
+
+    | `Main_bad_michelson_storage c ->
+      let s = Format.asprintf
+        "generated Michelson contract failed to typecheck : bad contract storage type\n\
+        code:\n %a" Michelson.pp c in
+      Format.pp_print_string f s
+
+    | `Main_bad_michelson c ->
+      let s = Format.asprintf
+        "generated Michelson contract failed to typecheck : bad contract type\n\
+        code:\n %a" Michelson.pp c in
+      Format.pp_print_string f s
+
+    | `Main_gas_exhaustion -> Format.pp_print_string f "gas exhaustion"
+
+    | `Main_unparse_tracer _ -> Format.pp_print_string f "could not unparse michelson type"
+
+    | `Main_typecheck_contract_tracer (c,_) ->
+      let s = Format.asprintf
+        "Could not typecheck michelson code:\n %a"
+        Michelson.pp c in
+      Format.pp_print_string f s
+    
+    | `Main_typecheck_parameter -> Format.pp_print_string f "Passed parameter does not match the contract type"
+
+    | `Main_check_typed_arguments (Simple_utils.Runned_result.Check_parameter, err) ->
+      Format.fprintf f "@[<v>Provided parameter type does not match contract parameter type@ %a@]"
+        (error_ppformat' ~display_format) err
+
+    | `Main_check_typed_arguments (Simple_utils.Runned_result.Check_storage, err) ->
+      Format.fprintf f "@[<v>Provided storage type does not match contract storage type@ %a@]"
+        (error_ppformat' ~display_format) err
+
+    | `Main_unknown_failwith_type ->
+      Format.fprintf f "@[<v>Execution failed with an unknown failwith type@]"
+    | `Main_unknown ->
+      Format.fprintf f "@[<v>Unknown error@]"
+
+    | `Main_execution_failed (fw:Runned_result.failwith) ->
+      let value = match fw with
+        | Failwith_int i -> string_of_int i
+        | Failwith_string s -> s
+        | Failwith_bytes b -> Bytes.to_string b in
+      Format.fprintf f
+        "[<hv>Execution failed with %s@]"
+        value
+    | `Main_entrypoint_not_a_function -> Format.fprintf f "@[<hv>Given entrypoint is not a function@]"
+    | `Main_entrypoint_not_found -> Format.fprintf f "@[<hv>Missing entrypoint@]"
+    | `Main_invalid_amount a -> Format.fprintf f "@[<hv>Invalid amount %s@]" a
+    | `Main_invalid_address a -> Format.fprintf f "@[<hv>Invalid address %s@]" a
+    | `Main_invalid_timestamp t -> Format.fprintf f "@[<hv>Invalid timestamp notation %s@]" t
+
+    | `Main_unparse_michelson_result _ -> Format.fprintf f "@[<hv>Error unparsing michelson result@]"
+    | `Main_parse_payload _ -> Format.fprintf f "@[<hv>Error parsing message@]"
+    | `Main_pack_payload _ -> Format.fprintf f "@[<hv>Error packing message@]"
+    | `Main_parse_michelson_input _ -> Format.fprintf f "@[<hv>Error parsing input@]"
+    | `Main_parse_michelson_code _ -> Format.fprintf f "@[<hv>Error parsing program code@]"
+    | `Main_michelson_execution_error _ -> Format.fprintf f "@[<hv>Error of execution@]"
+
+    | `Main_parser e -> Parser.Errors.error_ppformat ~display_format f e
+    | `Main_self_ast_imperative e -> Self_ast_imperative.Errors.error_ppformat ~display_format f e 
+    | `Main_imperative_to_sugar e -> Imperative_to_sugar.Errors.error_ppformat ~display_format f e
+    | `Main_sugar_to_core _e -> () (*no error in this pass*)
+    | `Main_cit_pascaligo e -> Concrete_to_imperative.Errors_pascaligo.error_ppformat ~display_format f e
+    | `Main_cit_cameligo e -> Concrete_to_imperative.Errors_cameligo.error_ppformat ~display_format f e
+    | `Main_typer e -> Typer.Errors.error_ppformat ~display_format f e
+    | `Main_interpreter _ -> () (*no error*)
+    | `Main_self_ast_typed e -> Self_ast_typed.Errors.error_ppformat ~display_format f e
+    | `Main_self_mini_c e -> Self_mini_c.Errors.error_ppformat ~display_format f e
+    | `Main_transpiler e -> Transpiler.Errors.error_ppformat ~display_format f  e
+    | `Main_compiler e -> Compiler.Errors.error_ppformat ~display_format f e
+
+    | `Main_uncompile_michelson e -> Compiler.Errors.error_ppformat ~display_format f  e
+    | `Main_uncompile_mini_c e -> Transpiler.Errors.error_ppformat ~display_format f  e
+    | `Main_uncompile_typed e -> Typer.Errors.error_ppformat ~display_format f  e
+  )
+  
+let error_ppformat : display_format:string display_format ->
+  Format.formatter -> Types.all -> unit = fun ~display_format f a ->
+    Format.fprintf f "@[<v>%a@ %s@]"
+      (error_ppformat' ~display_format) a
+      error_suggest
+
+let rec error_jsonformat : Types.all -> J.t = fun a ->
+  let json_error ~stage ~content =
+    `Assoc [
+      ("status", `String "error") ;
+      ("stage", `String stage) ;
+      ("content",  content )]
+  in
+  match a with
+  | `Test_err_tracer _
+  | `Test_run_tracer _
+  | `Test_expect_tracer _
+  | `Test_expect_n_tracer _
+  | `Test_expect_exp_tracer _
+  | `Test_expect_eq_n_tracer _
+  | `Test_internal _
+  | `Test_md_file_tracer _
+  | `Test_bad_code_block _
+  | `Test_expected_to_fail
+  | `Test_not_expected_to_fail
+  -> `Null
+
+  (* Top-level errors *)
+  | `Main_invalid_syntax_name _ ->
+    json_error ~stage:"command line interpreter" ~content:(`String "bad syntax name")
+
+  | `Main_invalid_extension _ ->
+    json_error ~stage:"command line interpreter" ~content:(`String "bad file extension")
+
+  | `Main_bad_michelson_parameter c ->
+    let code = Format.asprintf "%a" Michelson.pp c in
+    let content = `Assoc [("message", `String "bad contract parameter type") ; ("code", `String code)] in
+    json_error ~stage:"michelson contract build" ~content
+
+  | `Main_bad_michelson_storage c ->
+    let code = Format.asprintf "%a" Michelson.pp c in
+    let content = `Assoc [("message", `String "bad contract storage type") ; ("code", `String code)] in
+    json_error ~stage:"michelson contract build" ~content
+
+  | `Main_bad_michelson c ->
+    let code = Format.asprintf "%a" Michelson.pp c in
+    let content = `Assoc [("message", `String "bad contract type") ; ("code", `String code)] in
+    json_error ~stage:"michelson contract build" ~content
+
+  | `Main_gas_exhaustion ->
+    let content = `Assoc [("message", `String "gas exhaustion")] in
+    json_error ~stage:"michelson contract build" ~content
+
+  | `Main_unparse_tracer _ ->
+    let content = `Assoc [("message", `String "could not unparse michelson type")] in
+    json_error ~stage:"michelson contract build" ~content
+  
+  | `Main_typecheck_contract_tracer (c,_) -> 
+    let code = Format.asprintf "%a" Michelson.pp c in
+    let content = `Assoc [
+      ("message", `String "Could not typecheck michelson code") ;
+      ("code",    `String code) ; ] in
+    json_error ~stage:"michelson contract build" ~content
+
+  | `Main_typecheck_parameter ->
+    let content = `Assoc [("message", `String "Passed parameter does not match the contract type")] in
+    json_error ~stage:"michelson contract build" ~content
+  
+  | `Main_check_typed_arguments (Simple_utils.Runned_result.Check_parameter, err) ->
+    let content = `Assoc [
+      ("message", `String "Passed parameter does not match the contract type");
+      ("children", error_jsonformat err);
+      ] in
+    json_error ~stage:"contract argument typechecking" ~content
+
+  | `Main_check_typed_arguments (Simple_utils.Runned_result.Check_storage, err) ->
+    let content = `Assoc [
+      ("message", `String "Passed storage does not match the contract type");
+      ("children", error_jsonformat err);
+      ] in
+    json_error ~stage:"contract argument typechecking" ~content
+
+  | `Main_unknown_failwith_type ->
+    json_error ~stage:"michelson execution" ~content:(`String "unknown failwith type")
+  | `Main_unknown ->
+    json_error ~stage:"michelson execution" ~content:(`String "unknown error")
+
+  | `Main_execution_failed (fw:Runned_result.failwith) ->
+    let value = match fw with
+      | Failwith_int i -> `Assoc [("value", `Int i) ; ("type", `String "int")]
+      | Failwith_string s -> `Assoc [("value", `String s) ; ("type", `String "int")]
+      | Failwith_bytes b -> `Assoc [("value", `String (Bytes.to_string b)) ; ("type", `String "bytes")]
+    in
+    let content = `Assoc [("failwith", value)] in
+    json_error ~stage:"michelson execution" ~content
+
+  | `Main_invalid_amount a ->
+    let message = `String "invalid amount" in
+    let value = `String a in
+    let content = `Assoc [("message", message) ; ("value", value)] in
+    json_error ~stage:"parsing command line parameters" ~content
+  | `Main_invalid_address a ->
+    let message = `String "invalid address" in
+    let value = `String a in
+    let content = `Assoc [("message", message) ; ("value", value)] in
+    json_error ~stage:"parsing command line parameters" ~content
+  | `Main_invalid_timestamp t ->
+    let message = `String "invalid timestamp notation" in
+    let value = `String t in
+    let content = `Assoc [("message", message) ; ("value", value)] in
+    json_error ~stage:"parsing command line parameters" ~content
+
+  | `Main_unparse_michelson_result _ ->
+    json_error ~stage:"michelson execution" ~content:(`String "error unparsing michelson result")
+
+  | `Main_parse_payload _ ->
+    json_error ~stage:"michelson execution" ~content:(`String "error parsing message")
+
+  | `Main_pack_payload _ ->
+    json_error ~stage:"michelson execution" ~content:(`String "error packing message")
+
+  | `Main_parse_michelson_input _ ->
+    json_error ~stage:"michelson execution" ~content:(`String "error parsing input")
+
+  | `Main_parse_michelson_code _ ->
+    json_error ~stage:"michelson execution" ~content:(`String "error parsing program code")
+
+  | `Main_michelson_execution_error _ ->
+    json_error ~stage:"michelson execution" ~content:(`String "error of execution")
+
+  | `Main_entrypoint_not_a_function -> json_error ~stage:"top-level glue" ~content:(`String "given entrypoint is not a function")
+  | `Main_entrypoint_not_found -> json_error ~stage:"top-level glue" ~content:(`String "Missing entrypoint")
+
+  | `Main_parser e -> Parser.Errors.error_jsonformat e
+  | `Main_self_ast_imperative e -> Self_ast_imperative.Errors.error_jsonformat e
+  | `Main_imperative_to_sugar e -> Imperative_to_sugar.Errors.error_jsonformat e
+  | `Main_sugar_to_core _ -> `Null (*no error in this pass*)
+  | `Main_cit_pascaligo e -> Concrete_to_imperative.Errors_pascaligo.error_jsonformat e
+  | `Main_cit_cameligo e -> Concrete_to_imperative.Errors_cameligo.error_jsonformat e
+  | `Main_typer e -> Typer.Errors.error_jsonformat e
+  | `Main_interpreter _ -> `Null (*no error*)
+  | `Main_self_ast_typed e -> Self_ast_typed.Errors.error_jsonformat e
+  | `Main_transpiler e -> Transpiler.Errors.error_jsonformat e
+  | `Main_self_mini_c e -> Self_mini_c.Errors.error_jsonformat e
+  | `Main_compiler e -> Compiler.Errors.error_jsonformat e
+  
+  | `Main_uncompile_michelson e -> Compiler.Errors.error_jsonformat e
+  | `Main_uncompile_mini_c e -> Transpiler.Errors.error_jsonformat e
+  | `Main_uncompile_typed e -> Typer.Errors.error_jsonformat e
+
+let error_format : _ Display.format = {
+  pp = error_ppformat;
+  to_json = error_jsonformat;
+}

src/main/main_errors/main_errors.ml

@@ -0,0 +1,71 @@
+module Formatter = Formatter
+module Types = Types
+type all = Types.all
+
+(* passes tracers *)
+
+let parser_tracer (e:Parser.Errors.parser_error) : all = `Main_parser e
+let cit_cameligo_tracer (e:Concrete_to_imperative.Errors_cameligo.abs_error) : all = `Main_cit_cameligo e
+let cit_pascaligo_tracer (e:Concrete_to_imperative.Errors_pascaligo.abs_error) : all = `Main_cit_pascaligo e
+let self_ast_imperative_tracer (e:Self_ast_imperative.Errors.self_ast_imperative_error) : all = `Main_self_ast_imperative e
+let imperative_to_sugar_tracer (e:Imperative_to_sugar.Errors.imperative_to_sugar_error) : all = `Main_imperative_to_sugar e
+let sugar_to_core_tracer (e:Sugar_to_core.Errors.sugar_to_core_error) : all = `Main_sugar_to_core e
+let typer_tracer (e:Typer.Errors.typer_error) : all = `Main_typer e
+let self_ast_typed_tracer (e:Self_ast_typed.Errors.self_ast_typed_error) : all = `Main_self_ast_typed e
+let self_mini_c_tracer (e:Self_mini_c.Errors.self_mini_c_error) : all = `Main_self_mini_c e
+let transpiler_tracer (e:Transpiler.Errors.transpiler_error) : all = `Main_transpiler e
+let compiler_tracer (e:Compiler.Errors.compiler_error) : all = `Main_compiler e
+let interpret_tracer (e:Interpreter.interpreter_error) : all = `Main_interpreter e
+
+let uncompile_mini_c : Transpiler.Errors.transpiler_error -> all = fun e -> `Main_uncompile_mini_c e
+let uncompile_typed : Typer.Errors.typer_error -> all = fun e -> `Main_uncompile_typed e
+let uncompile_michelson : Compiler.Errors.compiler_error -> all = fun e -> `Main_uncompile_michelson e
+
+(* top-level glue (in between passes) *)
+
+let syntax_auto_detection extension : all = `Main_invalid_extension extension
+let invalid_syntax syntax : all = `Main_invalid_syntax_name syntax
+
+let entrypoint_not_a_function : all = `Main_entrypoint_not_a_function
+let entrypoint_not_found : all = `Main_entrypoint_not_found
+
+(* Michelson execution errors *)
+
+let arguments_check_tracer ps err : all = `Main_check_typed_arguments (ps, err)
+let unparse_tracer errs : all = `Main_unparse_tracer errs
+let typecheck_contract_tracer c errs : all = `Main_typecheck_contract_tracer (c,errs)
+let typecheck_parameters_tracer _ : all = `Main_typecheck_parameter
+
+let bad_parameter c : all = `Main_bad_michelson_parameter c
+let bad_storage   c : all = `Main_bad_michelson_storage c
+let bad_contract  c : all = `Main_bad_michelson c
+let gas_exhaustion : all = `Main_gas_exhaustion
+let unknown : all = `Main_unknown
+
+let unknown_failwith_type : all = `Main_unknown_failwith_type
+let failwith fw : all = `Main_execution_failed fw
+
+let unparsing_michelson_tracer err : all = `Main_unparse_michelson_result err
+let parsing_payload_tracer err : all = `Main_parse_payload err
+let packing_payload_tracer err : all = `Main_pack_payload err
+let parsing_input_tracer err : all = `Main_parse_michelson_input err
+let parsing_code_tracer err : all = `Main_parse_michelson_code err
+let error_of_execution_tracer err : all = `Main_michelson_execution_error err
+
+let invalid_amount s : all = `Main_invalid_amount s
+let invalid_address s : all = `Main_invalid_address s
+let invalid_timestamp s : all = `Main_invalid_timestamp s
+
+(* test errors *)
+
+let test_tracer name err : all = `Test_err_tracer (name,err)
+let test_run_tracer entrypoint err : all = `Test_run_tracer (entrypoint,err)
+let test_expect expected actual : all = `Test_expect_tracer (expected,actual)
+let test_expect_n_tracer i err : all = `Test_expect_n_tracer (i,err)
+let test_expect_exp_tracer e err : all = `Test_expect_exp_tracer (e,err)
+let test_expect_eq_n_tracer i err : all = `Test_expect_eq_n_tracer (i,err)
+let test_internal loc : all = `Test_internal loc
+let test_md_file_tracer md_file s group prg err : all = `Test_md_file_tracer (md_file,s,group,prg,err) 
+let test_code_block_arg arg : all = `Test_bad_code_block arg
+let test_expected_to_fail : all = `Test_expected_to_fail
+let test_not_expected_to_fail : all = `Test_not_expected_to_fail

src/main/main_errors/types.ml

@@ -0,0 +1,56 @@
+type all = 
+[
+ | `Main_invalid_syntax_name of string
+ | `Main_invalid_extension of string
+ | `Main_bad_michelson_parameter of Michelson.michelson
+ | `Main_bad_michelson_storage of Michelson.michelson
+ | `Main_bad_michelson of Michelson.michelson
+ | `Main_gas_exhaustion
+ | `Main_unparse_tracer of [ `Tezos_alpha_error of Proto_alpha_utils.Error_monad.error ] list
+ | `Main_typecheck_contract_tracer of Michelson.michelson * [ `Tezos_alpha_error of Proto_alpha_utils.Error_monad.error ] list
+ | `Main_typecheck_parameter
+ | `Main_check_typed_arguments of Simple_utils.Runned_result.check_type * all
+ | `Main_unknown_failwith_type
+ | `Main_unknown
+ | `Main_execution_failed of Runned_result.failwith
+ | `Main_unparse_michelson_result of Proto_alpha_utils.Trace.tezos_alpha_error list
+ | `Main_parse_payload of Proto_alpha_utils.Trace.tezos_alpha_error list
+ | `Main_pack_payload of Proto_alpha_utils.Trace.tezos_alpha_error list
+ | `Main_parse_michelson_input of Proto_alpha_utils.Trace.tezos_alpha_error list
+ | `Main_parse_michelson_code of Proto_alpha_utils.Trace.tezos_alpha_error list
+ | `Main_michelson_execution_error of Proto_alpha_utils.Trace.tezos_alpha_error list
+
+ | `Main_parser of Parser.Errors.parser_error
+ | `Main_self_ast_imperative of Self_ast_imperative.Errors.self_ast_imperative_error
+ | `Main_imperative_to_sugar of Imperative_to_sugar.Errors.imperative_to_sugar_error
+ | `Main_sugar_to_core of Sugar_to_core.Errors.sugar_to_core_error
+ | `Main_cit_pascaligo of Concrete_to_imperative.Errors_pascaligo.abs_error
+ | `Main_cit_cameligo of Concrete_to_imperative.Errors_cameligo.abs_error
+ | `Main_typer of Typer.Errors.typer_error
+ | `Main_interpreter of Interpreter.interpreter_error
+ | `Main_self_ast_typed of Self_ast_typed.Errors.self_ast_typed_error
+ | `Main_self_mini_c of Self_mini_c.Errors.self_mini_c_error
+ | `Main_transpiler of Transpiler.Errors.transpiler_error
+ | `Main_compiler of Compiler.Errors.compiler_error
+
+ | `Main_uncompile_michelson of Compiler.Errors.compiler_error
+ | `Main_uncompile_mini_c of Transpiler.Errors.transpiler_error
+ | `Main_uncompile_typed of Typer.Errors.typer_error
+ | `Main_entrypoint_not_a_function
+ | `Main_entrypoint_not_found
+ | `Main_invalid_amount of string
+ | `Main_invalid_address of string
+ | `Main_invalid_timestamp of string
+
+ | `Test_err_tracer of string * all
+ | `Test_run_tracer of string * all
+ | `Test_expect_tracer of Ast_core.expression * Ast_core.expression
+ | `Test_expect_n_tracer of int * all
+ | `Test_expect_exp_tracer of Ast_core.expression * all
+ | `Test_expect_eq_n_tracer of int * all
+ | `Test_internal of string
+ | `Test_md_file_tracer of string * string * string * string * all
+ | `Test_bad_code_block of string
+ | `Test_expected_to_fail
+ | `Test_not_expected_to_fail
+] 

src/main/run/of_michelson.ml

@@ -2,33 +2,12 @@ open Proto_alpha_utils
 open Trace
 open Memory_proto_alpha.Protocol.Script_ir_translator
 open Memory_proto_alpha.X
+open Simple_utils.Runned_result
 
-module Errors = struct
+module Errors = Main_errors
-  let unknown_failwith_type () =
-    let title () = "Execution failed with an unknown failwith type" in
-    let message () = "only bytes, string or int are printable" in
-    error title message
-
-  let failwith str () =
-    let title () = "Execution failed" in
-    let message () = "" in
-    let data = [
-      ("value" , fun () -> Format.asprintf "%s" str);
-    ] in
-    error ~data title message
-end
 
 type options = Memory_proto_alpha.options
 
-type run_failwith_res =
-  | Failwith_int of int
-  | Failwith_string of string
-  | Failwith_bytes of bytes
-
-type run_res =
-  | Success of ex_typed_value
-  | Fail of run_failwith_res
-
 type dry_run_options =
   { amount : string ;
     balance : string ;
@@ -36,23 +15,15 @@ type dry_run_options =
     sender : string option ;
     source : string option }
 
-let failwith_to_string (f:run_failwith_res) : string result =
+let make_dry_run_options (opts : dry_run_options) : (options , _) result =
-  let%bind str = match f with
-  | Failwith_int i -> ok @@ string_of_int i
-  | Failwith_string s -> ok @@ Format.asprintf "\"%s\"" (String.escaped s)
-  | Failwith_bytes b ->
-    ok @@ Format.asprintf "0X%a" Hex.pp (Hex.of_bytes b) in
-  ok @@ Format.asprintf "failwith(%s)" str
-
-let make_dry_run_options (opts : dry_run_options) : options result =
   let open Proto_alpha_utils.Trace in
   let open Proto_alpha_utils.Memory_proto_alpha in
   let open Protocol.Alpha_context in
   let%bind balance = match Tez.of_string opts.balance with
-    | None -> simple_fail "invalid amount"
+    | None -> fail @@ Errors.invalid_amount opts.balance
     | Some balance -> ok balance in
   let%bind amount = match Tez.of_string opts.amount with
-    | None -> simple_fail "invalid amount"
+    | None -> fail @@ Errors.invalid_amount opts.balance
     | Some amount -> ok amount in
   let%bind sender =
     match opts.sender with
@@ -60,7 +31,7 @@ let make_dry_run_options (opts : dry_run_options) : options result =
     | Some sender ->
       let%bind sender =
         trace_alpha_tzresult
-          (simple_error "invalid address")
+          (fun _ -> Errors.invalid_address sender)
           (Contract.of_b58check sender) in
       ok (Some sender) in
   let%bind source =
@@ -69,7 +40,7 @@ let make_dry_run_options (opts : dry_run_options) : options result =
     | Some source ->
       let%bind source =
         trace_alpha_tzresult
-          (simple_error "invalid source address")
+          (fun _ -> Errors.invalid_address source)
           (Contract.of_b58check source) in
       ok (Some source) in
   let%bind predecessor_timestamp =
@@ -78,33 +49,33 @@ let make_dry_run_options (opts : dry_run_options) : options result =
     | Some st ->
       match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with
         | Some t -> ok (Some t)
-        | None -> simple_fail ("\""^st^"\" is a bad timestamp notation") in
+        | None -> fail @@ Errors.invalid_timestamp st in
   ok @@ make_options ?predecessor_timestamp:predecessor_timestamp ~amount ~balance ?sender ?source ()
 
-let ex_value_ty_to_michelson (v : ex_typed_value) : Michelson.t result =
+let ex_value_ty_to_michelson (v : ex_typed_value) : (Michelson.t , _) result =
   let (Ex_typed_value (value , ty)) = v in
-  Trace.trace_tzresult_lwt (simple_error "error unparsing michelson result") @@
+  Trace.trace_tzresult_lwt Errors.unparsing_michelson_tracer @@
   Memory_proto_alpha.unparse_michelson_data value ty
 
 let pack_payload (payload:Michelson.t) ty =
   let%bind payload =
-    Trace.trace_tzresult_lwt (simple_error "error parsing message") @@
+    Trace.trace_tzresult_lwt Errors.parsing_payload_tracer @@
     Memory_proto_alpha.parse_michelson_data payload ty in
   let%bind data =
-    Trace.trace_tzresult_lwt (simple_error "error packing message") @@
+    Trace.trace_tzresult_lwt Errors.packing_payload_tracer @@
     Memory_proto_alpha.pack ty payload in
   ok @@ data
 
 let fetch_lambda_types (contract_ty:ex_ty) =
   match contract_ty with
   | Ex_ty (Lambda_t (in_ty, out_ty, _)) -> ok (Ex_ty in_ty, Ex_ty out_ty)
-  | _ -> simple_fail "failed to fetch lambda types"
+  | _ -> fail Errors.unknown (*TODO*)
 
-let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Michelson.t) : run_res result =
+let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Michelson.t) : (ex_typed_value runned_result, _) result =
   let open! Tezos_raw_protocol_006_PsCARTHA in
   let%bind (Ex_ty input_ty, Ex_ty output_ty) = fetch_lambda_types exp_type in
   let%bind input =
-    Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
+    Trace.trace_tzresult_lwt Errors.parsing_input_tracer @@
     Memory_proto_alpha.parse_michelson_data input_michelson input_ty
   in
   let top_level = Script_ir_translator.Toplevel
@@ -114,11 +85,11 @@ let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Mi
   let ty_stack_after = Script_typed_ir.Item_t (output_ty, Empty_t, None) in
   let exp = Michelson.strip_annots exp in
   let%bind descr =
-    Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
+    Trace.trace_tzresult_lwt Errors.parsing_code_tracer @@
     Memory_proto_alpha.parse_michelson_fail ~top_level exp ty_stack_before ty_stack_after in
   let open! Memory_proto_alpha.Protocol.Script_interpreter in
   let%bind res =
-    Trace.trace_tzresult_lwt (simple_error "error of execution") @@
+    Trace.trace_tzresult_lwt Errors.error_of_execution_tracer @@
     Memory_proto_alpha.failure_interpret ?options descr (Item(input, Empty)) in
   match res with
   | Memory_proto_alpha.Succeed stack ->
@@ -128,9 +99,9 @@ let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Mi
     | Int (_ , i)    -> ok @@ Fail (Failwith_int (Z.to_int i))
     | String (_ , s) -> ok @@ Fail (Failwith_string s)
     | Bytes (_, s)   -> ok @@ Fail (Failwith_bytes s)
-    | _              -> fail @@ Errors.unknown_failwith_type () )
+    | _              -> fail @@ Errors.unknown_failwith_type )
 
-let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : run_res result =
+let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : (ex_typed_value runned_result, _) result =
   let open! Tezos_raw_protocol_006_PsCARTHA in
   let (Ex_ty exp_type') = exp_type in
   let exp = Michelson.strip_annots exp in
@@ -138,11 +109,11 @@ let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : run_res result
   and ty_stack_before = Script_typed_ir.Empty_t
   and ty_stack_after = Script_typed_ir.Item_t (exp_type', Empty_t, None) in
   let%bind descr =
-    Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
+    Trace.trace_tzresult_lwt Errors.parsing_code_tracer @@
     Memory_proto_alpha.parse_michelson_fail ~top_level exp ty_stack_before ty_stack_after in
   let open! Memory_proto_alpha.Protocol.Script_interpreter in
   let%bind res =
-    Trace.trace_tzresult_lwt (simple_error "error of execution") @@
+    Trace.trace_tzresult_lwt Errors.error_of_execution_tracer @@
     Memory_proto_alpha.failure_interpret ?options descr Empty in
   match res with
   | Memory_proto_alpha.Succeed stack ->
@@ -152,24 +123,22 @@ let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : run_res result
     | Int (_ , i)    -> ok @@ Fail (Failwith_int (Z.to_int i))
     | String (_ , s) -> ok @@ Fail (Failwith_string s)
     | Bytes (_, s)   -> ok @@ Fail (Failwith_bytes s)
-    | _              -> fail @@ Errors.unknown_failwith_type () )
+    | _              -> fail @@ Errors.unknown_failwith_type )
 
-let run_failwith ?options (exp:Michelson.t) (exp_type:ex_ty) : run_failwith_res result =
+let run_failwith ?options (exp:Michelson.t) (exp_type:ex_ty) : (failwith , _) result =
   let%bind expr = run_expression ?options exp exp_type in
   match expr with
-  | Success _  -> simple_fail "An error of execution was expected"
+  | Success _  -> fail Errors.unknown (* TODO : simple_fail "an error of execution was expected" *)
   | Fail res -> ok res
 
-let run_no_failwith ?options (exp:Michelson.t) (exp_type:ex_ty) : ex_typed_value result =
+let run_no_failwith ?options (exp:Michelson.t) (exp_type:ex_ty) : (ex_typed_value , _) result =
   let%bind expr = run_expression ?options exp exp_type in
   match expr with
   | Success tval  -> ok tval
-  | Fail _ -> simple_fail "Unexpected error of execution"
+  | Fail _ -> fail Errors.unknown (* TODO : simple_fail "unexpected error of execution" *)
 
 let evaluate_expression ?options exp exp_type =
   let%bind etv = run_expression ?options exp exp_type in
   match etv with
     | Success etv' -> ex_value_ty_to_michelson etv'
-    | Fail res ->
+    | Fail res -> fail @@ Errors.failwith res
-      let%bind str = failwith_to_string res in
-      fail @@ Errors.failwith str ()

src/main/uncompile/dune

@@ -11,6 +11,7 @@
     ast_typed
     mini_c
     transpiler
+    main_errors
   )
   (preprocess
     (pps ppx_let bisect_ppx --conditional)

src/main/uncompile/formatter.ml

@@ -0,0 +1,35 @@
+open Display
+open Simple_utils.Runned_result
+
+let failwith_to_string (f:failwith) : string =
+  let str = match f with
+  | Failwith_int i -> string_of_int i
+  | Failwith_string s -> Format.asprintf "\"%s\"" (String.escaped s)
+  | Failwith_bytes b ->
+    Format.asprintf "0X%a" Hex.pp (Hex.of_bytes b) in
+  Format.asprintf "failwith(%s)" str
+
+let expression_ppformat ~display_format f (runned_result,_) =
+  match display_format with
+  | Display.Human_readable | Dev -> (
+    match runned_result with
+    | Fail fail_res ->
+      let failstring = failwith_to_string fail_res in
+      Format.pp_print_string f failstring
+    | Success typed ->
+      Ast_core.PP.expression f typed
+  )
+
+let expression_jsonformat (runned_result,_) : Display.json =
+  match runned_result with
+  | Fail fail_res ->
+    let failstring = failwith_to_string fail_res in
+    `Assoc [("value", `Null) ; ("failure", `String failstring)]
+  | Success typed ->
+    let temp = Format.asprintf "%a" Ast_core.PP.expression typed in
+    `Assoc [("value", `String temp) ; ("failure", `Null)]
+
+let expression_format : 'a Display.format = {
+  pp = expression_ppformat ;
+  to_json = expression_jsonformat ;
+}

src/main/uncompile/uncompile.ml

@@ -1,25 +1,44 @@
+module Formatter = Formatter
+
+open Main_errors
 open Trace
+open Simple_utils.Runned_result
 
 type ret_type = Function | Expression
 let uncompile_value func_or_expr program entry ex_ty_value =
-  let%bind entry_expression = Ast_typed.get_entry program entry in
+  let%bind output_type =
-  let%bind output_type = match func_or_expr with
+    let%bind entry_expression = trace_option entrypoint_not_found @@ Ast_typed.get_entry program entry in
-    | Expression -> ok entry_expression.type_expression
+    match func_or_expr with
+    | Expression ->
+      ok entry_expression.type_expression
     | Function ->
-      let%bind (_,output_type) =  Ast_typed.get_t_function entry_expression.type_expression in
+      let%bind (_,output_type) = trace_option entrypoint_not_a_function @@ Ast_typed.get_t_function entry_expression.type_expression in
       ok output_type in
-  let%bind mini_c = Compiler.Uncompiler.translate_value ex_ty_value in
+  let%bind mini_c = trace uncompile_michelson @@ Compiler.Uncompiler.translate_value ex_ty_value in
-  let%bind typed = Transpiler.untranspile mini_c output_type in
+  let%bind typed =  trace uncompile_mini_c    @@ Transpiler.untranspile mini_c output_type in
-  let%bind core  = Typer.untype_expression typed in
+  let%bind core  =  trace uncompile_typed     @@ Typer.untype_expression typed in
   ok @@ core
 
-let uncompile_typed_program_entry_expression_result program entry ex_ty_value =
+let uncompile_typed_program_entry_expression_result program entry runned_result =
-  uncompile_value Expression program entry ex_ty_value
+  match runned_result with
+  | Fail s -> ok (Fail s)
+  | Success ex_ty_value ->
+    let%bind uncompiled_value = uncompile_value Expression program entry ex_ty_value in
+    ok (Success uncompiled_value)
 
-let uncompile_typed_program_entry_function_result program entry ex_ty_value =
+let uncompile_typed_program_entry_function_result program entry runned_result =
-  uncompile_value Function program entry ex_ty_value
+  match runned_result with
+  | Fail s -> ok (Fail s)
+  | Success ex_ty_value ->
+    let%bind uncompiled_value = uncompile_value Function program entry ex_ty_value in
+    ok (Success uncompiled_value)
+
+let uncompile_expression type_value runned_result =
+  match runned_result with
+  | Fail s -> ok (Fail s)
+  | Success ex_ty_value ->
+    let%bind mini_c = trace uncompile_michelson @@ Compiler.Uncompiler.translate_value ex_ty_value in
+    let%bind typed = trace uncompile_mini_c @@ Transpiler.untranspile mini_c type_value in
+    let%bind uncompiled_value = trace uncompile_typed @@ Typer.untype_expression typed in
+    ok (Success uncompiled_value)
 
-let uncompile_expression type_value ex_ty_value =
-  let%bind mini_c = Compiler.Uncompiler.translate_value ex_ty_value in
-  let%bind typed = Transpiler.untranspile mini_c type_value in
-  Typer.untype_expression typed

src/passes/01-parser/cameligo.ml

@@ -69,14 +69,6 @@ module ParserLog =
 module Unit =
   ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
 
-module Errors =
-  struct
-    let generic message =
-      let title () = ""
-      and message () = message.Region.value
-      in Trace.error ~data:[] title message
-  end
-
 let apply parser =
   let local_fail error =
     Trace.fail

src/passes/01-parser/cameligo.mli

@@ -1,13 +1,14 @@
 (** This file provides an interface to the CameLIGO parser. *)
 
+open Trace
 module AST = Parser_cameligo.AST
 
 (** Open a CameLIGO filename given by string and convert into an
     abstract syntax tree. *)
-val parse_file : string -> AST.t Trace.result
+val parse_file : string -> (AST.t , Errors.parser_error) result
 
 (** Convert a given string into a CameLIGO abstract syntax tree *)
-val parse_string : string -> AST.t Trace.result
+val parse_string : string -> (AST.t , Errors.parser_error) result
 
 (** Parse a given string as a CameLIGO expression and return an
     expression AST.
@@ -15,10 +16,10 @@ val parse_string : string -> AST.t Trace.result
     This is intended to be used for interactive interpreters, or other
     scenarios where you would want to parse a CameLIGO expression
     outside of a contract. *)
-val parse_expression : string -> AST.expr Trace.result
+val parse_expression : string -> (AST.expr , Errors.parser_error) result
 
 (** Preprocess a given CameLIGO file and preprocess it. *)
-val preprocess : string -> Buffer.t Trace.result
+val preprocess : string -> (Buffer.t , Errors.parser_error) result
 
 (** Pretty-print a given CameLIGO file (after parsing it). *)
-val pretty_print : string -> Buffer.t Trace.result
+val pretty_print : string -> (Buffer.t, Errors.parser_error) result

src/passes/01-parser/cameligo/AST.ml

@@ -496,6 +496,10 @@ let expr_to_region = function
 | ESeq {region; _}   | ERecord {region; _} | EUpdate {region; _}
 | ECodeInj {region; _} -> region
 
+let declaration_to_region = function
+| Let {region;_}
+| TypeDecl {region;_} -> region
+
 let selection_to_region = function
   FieldName f -> f.region
 | Component c -> c.region

src/passes/01-parser/cameligo/ParserLog.ml

@@ -608,6 +608,8 @@ let pattern_to_string ~offsets ~mode =
   to_string ~offsets ~mode print_pattern
 let expr_to_string ~offsets ~mode =
   to_string ~offsets ~mode print_expr
+let type_expr_to_string ~offsets ~mode =
+  to_string ~offsets ~mode print_type_expr
 
 (** {1 Pretty-printing the AST} *)
 

src/passes/01-parser/cameligo/ParserLog.mli

@@ -24,6 +24,8 @@ val pattern_to_string :
   offsets:bool -> mode:[`Point|`Byte] -> AST.pattern -> string
 val expr_to_string :
   offsets:bool -> mode:[`Point|`Byte] -> AST.expr -> string
+val type_expr_to_string :
+  offsets:bool -> mode:[`Point|`Byte] -> AST.type_expr -> string
 
 (** {1 Pretty-printing of AST nodes} *)
 

src/passes/01-parser/errors.ml

@@ -0,0 +1,78 @@
+open Trace
+open Simple_utils.Display
+
+type parser_error = [
+  | `Parser_generic of string Region.reg
+  | `Parser_wrong_function_arguments of Parser_cameligo.AST.expr
+  | `Parser_invalid_wild of Parser_cameligo.AST.expr
+  ]
+
+let stage = "parser"
+
+let generic reg = `Parser_generic reg
+let wrong_function_arguments expr = `Parser_wrong_function_arguments expr
+let invalid_wild expr = `Parser_invalid_wild expr
+
+let wrong_function_msg =
+  "It looks like you are defining a function, \
+   however we do not\n\
+   understand the parameters declaration.\n\
+   Examples of valid functions:\n\
+   let x = (a: string, b: int) : int => 3;\n\
+   let tuple = ((a, b): (int, int)) => a + b; \n\
+   let x = (a: string) : string => \"Hello, \" ++ a;\n"
+let wild_pattern_msg =
+  "It looks like you are using a wild pattern where it cannot be used"
+
+
+let error_ppformat : display_format:string display_format ->
+  Format.formatter -> parser_error -> unit =
+  fun ~display_format f a ->
+  match display_format with
+  | Human_readable | Dev -> (
+    match a with
+    | `Parser_generic reg ->
+      Format.pp_print_string f reg.Region.value ;
+
+    | `Parser_wrong_function_arguments expr ->
+      let loc = Format.asprintf "%a"
+        Location.pp_lift @@ Parser_cameligo.AST.expr_to_region expr in
+      let s = Format.asprintf "%s\n%s" loc wrong_function_msg in
+      Format.pp_print_string f s ;
+
+    | `Parser_invalid_wild expr ->
+      let loc = Format.asprintf "%a"
+        Location.pp_lift @@ Parser_cameligo.AST.expr_to_region expr in
+      let s = Format.asprintf "%s\n%s" loc wild_pattern_msg in
+      Format.pp_print_string f s ;
+  )
+
+let error_jsonformat : parser_error -> J.t = fun a ->
+  let json_error ~stage ~content =
+    `Assoc [
+      ("status", `String "error") ;
+      ("stage", `String stage) ;
+      ("content",  content )]
+  in
+  match a with
+  | `Parser_generic reg ->
+    let content = `Assoc [
+      ("message", `String reg.Region.value); ]
+    in
+    json_error ~stage ~content
+  | `Parser_wrong_function_arguments expr ->
+    let loc = Format.asprintf "%a" Location.pp_lift @@
+      Parser_cameligo.AST.expr_to_region expr in
+    let content = `Assoc [
+      ("message", `String wrong_function_msg);
+      ("location", `String loc); ]
+    in
+    json_error ~stage ~content
+  | `Parser_invalid_wild expr ->
+    let loc = Format.asprintf "%a" Location.pp_lift @@
+      Parser_cameligo.AST.expr_to_region expr in
+    let content = `Assoc [
+      ("message", `String wild_pattern_msg); 
+      ("location", `String loc); ]
+    in
+    json_error ~stage ~content

src/passes/01-parser/formatter.ml

@@ -0,0 +1,14 @@
+open Display
+
+let ppx_ppformat ~display_format f (buf,_) =
+  match display_format with
+  | Human_readable | Dev -> Format.fprintf f "%s" (Buffer.contents buf)
+
+let ppx_jsonformat (buf,_) : json =
+  let s = Format.asprintf "%s" (Buffer.contents buf) in
+  `String s
+
+let ppx_format : 'a format = {
+  pp = ppx_ppformat;
+  to_json = ppx_jsonformat;
+}

src/passes/01-parser/parser.ml

@@ -1,5 +1,5 @@
 module Pascaligo = Pascaligo
 module Cameligo = Cameligo
 module Reasonligo = Reasonligo
-
+module Errors = Errors
-
+module Formatter = Formatter

src/passes/01-parser/pascaligo.ml

@@ -68,14 +68,6 @@ module ParserLog =
 module Unit =
   ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
 
-module Errors =
-  struct
-    let generic message =
-      let title () = ""
-      and message () = message.Region.value
-      in Trace.error ~data:[] title message
-  end
-
 let apply parser =
   let local_fail error =
     Trace.fail

src/passes/01-parser/pascaligo.mli

@@ -1,13 +1,15 @@
 (** This file provides an interface to the PascaLIGO parser. *)
 
+open Errors
+open Trace
 module AST = Parser_pascaligo.AST
 
 (** Open a PascaLIGO filename given by string and convert into an
     abstract syntax tree. *)
-val parse_file : string -> AST.t Trace.result
+val parse_file : string -> (AST.t, parser_error) result
 
 (** Convert a given string into a PascaLIGO abstract syntax tree *)
-val parse_string : string -> AST.t Trace.result
+val parse_string : string -> (AST.t, parser_error) result
 
 (** Parse a given string as a PascaLIGO expression and return an
     expression AST.
@@ -15,7 +17,7 @@ val parse_string : string -> AST.t Trace.result
     This is intended to be used for interactive interpreters, or other
     scenarios where you would want to parse a PascaLIGO expression
     outside of a contract. *)
-val parse_expression : string -> AST.expr Trace.result
+val parse_expression : string -> (AST.expr, parser_error) result
 
 (** Preprocess a given PascaLIGO file and preprocess it. *)
-val preprocess : string -> Buffer.t Trace.result
+val preprocess : string -> (Buffer.t, parser_error) result

src/passes/01-parser/pascaligo/AST.ml

@@ -807,6 +807,12 @@ let pattern_to_region = function
 | PList PCons {region; _}
 | PTuple      {region; _} -> region
 
+let declaration_to_region = function
+  TypeDecl {region;_}
+| ConstDecl {region;_}
+| FunDecl {region;_}
+| AttrDecl {region;_} -> region
+
 let lhs_to_region : lhs -> Region.t = function
   Path path -> path_to_region path
 | MapPath {region; _} -> region

src/passes/01-parser/pascaligo/ParserLog.ml

@@ -866,6 +866,8 @@ let pattern_to_string ~offsets ~mode =
   to_string ~offsets ~mode print_pattern
 let instruction_to_string ~offsets ~mode =
   to_string ~offsets ~mode print_instruction
+let type_expr_to_string ~offsets ~mode =
+  to_string ~offsets ~mode print_type_expr
 
 (* Pretty-printing the AST *)
 

src/passes/01-parser/pascaligo/ParserLog.mli

@@ -30,6 +30,8 @@ val pattern_to_string :
   offsets:bool -> mode:[`Point|`Byte] -> AST.pattern -> string
 val instruction_to_string :
   offsets:bool -> mode:[`Point|`Byte] -> AST.instruction -> string
+val type_expr_to_string :
+  offsets:bool -> mode:[`Point|`Byte] -> AST.type_expr -> string
 
 (** {1 Pretty-printing of AST nodes} *)
 

src/passes/01-parser/reasonligo.ml

@@ -1,5 +1,3 @@
-open Trace
-
 module AST         = Parser_cameligo.AST
 module LexToken    = Parser_reasonligo.LexToken
 module Lexer       = Lexer.Make (LexToken)
@@ -72,42 +70,6 @@ module ParserLog =
 module Unit =
   ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
 
-module Errors =
-  struct
-    let generic message =
-      let title () = ""
-      and message () = message.Region.value
-      in Trace.error ~data:[] title message
-
-    let wrong_function_arguments (expr: AST.expr) =
-      let title () = "" in
-      let message () =
-        "It looks like you are defining a function, \
-         however we do not\n\
-         understand the parameters declaration.\n\
-         Examples of valid functions:\n\
-         let x = (a: string, b: int) : int => 3;\n\
-         let tuple = ((a, b): (int, int)) => a + b; \n\
-         let x = (a: string) : string => \"Hello, \" ++ a;\n" in
-      let expression_loc = AST.expr_to_region expr in
-      let data = [
-        ("location",
-         fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)]
-      in error ~data title message
-
-    let invalid_wild (expr: AST.expr) =
-      let title () = "" in
-      let message () =
-        "It looks like you are using a wild pattern where it cannot be used."
-      in
-      let expression_loc = AST.expr_to_region expr in
-      let data = [
-        ("location",
-         fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)]
-      in error ~data title message
-
-  end
-
 let apply parser =
   let local_fail error =
     Trace.fail

src/passes/01-parser/reasonligo.mli

@@ -1,13 +1,14 @@
 (** This file provides an interface to the ReasonLIGO parser. *)
 
+open Trace
 module AST = Parser_cameligo.AST
 
 (** Open a ReasonLIGO filename given by string and convert into an
     abstract syntax tree. *)
-val parse_file : string -> AST.t Trace.result
+val parse_file : string -> (AST.t , Errors.parser_error) result
 
 (** Convert a given string into a ReasonLIGO abstract syntax tree *)
-val parse_string : string -> AST.t Trace.result
+val parse_string : string -> (AST.t , Errors.parser_error) result
 
 (** Parse a given string as a ReasonLIGO expression and return an
     expression AST.
@@ -15,10 +16,10 @@ val parse_string : string -> AST.t Trace.result
     This is intended to be used for interactive interpreters, or other
     scenarios where you would want to parse a ReasonLIGO expression
     outside of a contract. *)
-val parse_expression : string -> AST.expr Trace.result
+val parse_expression : string -> (AST.expr , Errors.parser_error) result
 
 (** Preprocess a given ReasonLIGO file and preprocess it. *)
-val preprocess : string -> Buffer.t Trace.result
+val preprocess : string -> (Buffer.t , Errors.parser_error) result
 
 (** Pretty-print a given CameLIGO file (after parsing it). *)
-val pretty_print : string -> Buffer.t Trace.result
+val pretty_print : string -> (Buffer.t , Errors.parser_error) result

src/passes/02-concrete_to_imperative/cameligo.ml

@@ -1,5 +1,6 @@
 [@@@warning "-45"]
 
+open Errors_cameligo
 open Trace
 open Ast_imperative
 
@@ -18,152 +19,6 @@ 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 () =
-      match actual with
-      | Raw.PVar v -> v.value
-      | Raw.PTuple _ -> "tuple"
-      | Raw.PRecord _ -> "record"
-      | Raw.PList _ -> "list"
-      | Raw.PBytes _ -> "bytes"
-      | _ -> "other"
-    in
-    let data = [
-      ("expected", fun () -> expected_name);
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@
-                Raw.pattern_to_region actual)]
-    in error ~data title message
-
-  let unsupported_let_in_function (region : Region.t) (patterns : Raw.pattern list) =
-    let title () = "" in
-    let message () = "\nDefining functions with \"let ... in\" \
-                      is not supported yet.\n" in
-    let patterns_loc =
-      List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p))
-        region patterns in
-    let data = [
-      ("location",
-       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\".\n"
-                      name.Region.value in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region)]
-    in error ~data title message
-
-  let untyped_fun_param var =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nUntyped function parameters \
-                       are not supported yet.\n" in
-    let param_loc = var.Region.region in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ param_loc)]
-    in error ~data title message
-
-  let untyped_recursive_function var =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nUntyped recursive functions \
-                       are not supported yet.\n" in
-    let param_loc = var.Region.region in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ param_loc)]
-    in error ~data title message
-
-  let unsupported_tuple_pattern p =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nTuple patterns are not supported yet.\n" in
-    let pattern_loc = Raw.pattern_to_region p in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
-    ] in
-    error ~data title message
-
-  let unsupported_cst_constr p =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nConstant constructors are not supported yet.\n" in
-    let pattern_loc = Raw.pattern_to_region p in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)]
-    in error ~data title message
-
-  let unsupported_non_var_pattern p =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nNon-variable patterns in constructors \
-                       are not supported yet.\n" in
-    let pattern_loc = Raw.pattern_to_region p in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
-    ] in
-    error ~data title message
-
-  let abstracting_expr t =
-    let title () = "abstracting expression" in
-    let message () = "" in
-    let data = [
-        ("expression" ,
-         (** TODO: The labelled arguments should be flowing from the CLI. *)
-       thunk @@ Parser_cameligo.ParserLog.expr_to_string
-                 ~offsets:true ~mode:`Point t)]
-    in error ~data title message
-
-  let only_constructors p =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nCurrently, only constructors are \
-                       supported in patterns.\n" in
-    let pattern_loc = Raw.pattern_to_region p in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
-    ] in
-    error ~data title message
-
-  let unsupported_sugared_lists region =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nCurrently, only empty lists and \
-                       constructors (::) \
-                       are supported in patterns.\n" in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ region)]
-    in error ~data title message
-
-  let corner_case description =
-    let title () = "Corner case" in
-    let message () = description in
-    error title message
-
-  let unknown_built_in name =
-    let title () = "\n Unknown built-in function" in
-    let message () = "" in
-    let data = [
-      ("built-in", fun  () -> name);
-    ] in
-    error ~data title message
-
-end
-
-open Errors
-
 open Operators.Concrete_to_imperative.Cameligo
 
 let r_split = Location.r_split
@@ -226,8 +81,8 @@ and unpar_pattern : Raw.pattern -> Raw.pattern = function
   | PPar p -> unpar_pattern p.value.inside
   | _ as p -> p
 
-and compile_type_expression : Raw.type_expr -> type_expression result = fun te ->
+and compile_type_expression : Raw.type_expr -> (type_expression, abs_error) result = fun te ->
-  trace (simple_info "abstracting this type expression...") @@
+  trace (abstracting_type_expr_tracer te) @@
   match te with
     TPar x -> compile_type_expression x.value.inside
   | TVar v -> (
@@ -255,38 +110,39 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
           (match lst with
           | [a ; b ; c ; d ] -> (
             let%bind b' =
-              trace_option (simple_error "second argument of michelson_or must be a string singleton") @@
+              trace_option (michelson_type_wrong te name.value) @@
                 get_t_string_singleton_opt b in
             let%bind d' =
-              trace_option (simple_error "fourth argument of michelson_or must be a string singleton") @@
+              trace_option (michelson_type_wrong te name.value) @@
                 get_t_string_singleton_opt d in
             let%bind a' = compile_type_expression a in
             let%bind c' = compile_type_expression c in
             ok @@ t_michelson_or ~loc a' b' c' d'
             )
-          | _ -> simple_fail "michelson_or does not have the right number of argument")
+          | _ -> fail @@ michelson_type_wrong_arity loc name.value)
         | "michelson_pair" ->
           let lst = npseq_to_list tuple.value.inside in
           (match lst with
           | [a ; b ; c ; d ] -> (
             let%bind b' =
-              trace_option (simple_error "second argument of michelson_pair must be a string singleton") @@
+              trace_option (michelson_type_wrong te name.value) @@
                 get_t_string_singleton_opt b in
             let%bind d' =
-              trace_option (simple_error "fourth argument of michelson_pair must be a string singleton") @@
+              trace_option (michelson_type_wrong te name.value) @@
                 get_t_string_singleton_opt d in
             let%bind a' = compile_type_expression a in
             let%bind c' = compile_type_expression c in
             ok @@ t_michelson_pair ~loc a' b' c' d'
             )
-          | _ -> simple_fail "michelson_pair does not have the right number of argument")
+          | _ -> fail @@ michelson_type_wrong_arity loc name.value)
         | _ ->
           let lst = npseq_to_list tuple.value.inside in
           let%bind lst' = bind_map_list compile_type_expression lst in
           let%bind cst =
           trace_option (unknown_predefined_type name) @@
             type_operators name.value in
-          ok @@ t_operator ~loc cst lst' )
+          ok @@ t_operator ~loc cst lst'
+      )
     )
   | TProd p -> (
       let%bind tpl = compile_list_type_expression  @@ npseq_to_list p.value in
@@ -321,9 +177,9 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
         @@ npseq_to_list s in
       let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in
       ok @@ make_t ~loc @@ T_sum m
-  | TString _s -> simple_fail "we don't support singleton string type"
+  | TString _s -> fail @@ unsupported_string_singleton te
 
-and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
+and compile_list_type_expression (lst:Raw.type_expr list) : (type_expression , abs_error) result =
   match lst with
   | [] -> ok @@ t_unit ()
   | [hd] -> compile_type_expression hd
@@ -332,7 +188,7 @@ and compile_list_type_expression (lst:Raw.type_expr list) : type_expression resu
       ok @@ t_tuple lst
 
 let rec compile_expression :
-  Raw.expr -> expr result = fun t ->
+  Raw.expr -> (expr , abs_error) result = fun t ->
   let return x = ok x in
   let compile_projection = fun (p:Raw.projection Region.reg) ->
     let (p , loc) = r_split p in
@@ -377,7 +233,7 @@ let compile_update (u: Raw.update Region.reg) =
   let aux ur ((var, path), expr) =
     ok @@ e_update ~loc ur (Access_record var :: path) expr
   in bind_fold_list aux record updates'
-in trace (abstracting_expr t) @@
+in trace (abstracting_expr_tracer t) @@
   match t with
     Raw.ELetIn e ->
       let Raw.{kwd_rec; binding; body; attributes; _} = e.value in
@@ -464,7 +320,7 @@ in trace (abstracting_expr t) @@
                 | Some t -> ok @@ t
                 | None -> match rhs'.expression_content with
                       | E_ascription a -> ok a.type_annotation
-                      | _ -> fail @@ untyped_recursive_function e
+                      | _ -> fail @@ untyped_recursive_fun e.Region.region
               in
               let expression_content = E_recursive {fun_name;fun_type;lambda} in
               let expression_content = E_let_in {li with rhs = {li.rhs with  expression_content}} in
@@ -476,7 +332,7 @@ in trace (abstracting_expr t) @@
 
       (* let f p1 ps... = rhs in body *)
       | (f, p1 :: ps) ->
-        fail @@ unsupported_let_in_function e.region (f :: p1 :: ps)
+        fail @@ unsupported_let_in_function (f :: p1 :: ps)
       end
   | Raw.EAnnot a ->
       let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in
@@ -643,7 +499,7 @@ in trace (abstracting_expr t) @@
      let%bind code = compile_expression ci.code
      in ok @@ e_raw_code ~loc language code
 
-and compile_fun lamb' : expr result =
+and compile_fun lamb' : (expr , abs_error) result =
   let return x = ok x in
   let (lamb , loc) = r_split lamb' in
   let%bind params' =
@@ -754,7 +610,7 @@ and compile_fun lamb' : expr result =
   return @@ ret_lamb
 
 
-and compile_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
+and compile_logic_expression ?te_annot (t:Raw.logic_expr) : (expr , abs_error) result =
   let return x = ok @@ make_option_typed x te_annot in
   match t with
   | BoolExpr (False reg) -> (
@@ -784,7 +640,7 @@ and compile_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
   | CompExpr (Neq c) ->
       compile_binop "NEQ" c
 
-and compile_list_expression (t:Raw.list_expr) : expression result =
+and compile_list_expression (t:Raw.list_expr) : (expression , abs_error) result =
   let return x = ok @@ x in
   match t with
     ECons c -> compile_binop "CONS" c
@@ -796,7 +652,7 @@ and compile_list_expression (t:Raw.list_expr) : expression result =
       return @@ e_list ~loc lst'
     )
 
-and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
+and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : (expression , abs_error) result =
   let return x = ok @@ x in
   let (args , loc) = r_split t in
   let%bind a = compile_expression args.arg1 in
@@ -804,14 +660,14 @@ and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result
   let%bind name = trace_option (unknown_built_in name) @@ constants name in
   return @@ e_constant ~loc name [ a ; b ]
 
-and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
+and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : (expression , abs_error) result =
   let return x = ok @@ x in
   let (t , loc) = r_split t in
   let%bind a = compile_expression t.arg in
   let%bind name = trace_option (unknown_built_in name) @@ constants name in
   return @@ e_constant ~loc name [ a ]
 
-and compile_tuple_expression ?loc (lst:Raw.expr list) : expression result =
+and compile_tuple_expression ?loc (lst:Raw.expr list) : (expression , abs_error) result =
   let return x = ok @@ x in
   match lst with
   | [] -> return @@ e_literal ?loc Literal_unit
@@ -820,7 +676,7 @@ and compile_tuple_expression ?loc (lst:Raw.expr list) : expression result =
       let%bind lst = bind_list @@ List.map compile_expression lst in
       return @@ e_tuple ?loc lst
 
-and compile_declaration : Raw.declaration -> declaration Location.wrap list result =
+and compile_declaration : Raw.declaration -> (declaration Location.wrap list , abs_error) result =
   fun t ->
   let open! Raw in
   let loc : 'a . 'a Raw.reg -> _ -> _ =
@@ -879,7 +735,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu
                      gen_access_tuple name ~i: (i + 1) ~accesses
                  in ok (gen_access_tuple name)
                (* TODO: Improve this error message *)
-               | other -> fail @@ abstracting_expr other
+               | other -> fail @@ bad_deconstruction other
           in let%bind decls =
                (* TODO: Rewrite the gen_access_tuple so there's no List.rev *)
                bind_map_list process_variable (List.combine variables (List.rev expr_bind_lst))
@@ -937,7 +793,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu
         | Some _ -> match rhs'.expression_content with
           E_lambda lambda ->
             (match lhs_type with
-              None -> fail @@ untyped_recursive_function var
+              None -> fail @@ untyped_recursive_fun var.Region.region
               | Some (lhs_type) ->
               let expression_content = E_recursive {fun_name=binder;fun_type=lhs_type;lambda} in
               ok @@ {rhs' with expression_content})
@@ -946,7 +802,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu
       ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))]
     )
 
-and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
+and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error) result =
   fun t ->
   let open Raw in
   let rec get_var (t:Raw.pattern) =
@@ -962,8 +818,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
   let get_single (t:Raw.pattern) =
     let t' = get_tuple t in
     let%bind () =
-      trace_strong (unsupported_tuple_pattern t) @@
+      Assert.assert_list_size (unsupported_tuple_pattern t) t' 1 in
-      Assert.assert_list_size t' 1 in
     ok (List.hd t') in
   let rec get_constr (t:Raw.pattern) =
     match t with
@@ -1009,8 +864,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
   let%bind patterns =
     let aux (x , y) =
       let xs = get_tuple x in
-      trace_strong (unsupported_tuple_pattern x) @@
+      let%bind () = Assert.assert_list_size (unsupported_tuple_pattern x) xs 1 in
-      Assert.assert_list_size xs 1 >>? fun () ->
       ok (List.hd xs , y)
     in
     bind_map_list aux t in
@@ -1021,8 +875,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
   | [(PList (PCons c), cons); (PList (PListComp sugar_nil), nil)]
   | [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] ->
       let%bind () =
-        trace_strong (unsupported_sugared_lists sugar_nil.region)
+        Assert.assert_list_empty (unsupported_sugared_lists sugar_nil.region)
-        @@ Assert.assert_list_empty
         @@ pseq_to_list
         @@ sugar_nil.value.elements in
       let%bind (a, b) =
@@ -1032,27 +885,18 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
         ok (a, b) in
       ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons); match_nil=nil}
   | lst ->
-      let error x =
-        let title () = "Pattern" in
-         (** TODO: The labelled arguments should be flowing from the CLI. *)
-        let content () =
-          Printf.sprintf "Pattern : %s"
-                         (Parser_cameligo.ParserLog.pattern_to_string
-                            ~offsets:true ~mode:`Point x) in
-        error title content
-      in
       let as_variant () =
-        trace (simple_info "currently, only booleans, lists, options, and constructors \
+        trace_strong (unsupported_pattern_type (List.map fst lst)) @@
-                            are supported in patterns") @@
         let%bind constrs =
           let aux (x, y) =
-            let%bind x' = trace (error x) @@ get_constr x
+            let%bind x' = get_constr x
             in ok (x', y)
           in bind_map_list aux lst
         in ok @@ ez_match_variant constrs in
       let as_option () =
+        trace_strong (unsupported_pattern_type (List.map fst lst)) @@
         let aux (x, y) =
-          let%bind x' = trace (error x) @@ get_constr_opt x
+          let%bind x' = get_constr_opt x
           in ok (x', y) in
         let%bind constrs = bind_map_list aux lst in
         match constrs with
@@ -1063,9 +907,12 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
            ok @@ Match_option {
                     match_some = (Var.of_name some_var, some_expr);
                     match_none = none_expr }
-        | _ -> simple_fail "bad option pattern"
+        | _ -> fail @@ corner_case "bad option pattern"
       in bind_or (as_option () , as_variant ())
 
-let compile_program : Raw.ast -> program result = fun t ->
+let compile_program : Raw.ast -> (program , abs_error) result = fun t ->
-  let%bind decls = bind_map_list compile_declaration @@ nseq_to_list t.decl in
+  let declarations = nseq_to_list t.decl in
+  let%bind decls =
+    trace (program_tracer declarations) @@
+    bind_map_list compile_declaration declarations in
   ok @@ List.concat @@ decls

src/passes/02-concrete_to_imperative/cameligo.mli

@@ -7,56 +7,8 @@ module Raw = Parser.Cameligo.AST
 module SMap = Map.String
 module Option = Simple_utils.Option
 
-(*
-val nseq_to_list : 'a * 'a list -> 'a list 
-val npseq_to_list : 'a * ( 'b * 'a ) list -> 'a list 
-*)
 val npseq_to_nelist : 'a * ( 'b * 'c ) list -> 'a * 'c list 
-(*
-val pseq_to_list : ('a * ('b * 'a) list) option -> 'a list
-val get_value : 'a Raw.reg -> 'a
-*)
 
-module Errors : sig 
+val compile_expression : Raw.expr -> (expr, Errors_cameligo.abs_error) result
-  (*
-  val wrong_pattern : string -> Raw.pattern -> unit -> error
-  val multiple_patterns : string -> Raw.pattern list -> unit -> error
-  val unknown_predefined_type : string Raw.reg -> unit -> error
-  val unsupported_arith_op : Raw.expr -> unit -> error
-  val unsupported_string_catenation : Raw.expr -> unit -> error
-  val untyped_fun_param : 'a Raw.reg -> unit -> error
-  val unsupported_tuple_pattern : Raw.pattern -> unit -> error
-  val unsupported_cst_constr : Raw.pattern -> unit -> error
-  val unsupported_non_var_pattern : Raw.pattern -> unit -> error
-  val abstracting_expr : Raw.expr -> unit -> error
-  val only_constructors : Raw.pattern -> unit -> error
-  val unsupported_sugared_lists : Raw.wild -> unit -> error
-  val bad_set_definition : unit -> error
-  val bad_list_definition : unit -> error
-  val bad_map_definition : unit -> error
-  val corner_case : loc:string -> string -> unit -> error
-  *)
-end
 
-
+val compile_program : Raw.ast -> (program, Errors_cameligo.abs_error) result
-(*
-val r_split : 'a Raw.reg -> 'a * Location.t
-val pattern_to_var : Raw.pattern -> Raw.variable result
-val pattern_to_typed_var : Raw.pattern -> ( Raw.variable * Raw.type_expr option ) result
-val expr_to_typed_expr : Raw.expr -> ( Raw.expr * Raw.type_expr option ) result
-val patterns_to_var : Raw.pattern list -> Raw.variable result
-val compile_type_expression : Raw.type_expr -> type_expression result
-val compile_list_type_expression : Raw.type_expr list -> type_expression result
-*)
-val compile_expression : Raw.expr -> expr result
-(*
-val compile_fun : Raw.fun_expr Raw.reg -> expr result 
-val compile_logic_expression : ?te_annot:type_expression -> Raw.logic_expr -> expr result
-val compile_list_expression : Raw.list_expr -> expression result
-val compile_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result 
-val compile_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result
-val compile_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result
-val compile_declaration : Raw.declaration -> declaration Location.wrap result
-val compile_cases : (Raw.pattern * 'a) list -> 'a matching result
-*)
-val compile_program : Raw.ast -> program result

src/passes/02-concrete_to_imperative/concrete_to_imperative.ml

@@ -1,2 +1,4 @@
+module Errors_cameligo = Errors_cameligo
+module Errors_pascaligo = Errors_pascaligo
 module Pascaligo = Pascaligo
 module Cameligo = Cameligo

src/passes/02-concrete_to_imperative/dune

@@ -7,7 +7,7 @@
     parser
     ast_imperative
     operators)
-  (modules cameligo pascaligo concrete_to_imperative)
+  (modules errors_cameligo errors_pascaligo cameligo pascaligo concrete_to_imperative)
   (preprocess
     (pps
       ppx_let

src/passes/02-concrete_to_imperative/errors_cameligo.ml

@@ -0,0 +1,316 @@
+open Trace
+open Simple_utils.Display
+
+module Raw = Parser_cameligo.AST
+
+let stage = "abstracter"
+
+type abs_error = [
+  | `Concrete_cameligo_wrong_pattern of string * Raw.pattern
+  | `Concrete_cameligo_unsupported_let_in of Raw.pattern list
+  | `Concrete_cameligo_unknown_predefined_type of Raw.type_constr
+  | `Concrete_cameligo_untyped_fun_param of Raw.variable
+  | `Concrete_cameligo_recursive_fun of Region.t
+  | `Concrete_cameligo_unsupported_tuple_pattern of Raw.pattern
+  | `Concrete_cameligo_unsupported_constant_constr of Raw.pattern
+  | `Concrete_cameligo_unsupported_non_var_pattern of Raw.pattern
+  | `Concrete_cameligo_unsupported_pattern_type of Raw.pattern list
+  | `Concrete_cameligo_unsupported_string_singleton of Raw.type_expr
+  | `Concrete_cameligo_abstraction_tracer of Raw.expr * abs_error
+  | `Concrete_cameligo_abstraction_type_tracer of Raw.type_expr * abs_error
+  | `Concrete_cameligo_bad_deconstruction of Raw.expr
+  | `Concrete_cameligo_only_constructors of Raw.pattern
+  | `Concrete_cameligo_unsupported_sugared_lists of Raw.wild
+  | `Concrete_cameligo_corner_case of string
+  | `Concrete_cameligo_unknown_built_in of string
+  | `Concrete_cameligo_michelson_type_wrong of Raw.type_expr * string
+  | `Concrete_cameligo_michelson_type_wrong_arity of Location.t * string
+  | `Concrete_cameligo_program_tracer of Raw.declaration list * abs_error
+  ]
+
+let wrong_pattern expected actual = `Concrete_cameligo_wrong_pattern (expected,actual)
+let unsupported_let_in_function patterns = `Concrete_cameligo_unsupported_let_in patterns
+let unknown_predefined_type name = `Concrete_cameligo_unknown_predefined_type name
+let untyped_fun_param var = `Concrete_cameligo_untyped_fun_param var
+let untyped_recursive_fun reg = `Concrete_cameligo_recursive_fun reg
+let unsupported_tuple_pattern p = `Concrete_cameligo_unsupported_tuple_pattern p
+let unsupported_cst_constr p = `Concrete_cameligo_unsupported_constant_constr p
+let unsupported_non_var_pattern p = `Concrete_cameligo_unsupported_non_var_pattern p
+let unsupported_pattern_type pl = `Concrete_cameligo_unsupported_pattern_type pl
+let unsupported_string_singleton te = `Concrete_cameligo_unsupported_string_singleton te
+let abstracting_expr_tracer t err = `Concrete_cameligo_abstraction_tracer (t,err)
+let abstracting_type_expr_tracer t err = `Concrete_cameligo_abstraction_type_tracer (t,err)
+let bad_deconstruction t = `Concrete_cameligo_bad_deconstruction t
+let only_constructors p = `Concrete_cameligo_only_constructors p
+let unsupported_sugared_lists region = `Concrete_cameligo_unsupported_sugared_lists region
+let corner_case desc = `Concrete_cameligo_corner_case desc
+let unknown_built_in name = `Concrete_cameligo_unknown_built_in name
+let michelson_type_wrong texpr name = `Concrete_cameligo_michelson_type_wrong (texpr,name)
+let michelson_type_wrong_arity loc name = `Concrete_cameligo_michelson_type_wrong_arity (loc,name)
+let program_tracer decl err = `Concrete_cameligo_program_tracer (decl,err)
+
+let rec error_ppformat : display_format:string display_format ->
+  Format.formatter -> abs_error -> unit =
+  fun ~display_format f a ->
+  match display_format with
+  | Human_readable | Dev -> (
+    match a with
+    | `Concrete_cameligo_wrong_pattern (expected_name,actual) ->
+      Format.fprintf f
+        "@[<hv>%a@Wrong pattern: expected %s got %s@]"
+        Location.pp_lift (Raw.pattern_to_region actual)
+        (Parser_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point actual)
+        expected_name
+    | `Concrete_cameligo_unsupported_let_in expr ->
+      Format.fprintf f
+        "@[<hv>%a@Defining functions with \"let ... in\" is not supported yet@]"
+        Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost expr)
+    | `Concrete_cameligo_unknown_predefined_type type_name ->
+      Format.fprintf f
+        "@[<hv>%a@Unknown predefined type \"%s\"@]"
+        Location.pp_lift type_name.Region.region
+        type_name.Region.value
+    | `Concrete_cameligo_untyped_fun_param variable ->
+      Format.fprintf f
+        "@[<hv>%a@Untyped function parameters are not supported yet@]"
+        Location.pp_lift variable.Region.region
+    | `Concrete_cameligo_recursive_fun reg ->
+      Format.fprintf f
+        "@[<hv>%a@Untyped recursive functions are not supported yet@]"
+        Location.pp_lift reg
+    | `Concrete_cameligo_unsupported_tuple_pattern p ->
+      Format.fprintf f
+        "@[<hv>%a@The following tuple pattern is not supported yet:@\"%s\"@]"
+        Location.pp_lift (Raw.pattern_to_region p)
+        (Parser_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point p)
+    | `Concrete_cameligo_unsupported_constant_constr p ->
+      Format.fprintf f
+        "@[<hv>%a@Constant constructors are not supported yet@]"
+        Location.pp_lift (Raw.pattern_to_region p)
+    | `Concrete_cameligo_unsupported_non_var_pattern p ->
+      Format.fprintf f
+        "@[<hv>%a@Non-variable patterns in constructors are not supported yet@]"
+        Location.pp_lift (Raw.pattern_to_region p)
+    | `Concrete_cameligo_unsupported_pattern_type pl ->
+      Format.fprintf f
+        "@[<hv>%a@Currently, only booleans, lists, options, and constructors are supported in patterns@]"
+        Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost pl)
+    | `Concrete_cameligo_unsupported_string_singleton te ->
+      Format.fprintf f
+        "@[<hv>%a@Unsupported singleton string type@]"
+        Location.pp_lift (Raw.type_expr_to_region te)
+    | `Concrete_cameligo_abstraction_tracer (expr,err) ->
+      Format.fprintf f
+        "@[<hv>%a@Abstracting expression:@\"%s\"@%a@]"
+        Location.pp_lift (Raw.expr_to_region expr)
+        (Parser_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point expr)
+        (error_ppformat ~display_format) err
+    | `Concrete_cameligo_abstraction_type_tracer (te,err) ->
+      Format.fprintf f
+        "@[<hv>%a@Abstracting type expression:@\"%s\"@%a@]"
+        Location.pp_lift (Raw.type_expr_to_region te)
+        (Parser_cameligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point te)
+        (error_ppformat ~display_format) err
+    | `Concrete_cameligo_bad_deconstruction expr ->
+      Format.fprintf f
+        "@[<hv>%a@Bad tuple deconstruction \"%s\"@]"
+        Location.pp_lift (Raw.expr_to_region expr)
+        (Parser_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point expr)
+    | `Concrete_cameligo_only_constructors p ->
+      Format.fprintf f
+        "@[<hv>%a@Currently, only constructors are supported in patterns@]"
+        Location.pp_lift (Raw.pattern_to_region p)
+    | `Concrete_cameligo_unsupported_sugared_lists wild ->
+      Format.fprintf f
+        "@[<hv>%a@Currently, only empty lists and constructors (::) are supported in patterns@]"
+        Location.pp_lift wild
+    | `Concrete_cameligo_corner_case desc ->
+      Format.fprintf f "Corner case: %s" desc
+    | `Concrete_cameligo_unknown_built_in bi ->
+      Format.fprintf f "Unknown built-in function %s" bi
+    | `Concrete_cameligo_michelson_type_wrong (texpr,name) ->
+      Format.fprintf f
+        "@[<hv>%a@Argument %s of %s must be a string singleton@]"
+          Location.pp_lift (Raw.type_expr_to_region texpr)
+          (Parser_cameligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point texpr)
+          name
+    | `Concrete_cameligo_michelson_type_wrong_arity (loc,name) ->
+      Format.fprintf f
+        "@[<hv>%a@%s does not have the right number of argument@]"
+        Location.pp loc
+        name
+    | `Concrete_cameligo_program_tracer (decl,err) ->
+      Format.fprintf f
+        "@[<hv>%a@Abstracting program@%a@]"
+        Location.pp_lift (List.fold_left (fun a d -> Region.cover a (Raw.declaration_to_region d)) Region.ghost decl)
+        (error_ppformat ~display_format) err
+  )
+
+
+let rec error_jsonformat : abs_error -> J.t = fun a ->
+  let json_error ~stage ~content =
+    `Assoc [
+      ("status", `String "error") ;
+      ("stage", `String stage) ;
+      ("content",  content )]
+  in
+  match a with
+  | `Concrete_cameligo_wrong_pattern (expected_name,actual) ->
+    let message = `String "wrong pattern" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region actual) in
+    let actual = (Parser_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point actual) in
+    let content = `Assoc [
+      ("message", message);
+      ("location", `String loc);
+      ("expected", `String expected_name);
+      ("actual", `String actual) ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_unsupported_let_in expr ->
+    let message = `String "Defining functions with \"let ... in\" is not supported yet" in
+    let loc = Format.asprintf "%a"
+      Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost expr) in
+    let content = `Assoc [
+      ("message", message);
+      ("location", `String loc)] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_unknown_predefined_type type_name ->
+    let message = `String "Unknown predefined type" in
+    let t = `String type_name.Region.value in
+    let loc = Format.asprintf "%a" Location.pp_lift type_name.Region.region in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);
+      ("type", t ) ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_untyped_fun_param variable ->
+    let message = `String "Untyped function parameters are not supported yet" in
+    let loc = Format.asprintf "%a" Location.pp_lift variable.Region.region in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_recursive_fun reg ->
+    let message = `String "Untyped recursive functions are not supported yet" in
+    let loc = Format.asprintf "%a" Location.pp_lift reg in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_unsupported_tuple_pattern p ->
+    let message = `String "The following tuple pattern is not supported yet" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
+    let pattern = Parser_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point p in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);
+      ("pattern", `String pattern); ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_unsupported_constant_constr p ->
+    let message = `String "Constant constructors are not supported yet" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_unsupported_non_var_pattern p ->
+    let message = `String "Non-variable patterns in constructors are not supported yet" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_unsupported_pattern_type pl ->
+    let loc = Format.asprintf "%a"
+      Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost pl) in
+    let message = `String "Currently, only booleans, lists, options, and constructors are supported in patterns" in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_unsupported_string_singleton te ->
+    let message = `String "Unsupported singleton string type" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.type_expr_to_region te) in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_abstraction_tracer (expr,err) ->
+    let message = `String "Abstracting expression" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.expr_to_region expr) in
+    let expr = Parser_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point expr in
+    let children = error_jsonformat err in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);
+      ("expression", `String expr);
+      ("children", children) ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_abstraction_type_tracer (te,err) ->
+    let message = `String "Abstracting type expression" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.type_expr_to_region te) in
+    let expr = Parser_cameligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point te in
+    let children = error_jsonformat err in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);
+      ("type expression", `String expr);
+      ("children", children) ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_bad_deconstruction expr ->
+    let message = `String "Bad tuple deconstruction" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.expr_to_region expr) in
+    let expr = Parser_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point expr in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);
+      ("expression", `String expr) ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_only_constructors p ->
+    let message = `String "Currently, only constructors are supported in patterns" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_unsupported_sugared_lists wild ->
+    let message = `String "Currently, only empty lists and constructors (::) are supported in patterns" in
+    let loc = Format.asprintf "%a" Location.pp_lift wild in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc); ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_corner_case desc ->
+    let message = Format.asprintf "Corner case: %s" desc in
+    let content = `Assoc [
+      ("message", `String message ); ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_unknown_built_in bi ->
+    let message = Format.asprintf "Unknown built-in function %s" bi in
+    let content = `Assoc [
+      ("message", `String message ); ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_michelson_type_wrong (texpr,name) ->
+    let message = Format.asprintf "Argument %s of %s must be a string singleton"
+        (Parser_cameligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point texpr) name in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.type_expr_to_region texpr) in
+    let content = `Assoc [
+      ("message", `String message );
+      ("location", `String loc); ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_michelson_type_wrong_arity (loc,name) ->
+    let message = Format.asprintf "%s does not have the right number of argument" name in
+    let loc = Format.asprintf "%a" Location.pp loc in
+    let content = `Assoc [
+      ("message", `String message );
+      ("location", `String loc); ] in
+    json_error ~stage ~content
+  | `Concrete_cameligo_program_tracer (decl,err) ->
+    let message = `String "Abstracting program" in
+    let loc = Format.asprintf "%a"
+      Location.pp_lift (List.fold_left (fun a d -> Region.cover a (Raw.declaration_to_region d)) Region.ghost decl) in
+    let children = error_jsonformat err in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);
+      ("children", children) ] in
+    json_error ~stage ~content

src/passes/02-concrete_to_imperative/errors_pascaligo.ml

@@ -0,0 +1,227 @@
+open Trace
+open Simple_utils.Display
+
+module Raw = Parser_pascaligo.AST
+
+let stage = "abstracter"
+
+type abs_error = [
+  | `Concrete_pascaligo_unsupported_constant_constr of Raw.pattern
+  | `Concrete_pascaligo_unknown_predefined_type of Raw.constr
+  | `Concrete_pascaligo_unsupported_non_var_pattern of Raw.pattern
+  | `Concrete_pascaligo_only_constructors of Raw.pattern
+  | `Concrete_pascaligo_unsupported_pattern_type of Raw.pattern list
+  | `Concrete_pascaligo_unsupported_tuple_pattern of Raw.pattern
+  | `Concrete_pascaligo_unsupported_string_singleton of Raw.type_expr
+  | `Concrete_pascaligo_unsupported_deep_some_pattern of Raw.pattern
+  | `Concrete_pascaligo_unsupported_deep_list_pattern of (Raw.pattern, Raw.wild) Parser_shared.Utils.nsepseq Raw.reg
+  | `Concrete_pascaligo_unknown_built_in of string
+  | `Concrete_pascaligo_michelson_type_wrong of Raw.type_expr * string
+  | `Concrete_pascaligo_michelson_type_wrong_arity of Location.t * string
+  | `Concrete_pascaligo_instruction_tracer of Raw.instruction * abs_error
+  | `Concrete_pascaligo_program_tracer of Raw.declaration list * abs_error
+  ]
+
+let unsupported_cst_constr p = `Concrete_pascaligo_unsupported_constant_constr p
+let unknown_predefined_type name = `Concrete_pascaligo_unknown_predefined_type name
+let unsupported_non_var_pattern p = `Concrete_pascaligo_unsupported_non_var_pattern p
+let only_constructors p = `Concrete_pascaligo_only_constructors p
+let unsupported_pattern_type pl = `Concrete_pascaligo_unsupported_pattern_type pl
+let unsupported_tuple_pattern p = `Concrete_pascaligo_unsupported_tuple_pattern p
+let unsupported_string_singleton te = `Concrete_pascaligo_unsupported_string_singleton te
+let unsupported_deep_some_patterns p = `Concrete_pascaligo_unsupported_deep_some_pattern p
+let unsupported_deep_list_patterns cons = `Concrete_pascaligo_unsupported_deep_list_pattern cons
+let unknown_built_in name = `Concrete_pascaligo_unknown_built_in name
+let michelson_type_wrong texpr name = `Concrete_pascaligo_michelson_type_wrong (texpr,name)
+let michelson_type_wrong_arity loc name = `Concrete_pascaligo_michelson_type_wrong_arity (loc,name)
+let abstracting_instruction_tracer i err = `Concrete_pascaligo_instruction_tracer (i,err)
+let program_tracer decl err = `Concrete_pascaligo_program_tracer (decl,err)
+
+let rec error_ppformat : display_format:string display_format ->
+  Format.formatter -> abs_error -> unit =
+  fun ~display_format f a ->
+  match display_format with
+  | Human_readable | Dev -> (
+    match a with
+    | `Concrete_pascaligo_unknown_predefined_type type_name ->
+      Format.fprintf f
+        "@[<hv>%a@Unknown predefined type \"%s\"@]"
+        Location.pp_lift type_name.Region.region
+        type_name.Region.value
+    | `Concrete_pascaligo_unsupported_pattern_type pl ->
+      Format.fprintf f
+        "@[<hv>%a@Currently, only booleans, lists, options, and constructors are supported in patterns@]"
+        Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost pl)
+    | `Concrete_pascaligo_unsupported_tuple_pattern p ->
+      Format.fprintf f
+        "@[<hv>%a@The following tuple pattern is not supported yet:@\"%s\"@]"
+        Location.pp_lift (Raw.pattern_to_region p)
+        (Parser_pascaligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point p)
+    | `Concrete_pascaligo_unsupported_constant_constr p ->
+      Format.fprintf f
+        "@[<hv>%a@Constant constructors are not supported yet@]"
+        Location.pp_lift (Raw.pattern_to_region p)
+    | `Concrete_pascaligo_unsupported_non_var_pattern p ->
+      Format.fprintf f
+        "@[<hv>%a@Non-variable patterns in constructors are not supported yet@]"
+        Location.pp_lift (Raw.pattern_to_region p)
+    | `Concrete_pascaligo_unsupported_string_singleton te ->
+      Format.fprintf f
+        "@[<hv>%a@Unsupported singleton string type@]"
+        Location.pp_lift (Raw.type_expr_to_region te)
+    | `Concrete_pascaligo_unsupported_deep_some_pattern p ->
+      Format.fprintf f
+        "@[<hv>%a@Currently, only variables in Some constructors are supported@]"
+        Location.pp_lift (Raw.pattern_to_region p)
+    | `Concrete_pascaligo_unsupported_deep_list_pattern cons ->
+      Format.fprintf f
+        "@[<hv>%a@Currently, only empty lists and x::y are supported in list patterns@]"
+        Location.pp_lift @@ cons.Region.region
+    | `Concrete_pascaligo_only_constructors p ->
+      Format.fprintf f
+        "@[<hv>%a@Currently, only constructors are supported in patterns@]"
+        Location.pp_lift (Raw.pattern_to_region p)
+    | `Concrete_pascaligo_unknown_built_in bi ->
+      Format.fprintf f "Unknown built-in function %s" bi
+    | `Concrete_pascaligo_michelson_type_wrong (texpr,name) ->
+      Format.fprintf f
+        "@[<hv>%a@Argument %s of %s must be a string singleton@]"
+          Location.pp_lift (Raw.type_expr_to_region texpr)
+          (Parser_pascaligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point texpr)
+          name
+    | `Concrete_pascaligo_michelson_type_wrong_arity (loc,name) ->
+      Format.fprintf f
+        "@[<hv>%a@%s does not have the right number of argument@]"
+        Location.pp loc
+        name
+    | `Concrete_pascaligo_instruction_tracer (inst,err) ->
+      Format.fprintf f
+        "@[<hv>%a@Abstracting instruction:@\"%s\"@%a@]"
+        Location.pp_lift (Raw.instr_to_region inst)
+        (Parser_pascaligo.ParserLog.instruction_to_string ~offsets:true ~mode:`Point inst)
+        (error_ppformat ~display_format) err
+    | `Concrete_pascaligo_program_tracer (decl,err) ->
+      Format.fprintf f
+        "@[<hv>%a@Abstracting program@%a@]"
+        Location.pp_lift (List.fold_left (fun a d -> Region.cover a (Raw.declaration_to_region d)) Region.ghost decl)
+        (error_ppformat ~display_format) err
+  )
+
+
+let rec error_jsonformat : abs_error -> J.t = fun a ->
+  let json_error ~stage ~content =
+    `Assoc [
+      ("status", `String "error") ;
+      ("stage", `String stage) ;
+      ("content",  content )]
+  in
+  match a with
+  | `Concrete_pascaligo_unknown_predefined_type type_name ->
+    let message = `String "Unknown predefined type" in
+    let t = `String type_name.Region.value in
+    let loc = Format.asprintf "%a" Location.pp_lift type_name.Region.region in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);
+      ("type", t ) ] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_unsupported_pattern_type pl ->
+    let loc = Format.asprintf "%a"
+      Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost pl) in
+    let message = `String "Currently, only booleans, lists, options, and constructors are supported in patterns" in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_unsupported_tuple_pattern p ->
+    let message = `String "The following tuple pattern is not supported yet" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
+    let pattern = Parser_pascaligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point p in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);
+      ("pattern", `String pattern); ] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_unsupported_constant_constr p ->
+    let message = `String "Constant constructors are not supported yet" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_unsupported_non_var_pattern p ->
+    let message = `String "Non-variable patterns in constructors are not supported yet" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_unsupported_string_singleton te ->
+    let message = `String "Unsupported singleton string type" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.type_expr_to_region te) in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_unsupported_deep_some_pattern p ->
+    let message = `String "Currently, only variables in Some constructors are supported" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_unsupported_deep_list_pattern cons ->
+    let message = `String "Currently, only empty lists and x::y are supported in list patterns" in
+    let loc = Format.asprintf "%a" Location.pp_lift @@ cons.Region.region in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_only_constructors p ->
+    let message = `String "Currently, only constructors are supported in patterns" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.pattern_to_region p) in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_unknown_built_in bi ->
+    let message = Format.asprintf "Unknown built-in function %s" bi in
+    let content = `Assoc [
+      ("message", `String message ); ] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_michelson_type_wrong (texpr,name) ->
+    let message = Format.asprintf "Argument %s of %s must be a string singleton"
+        (Parser_pascaligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point texpr) name in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.type_expr_to_region texpr) in
+    let content = `Assoc [
+      ("message", `String message );
+      ("location", `String loc); ] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_michelson_type_wrong_arity (loc,name) ->
+    let message = Format.asprintf "%s does not have the right number of argument" name in
+    let loc = Format.asprintf "%a" Location.pp loc in
+    let content = `Assoc [
+      ("message", `String message );
+      ("location", `String loc); ] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_instruction_tracer (inst,err) ->
+    let message = `String "Abstracting instruction" in
+    let loc = Format.asprintf "%a" Location.pp_lift (Raw.instr_to_region inst) in
+    let expr = Parser_pascaligo.ParserLog.instruction_to_string ~offsets:true ~mode:`Point inst in
+    let children = error_jsonformat err in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);
+      ("instruction", `String expr);
+      ("children", children) ] in
+    json_error ~stage ~content
+  | `Concrete_pascaligo_program_tracer (decl,err) ->
+    let message = `String "Abstracting program" in
+    let loc = Format.asprintf "%a"
+      Location.pp_lift (List.fold_left (fun a d -> Region.cover a (Raw.declaration_to_region d)) Region.ghost decl) in
+    let children = error_jsonformat err in
+    let content = `Assoc [
+      ("message", message );
+      ("location", `String loc);
+      ("children", children) ] in
+    json_error ~stage ~content

src/passes/02-concrete_to_imperative/pascaligo.ml

@@ -1,9 +1,10 @@
+open Errors_pascaligo
 open Trace
 open Ast_imperative
 
 module Raw = Parser.Pascaligo.AST
 module SMap = Map.String
-module ParserLog = Parser_pascaligo.ParserLog
+(* module ParserLog = Parser_pascaligo.ParserLog *)
 
 open Combinators
 
@@ -14,114 +15,6 @@ 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_cst_constr p =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nConstant constructors are not supported yet.\n" in
-    let pattern_loc = Raw.pattern_to_region p in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
-    ] in
-    error ~data title message
-
-  let unknown_predefined_type name =
-    let title () = "\nType constants" in
-    let message () =
-      Format.asprintf "Unknown predefined type \"%s\".\n" name.Region.value in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region)
-    ] in
-    error ~data title message
-
-  let unsupported_non_var_pattern p =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nNon-variable patterns in constructors \
-                       are not supported yet.\n" in
-    let pattern_loc = Raw.pattern_to_region p in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
-    ] in
-    error ~data title message
-
-  let only_constructors p =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nCurrently, only constructors \
-                       are supported in patterns.\n" in
-    let pattern_loc = Raw.pattern_to_region p in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
-    ] in
-    error ~data title message
-
-  let unsupported_tuple_pattern p =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nTuple patterns are not supported yet.\n" in
-    let pattern_loc = Raw.pattern_to_region p in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) ;
-      (** TODO: The labelled arguments should be flowing from the CLI. *)
-      ("pattern",
-       fun () -> ParserLog.pattern_to_string
-                ~offsets:true ~mode:`Point p)
-    ] in
-    error ~data title message
-
-  let unsupported_deep_Some_patterns pattern =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nCurrently, only variables in constructors \
-                       \"Some\" in patterns are supported.\n" in
-    let pattern_loc = Raw.pattern_to_region pattern in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
-    ] in
-    error ~data title message
-
-  let unsupported_deep_list_patterns cons =
-    let title () = "" in
-    let message () =
-      Format.asprintf "\nCurrently, only empty lists and x::y \
-                       are supported in patterns.\n" in
-    let data = [
-      ("location",
-       fun () -> Format.asprintf "%a" Location.pp_lift @@ cons.Region.region)
-    ] in
-    error ~data title message
-
-  (* Logging *)
-
-  let abstracting_instruction t =
-    let title () = "\nSimplifiying instruction" in
-    let message () = "" in
-    (** TODO: The labelled arguments should be flowing from the CLI. *)
-    let data = [
-      ("instruction",
-       fun () -> ParserLog.instruction_to_string
-                ~offsets:true ~mode:`Point t)
-    ] in
-    error ~data title message
-
-  let unknown_built_in name =
-    let title () = "\n Unknown built-in function" in
-    let message () = "" in
-    let data = [
-      ("built-in", fun  () -> name);
-    ] in
-    error ~data title message
-
-end
-
-open Errors
 open Operators.Concrete_to_imperative.Pascaligo
 
 let r_split = Location.r_split
@@ -156,7 +49,7 @@ let get_t_string_singleton_opt = function
   | _ -> None
 
 
-let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
+let rec compile_type_expression (t:Raw.type_expr) : (type_expression , (abs_error)) result =
   match t with
     TPar x -> compile_type_expression x.value.inside
   | TVar v -> (
@@ -181,31 +74,31 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
           (match lst with
           | [a ; b ; c ; d ] -> (
             let%bind b' =
-              trace_option (simple_error "second argument of michelson_or must be a string singleton") @@
+              trace_option (michelson_type_wrong t name.value) @@
                 get_t_string_singleton_opt b in
             let%bind d' =
-              trace_option (simple_error "fourth argument of michelson_or must be a string singleton") @@
+              trace_option (michelson_type_wrong t name.value) @@
                 get_t_string_singleton_opt d in
             let%bind a' = compile_type_expression a in
             let%bind c' = compile_type_expression c in
             ok @@ t_michelson_or ~loc a' b' c' d'
             )
-          | _ -> simple_fail "michelson_or does not have the right number of argument")
+          | _ -> fail @@ michelson_type_wrong_arity loc name.value)
         | "michelson_pair" ->
           let lst = npseq_to_list tuple.value.inside in
           (match lst with
           | [a ; b ; c ; d ] -> (
             let%bind b' =
-              trace_option (simple_error "second argument of michelson_pair must be a string singleton") @@
+              trace_option (michelson_type_wrong t name.value) @@
                 get_t_string_singleton_opt b in
             let%bind d' =
-              trace_option (simple_error "fourth argument of michelson_pair must be a string singleton") @@
+              trace_option (michelson_type_wrong t name.value) @@
                 get_t_string_singleton_opt d in
             let%bind a' = compile_type_expression a in
             let%bind c' = compile_type_expression c in
             ok @@ t_michelson_pair ~loc a' b' c' d'
             )
-          | _ -> simple_fail "michelson_pair does not have the right number of argument")
+          | _ -> fail @@ michelson_type_wrong_arity loc name.value)
         | _ ->
           let lst = npseq_to_list tuple.value.inside in
           let%bind lst =
@@ -213,7 +106,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
           let%bind cst =
             trace_option (unknown_predefined_type name) @@
             type_operators name.value in
-          ok @@ t_operator ~loc cst lst)
+          ok @@ t_operator ~loc cst lst )
   | TProd p ->
       let%bind tpl = compile_list_type_expression
     @@ npseq_to_list p.value in
@@ -252,9 +145,9 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
         @@ npseq_to_list s in
       let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in
       ok @@ make_t ~loc @@ T_sum m
-  | TString _s -> simple_fail "we don't support singleton string type"
+  | TString _s -> fail @@ unsupported_string_singleton t
 
-and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
+and compile_list_type_expression (lst:Raw.type_expr list) : (type_expression , (abs_error)) result =
   match lst with
   | [] -> ok @@ t_unit ()
   | [hd] -> compile_type_expression hd
@@ -278,7 +171,7 @@ let compile_projection : Raw.projection Region.reg -> _ = fun p ->
   ok @@ e_accessor ~loc var path'
 
 
-let rec compile_expression (t:Raw.expr) : expr result =
+let rec compile_expression (t:Raw.expr) : (expr , (abs_error)) result =
   let return x = ok x in
   match t with
   | EAnnot a -> (
@@ -423,7 +316,7 @@ let rec compile_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 =
+        let aux : Raw.binding -> (expression * expression, (abs_error)) result =
           fun b ->
             let%bind src = compile_expression b.source in
             let%bind dst = compile_expression b.image in
@@ -435,7 +328,7 @@ let rec compile_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 =
+        let aux : Raw.binding -> (expression * expression, (abs_error)) result =
           fun b ->
             let%bind src = compile_expression b.source in
             let%bind dst = compile_expression b.image in
@@ -481,7 +374,7 @@ and compile_update (u: Raw.update Region.reg) =
     ok @@ e_update ~loc ur (Access_record var :: path) expr
   in bind_fold_list aux record updates'
 
-and compile_logic_expression (t:Raw.logic_expr) : expression result =
+and compile_logic_expression (t:Raw.logic_expr) : (expression , (abs_error)) result =
   match t with
   | BoolExpr (False reg) ->
       ok @@ e_bool ~loc:(Location.lift reg) false
@@ -506,7 +399,7 @@ and compile_logic_expression (t:Raw.logic_expr) : expression result =
   | CompExpr (Neq c) ->
       compile_binop "NEQ" c
 
-and compile_list_expression (t:Raw.list_expr) : expression result =
+and compile_list_expression (t:Raw.list_expr) : (expression , (abs_error)) result =
   let return x = ok x in
   match t with
     ECons c ->
@@ -521,7 +414,7 @@ and compile_list_expression (t:Raw.list_expr) : expression result =
       let loc = Location.lift reg in
       return @@ e_list ~loc []
 
-and compile_set_expression (t:Raw.set_expr) : expression result =
+and compile_set_expression (t:Raw.set_expr) : (expression , (abs_error)) result =
   match t with
   | SetMem x -> (
     let (x' , loc) = r_split x in
@@ -536,7 +429,7 @@ and compile_set_expression (t:Raw.set_expr) : expression result =
     ok @@ e_set ~loc elements'
   )
 
-and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
+and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : (expression , (abs_error)) result =
   let return x = ok x in
   let (t , loc) = r_split t in
   let%bind a = compile_expression t.arg1 in
@@ -544,14 +437,14 @@ and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result
   let%bind name = trace_option (unknown_built_in name) @@ constants name in
   return @@ e_constant ~loc name [ a ; b ]
 
-and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
+and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : (expression , (abs_error)) result =
   let return x = ok x in
   let (t , loc) = r_split t in
   let%bind a = compile_expression t.arg in
   let%bind name = trace_option (unknown_built_in name) @@ constants name in
   return @@ e_constant ~loc name [ a ]
 
-and compile_tuple_expression ?loc (lst:Raw.expr list) : expression result =
+and compile_tuple_expression ?loc (lst:Raw.expr list) : (expression , (abs_error)) result =
   let return x = ok x in
   match lst with
   | [] -> return @@ e_literal Literal_unit
@@ -593,7 +486,7 @@ and compile_data_declaration : Raw.data_decl -> _ result =
       in return_let_in ~loc binder inline expr
 
 and compile_param :
-      Raw.param_decl -> (string * type_expression) result =
+      Raw.param_decl -> (string * type_expression, (abs_error)) result =
   fun t ->
   match t with
   | ParamConst c ->
@@ -609,7 +502,7 @@ and compile_param :
 
 and compile_fun_decl :
       loc:_ -> Raw.fun_decl ->
-      ((expression_variable * type_expression option) * expression) result =
+      ((expression_variable * type_expression option) * expression , (abs_error)) result =
   fun ~loc x ->
   let open! Raw in
   let {kwd_recursive;fun_name; param; ret_type; block_with;
@@ -686,7 +579,7 @@ and compile_fun_decl :
   )
 
 and compile_fun_expression :
-  loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
+  loc:_ -> Raw.fun_expr -> (type_expression option * expression , (abs_error)) result =
   fun ~loc x ->
   let open! Raw in
   let {param; ret_type; return; _} : fun_expr = x in
@@ -768,7 +661,7 @@ and compile_statement_list statements =
       hook (compile_data_declaration d :: acc) statements
   in bind_list @@ hook [] (List.rev statements)
 
-and compile_single_instruction : Raw.instruction -> (_ -> expression result) result =
+and compile_single_instruction : Raw.instruction -> ((_ -> (expression , (abs_error)) result), (abs_error)) result =
   fun t ->
   match t with
   | ProcCall x -> (
@@ -996,7 +889,7 @@ and compile_selection : Raw.selection -> access = function
   FieldName property -> Access_record property.value
 | Component index    -> Access_tuple (snd index.value)
 
-and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
+and compile_cases : (Raw.pattern * expression) list -> (matching_expr , (abs_error)) result = fun t ->
   let open Raw in
   let get_var (t:Raw.pattern) =
     match t with
@@ -1009,8 +902,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
   let get_single (t: Raw.pattern) =
     let t' = get_tuple t in
     let%bind () =
-      trace_strong (unsupported_tuple_pattern t) @@
+      Assert.assert_list_size (unsupported_tuple_pattern t) t' 1 in
-      Assert.assert_list_size t' 1 in
     ok (List.hd t') in
   let get_toplevel (t : Raw.pattern) =
     match t with
@@ -1052,7 +944,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
       let (_, v) = v.value in
       let%bind v = match v.value.inside with
         | PVar v -> ok v.value
-        | p -> fail @@ unsupported_deep_Some_patterns p in
+        | p -> fail @@ unsupported_deep_some_patterns p in
       ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some) }
     )
   | [(PList PCons c, cons) ; (PList (PNil _), nil)]
@@ -1068,33 +960,23 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
       in
       ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons) ; match_nil = nil}
   | lst ->
-      trace (simple_info "currently, only booleans, options, lists and \
-                         user-defined constructors are supported in patterns") @@
       let%bind constrs =
+        trace_strong (unsupported_pattern_type (List.map fst lst)) @@
         let aux (x , y) =
-          let error =
-            let title () = "Pattern" in
-            (* TODO: The labelled arguments should be flowing from the CLI. *)
-            let content () =
-              Printf.sprintf "Pattern : %s"
-                (ParserLog.pattern_to_string
-                   ~offsets:true ~mode:`Point x) in
-            error title content in
           let%bind x' =
-            trace error @@
             get_constr x in
           ok (x' , y) in
         bind_map_list aux lst in
       ok @@ ez_match_variant constrs
 
-and compile_instruction : Raw.instruction -> (_ -> expression result) result =
+and compile_instruction : Raw.instruction -> ((_ -> (expression, (abs_error)) result) , (abs_error)) result =
-  fun t -> trace (abstracting_instruction t) @@ compile_single_instruction t
+  fun t -> trace (abstracting_instruction_tracer t) @@ compile_single_instruction t
 
-and compile_statements : Raw.statements -> (_ -> expression result) result =
+and compile_statements : Raw.statements -> ((_ -> (expression,(abs_error)) result) , (abs_error)) result =
   fun statements ->
     let lst = npseq_to_list statements in
     let%bind fs = compile_statement_list lst in
-    let aux : _ -> (expression option -> expression result) -> _ =
+    let aux : _ -> (expression option -> (expression, (abs_error)) result) -> _ =
       fun prec cur ->
         let%bind res = cur prec
         in ok @@ Some res in
@@ -1102,11 +984,11 @@ and compile_statements : Raw.statements -> (_ -> expression result) result =
            let%bind ret = bind_fold_right_list aux expr' fs in
            ok @@ Option.unopt_exn ret
 
-and compile_block : Raw.block -> (_ -> expression result) result =
+and compile_block : Raw.block -> ((_ -> (expression , (abs_error)) result) , (abs_error)) result =
   fun t -> compile_statements t.statements
 
 
-and compile_declaration_list declarations : declaration Location.wrap list result =
+and compile_declaration_list declarations : (declaration Location.wrap list, (abs_error)) result =
   let open Raw in
   let rec hook acc = function
     [] -> acc
@@ -1169,5 +1051,8 @@ and compile_declaration_list declarations : declaration Location.wrap list resul
       hook (bind_list_cons res acc) declarations
   in hook (ok @@ []) (List.rev declarations)
 
-let compile_program : Raw.ast -> program result =
+let compile_program : Raw.ast -> (program , (abs_error)) result =
-  fun t -> compile_declaration_list @@ nseq_to_list t.decl
+  fun t ->
+  let declarations = nseq_to_list t.decl in
+  trace (program_tracer declarations) @@
+    compile_declaration_list declarations

src/passes/02-concrete_to_imperative/pascaligo.mli

@@ -8,8 +8,8 @@ module SMap = Map.String
 
 (** Convert a concrete PascaLIGO expression AST to the imperative
     expression AST used by the compiler. *)
-val compile_expression : Raw.expr -> expr result
+val compile_expression : Raw.expr -> (expr , Errors_pascaligo.abs_error) result
 
 (** Convert a concrete PascaLIGO program AST to the miperative program
     AST used by the compiler. *)
-val compile_program : Raw.ast -> program result
+val compile_program : Raw.ast -> (program, Errors_pascaligo.abs_error) result

src/passes/03-self_ast_imperative/entrypoints_length_limit.ml

@@ -1,23 +1,16 @@
+open Errors
 open Ast_imperative
 open Trace
 open Stage_common.Helpers
 
-module Errors = struct
+let peephole_type_expression : type_expression -> (type_expression , self_ast_imperative_error) result = fun e ->
-  let bad_string_timestamp name () =
-    let title = thunk @@ Format.asprintf ("Too long constructor '%s'") name in
-    let message () = "names length is limited to 32 (tezos limitation)" in
-    error title message ()
-end
-open Errors
-
-let peephole_type_expression : type_expression -> type_expression result = fun e ->
   let return type_content = ok {type_content; location=e.location } in
   match e.type_content with
   | T_sum cmap ->
     let%bind _uu = bind_map_cmapi
       (fun k _ ->
         let (Constructor name) = k in
-        if (String.length name  >= 32) then fail @@ bad_string_timestamp name
+        if (String.length name  >= 32) then fail @@ too_long_constructor name e
         else ok ()
       )
       cmap in

src/passes/03-self_ast_imperative/errors.ml

@@ -0,0 +1,151 @@
+open Simple_utils.Display
+open Ast_imperative
+open Trace
+
+let stage = "self_ast_imperative"
+
+type self_ast_imperative_error = [
+  | `Self_ast_imperative_long_constructor of (string * type_expression)
+  | `Self_ast_imperative_bad_timestamp of (string * expression)
+  | `Self_ast_imperative_bad_format_literal of (expression * Proto_alpha_utils.Trace.tezos_alpha_error list)
+  | `Self_ast_imperative_bad_empty_arity of (constant' * expression)
+  | `Self_ast_imperative_bad_single_arity of (constant' * expression)
+  | `Self_ast_imperative_bad_map_param_type of (constant' * expression)
+  | `Self_ast_imperative_bad_set_param_type of (constant' * expression)
+  | `Self_ast_imperative_bad_convertion_bytes of expression
+]
+
+let too_long_constructor c e = `Self_ast_imperative_long_constructor (c,e)
+let bad_timestamp t e = `Self_ast_imperative_bad_timestamp (t,e)
+let bad_format e errs = `Self_ast_imperative_bad_format_literal (e,errs)
+let bad_empty_arity c e = `Self_ast_imperative_bad_empty_arity (c,e)
+let bad_single_arity c e = `Self_ast_imperative_bad_single_arity (c,e)
+let bad_map_param_type c e = `Self_ast_imperative_bad_map_param_type (c,e)
+let bad_set_param_type c e = `Self_ast_imperative_bad_set_param_type (c,e)
+let bad_conversion_bytes e = `Self_ast_imperative_bad_convertion_bytes e
+
+let error_ppformat : display_format:string display_format ->
+  Format.formatter -> self_ast_imperative_error -> unit =
+  fun ~display_format f a ->
+  match display_format with
+  | Human_readable | Dev -> (
+    match a with
+    | `Self_ast_imperative_long_constructor (c,e) ->
+      Format.fprintf f
+        "@[<hv>%a@ Too long constructor '%s'@ names length are limited to 32 (tezos limitation)@]"
+        Location.pp e.location
+        c
+    | `Self_ast_imperative_bad_timestamp (t,e) ->
+      Format.fprintf f
+        "@[<hv>%a@ Badly formatted timestamp '%s'@]"
+        Location.pp e.location
+        t
+    | `Self_ast_imperative_bad_format_literal (e,_errs) ->
+      Format.fprintf f
+        "@[<hv>%a@ Badly formatted literal: %a@]"
+        Location.pp e.location
+        Ast_imperative.PP.expression e
+    | `Self_ast_imperative_bad_empty_arity (c, e) ->
+      Format.fprintf f
+        "@[<hv>%a@ Wrong arity:@%a expects no parameter@]"
+        Location.pp e.location PP.constant c
+    | `Self_ast_imperative_bad_single_arity (c, e) ->
+      Format.fprintf f
+        "@[<hv>%a@ Wrong arity:@%a expects one parameter@]"
+        Location.pp e.location PP.constant c
+    | `Self_ast_imperative_bad_map_param_type (c,e) ->
+      Format.fprintf f
+        "@[<hv>%a@ Wrong arity:@%a expects a list of pair parameter@]"
+        Location.pp e.location PP.constant c
+    | `Self_ast_imperative_bad_set_param_type (c,e) ->
+      Format.fprintf f
+        "@[<hv>%a@ Wrong arity:@%a expects a list of pair parameter@]"
+        Location.pp e.location PP.constant c
+    | `Self_ast_imperative_bad_convertion_bytes e ->
+      Format.fprintf f
+        "@[<hv>%a@ Bad bytes literal (conversion went wrong)@]"
+        Location.pp e.location
+  )
+
+let error_jsonformat : self_ast_imperative_error -> J.t = fun a ->
+  let json_error ~stage ~content =
+    `Assoc [
+      ("status", `String "error") ;
+      ("stage", `String stage) ;
+      ("content",  content )]
+  in
+  match a with
+  | `Self_ast_imperative_long_constructor (c,e) ->
+    let message = `String "too long constructor (limited to 32)" in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let content = `Assoc [
+      ("message", message);
+      ("location", loc);
+      ("value", `String c)
+    ] in
+    json_error ~stage ~content
+  | `Self_ast_imperative_bad_timestamp (t,e) ->
+    let message = `String "badly formatted timestamp" in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let content = `Assoc [
+      ("message", message);
+      ("location", loc);
+      ("value", `String t)
+    ] in
+    json_error ~stage ~content
+  | `Self_ast_imperative_bad_format_literal (e,_errs) ->
+    let message = `String "badly formatted literal" in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let content = `Assoc [
+      ("message", message);
+      ("location", loc);
+    ] in
+    json_error ~stage ~content
+  | `Self_ast_imperative_bad_empty_arity (c, e) ->
+    let message = `String "constant expects no parameters" in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let value = `String (Format.asprintf "%a" PP.constant c) in
+    let content = `Assoc [
+      ("message", message);
+      ("location", loc);
+      ("value", value);
+    ] in
+    json_error ~stage ~content
+  | `Self_ast_imperative_bad_single_arity (c, e) ->
+    let message = `String "constant expects one parameters" in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let value = `String (Format.asprintf "%a" PP.constant c) in
+    let content = `Assoc [
+      ("message", message);
+      ("location", loc);
+      ("value", value);
+    ] in
+    json_error ~stage ~content
+  | `Self_ast_imperative_bad_map_param_type (c,e) ->
+    let message = `String "constant expects a list of pair as parameter" in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let value = `String (Format.asprintf "%a" PP.constant c) in
+    let content = `Assoc [
+      ("message", message);
+      ("location", loc);
+      ("value", value);
+    ] in
+    json_error ~stage ~content
+  | `Self_ast_imperative_bad_set_param_type (c,e) ->
+    let message = `String "constant expects a list as parameter" in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let value = `String (Format.asprintf "%a" PP.constant c) in
+    let content = `Assoc [
+      ("message", message);
+      ("location", loc);
+      ("value", value);
+    ] in
+    json_error ~stage ~content
+  | `Self_ast_imperative_bad_convertion_bytes e ->
+    let message = `String "Bad bytes literal (conversion went wrong)" in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let content = `Assoc [
+      ("message", message);
+      ("location", loc);
+    ] in
+    json_error ~stage ~content

src/passes/03-self_ast_imperative/helpers.ml

@@ -16,8 +16,8 @@ let bind_map_lmap_t f map = bind_lmap (
       ok {field with field_type }) 
     map)
 
-type 'a folder = 'a -> expression -> 'a result
+type ('a,'err) folder = 'a -> expression -> ('a, 'err) result
-let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
+let rec fold_expression : ('a, 'err) folder -> 'a -> expression -> ('a, 'err) result = fun f init e ->
   let self = fold_expression f in 
   let%bind init' = f init e in
   match e.expression_content with
@@ -112,7 +112,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
       let%bind res = self res body in
       ok res  
 
-and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
+and fold_cases : ('a , 'b) folder -> 'a -> matching_expr -> ('a , 'b) result = fun f init m ->
   match m with
   | Match_variant lst -> (
       let aux init' ((_ , _) , e) =
@@ -144,12 +144,12 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
       ok res
     )
 
-type exp_mapper = expression -> expression result
+type 'err exp_mapper = expression -> (expression , 'err) result
-type ty_exp_mapper = type_expression -> type_expression result
+type 'err ty_exp_mapper = type_expression -> (type_expression, 'err) result
-type abs_mapper =
+type 'err abs_mapper =
-  | Expression of exp_mapper
+  | Expression of 'err exp_mapper
-  | Type_expression of ty_exp_mapper 
+  | Type_expression of 'err ty_exp_mapper 
-let rec map_expression : exp_mapper -> expression -> expression result = fun f e ->
+let rec map_expression : 'err exp_mapper -> expression -> (expression, 'err) result = fun f e ->
   let self = map_expression f in
   let%bind e' = f e in
   let return expression_content = ok { e' with expression_content } in
@@ -263,7 +263,7 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
 
   | E_literal _ | E_variable _ | E_raw_code _ | E_skip as e' -> return e'
 
-and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
+and map_type_expression : 'err ty_exp_mapper -> type_expression -> (type_expression , _) result = fun f te ->
   let self = map_type_expression f in
   let%bind te' = f te in
   let return type_content = ok { type_content; location=te.location } in
@@ -287,7 +287,7 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
   | T_operator _
   | T_variable _ | T_constant _ -> ok te'
 
-and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
+and map_cases : 'err exp_mapper -> matching_expr -> (matching_expr , _) result = fun f m ->
   match m with
   | Match_variant lst -> (
       let aux ((a , b) , e) =
@@ -320,7 +320,7 @@ and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
       ok @@ Match_variable (name, ty_opt, e')
     )
 
-and map_program : abs_mapper -> program -> program result = fun m p ->
+and map_program : 'err abs_mapper -> program -> (program , _) result = fun m p ->
   let aux = fun (x : declaration) ->
     match x,m with
     | (Declaration_constant (t , o , i, e), Expression m') -> (
@@ -336,8 +336,8 @@ and map_program : abs_mapper -> program -> program result = fun m p ->
   in
   bind_map_list (bind_map_location aux) p
 
-type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
+type ('a, 'err) fold_mapper = 'a -> expression -> ((bool * 'a * expression), 'err) result
-let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
+let rec fold_map_expression : ('a, 'err) fold_mapper -> 'a -> expression -> ('a * expression , 'err) result = fun f a e ->
   let self = fold_map_expression f in
   let%bind (continue, init',e') = f a e in
   if (not continue) then ok(init',e')
@@ -452,7 +452,7 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
       ok (res, return @@ E_while {condition; body})
   | E_literal _ | E_variable _ | E_raw_code _ | E_skip as e' -> ok (init', return e')
 
-and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
+and fold_map_cases : ('a , 'err) fold_mapper -> 'a -> matching_expr -> ('a * matching_expr , 'err) result = fun f init m ->
   match m with
   | Match_variant lst -> (
       let aux init ((a , b) , e) =

src/passes/03-self_ast_imperative/literals.ml

@@ -1,57 +1,9 @@
+open Errors
 open Ast_imperative
 open Trace
 open Proto_alpha_utils
 
-module Errors = struct
+let peephole_expression : expression -> (expression , self_ast_imperative_error) result = fun e ->
-
-  let bad_format e () =
-    let title = (thunk ("Badly formatted literal")) in
-    let message () = Format.asprintf "%a" PP.expression e in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
-    ] in
-    error ~data title message ()
-
-  let bad_empty_arity cst loc () =
-    let cst_name = thunk @@ Format.asprintf "%a" Stage_common.PP.constant cst in
-    let title = thunk @@ "Wrong "^(cst_name ())^" literal arity" in
-    let message = thunk @@ (cst_name ())^" literal expects no parameter" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-    ] in
-    error ~data title message ()
-
-  let bad_single_arity cst loc () =
-    let cst_name = thunk @@ Format.asprintf "%a" Stage_common.PP.constant cst in
-    let title = thunk @@ "Wrong "^(cst_name ())^" literal arity" in
-    let message = thunk @@ (cst_name ())^" literal expects a single parameter" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-    ] in
-    error ~data title message ()
-
-  let bad_map_param_type cst loc () =
-    let cst_name = thunk @@ Format.asprintf "%a" Stage_common.PP.constant cst in
-    let title = thunk @@ "Wrong "^(cst_name ())^" literal parameter type" in
-    let message = thunk @@ (cst_name ())^" literal expects a list of pairs as parameter" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-    ] in
-    error ~data title message ()
-
-  let bad_set_param_type cst loc () =
-    let cst_name = thunk @@ Format.asprintf "%a" Stage_common.PP.constant cst in
-    let title = thunk @@ "Wrong "^(cst_name ())^" literal parameter type" in
-    let message = thunk @@ (cst_name ())^" literal expects a list as parameter" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-    ] in
-    error ~data title message ()
-  
-end
-open Errors
-
-let peephole_expression : expression -> expression result = fun e ->
   let return expression_content = ok { e with expression_content } in
   match e.expression_content with
   | E_literal (Literal_key_hash s) as l -> (
@@ -84,76 +36,65 @@ let peephole_expression : expression -> expression result = fun e ->
     )
   | E_constant {cons_name=C_BIG_MAP_LITERAL as cst; arguments=lst} -> (
       let%bind elt =
-        trace_option (bad_single_arity cst e.location) @@
+        trace_option (bad_single_arity cst e) @@
         List.to_singleton lst
       in
       let%bind lst =
-        trace_strong (bad_map_param_type cst e.location) @@
+        trace_option (bad_map_param_type cst e) @@
         get_e_list elt.expression_content
       in
       let aux = fun (e : expression) ->
-        trace_strong (bad_map_param_type cst e.location) @@
+        trace_option (bad_map_param_type cst e) @@
-        let%bind tpl = get_e_tuple e.expression_content in
+          Option.(get_e_tuple e.expression_content >>= fun t ->
-        let%bind (a , b) =
+            List.to_pair t)
-          trace_option (simple_error "of pairs") @@
-          List.to_pair tpl
-        in
-        ok (a , b)
       in
       let%bind pairs = bind_map_list aux lst in
       return @@ E_big_map pairs
     )
   | E_constant {cons_name=C_MAP_LITERAL as cst; arguments=lst} -> (
       let%bind elt =
-        trace_option (bad_single_arity cst e.location) @@
+        trace_option (bad_single_arity cst e) @@
         List.to_singleton lst
       in
       let%bind lst =
-        trace_strong (bad_map_param_type cst e.location) @@
+        trace_option (bad_map_param_type cst e) @@
         get_e_list elt.expression_content
       in
       let aux = fun (e : expression) ->
-        trace_strong (bad_map_param_type cst e.location) @@
+        trace_option (bad_map_param_type cst e) @@
-        let%bind tpl = get_e_tuple e.expression_content in
+          Option.(get_e_tuple e.expression_content >>= fun t ->
-        let%bind (a , b) =
+            List.to_pair t)
-          trace_option (simple_error "of pairs") @@
-          List.to_pair tpl
-        in
-        ok (a , b)
       in
       let%bind pairs = bind_map_list aux lst in
       return @@ E_map pairs
     )
   | E_constant {cons_name=C_BIG_MAP_EMPTY as cst; arguments=lst} -> (
       let%bind () =
-        trace_strong (bad_empty_arity cst e.location) @@
+        Assert.assert_list_empty (bad_empty_arity cst e) lst
-        Assert.assert_list_empty lst
       in
       return @@ E_big_map []
     )
   | E_constant {cons_name=C_MAP_EMPTY as cst; arguments=lst} -> (
       let%bind () =
-        trace_strong (bad_empty_arity cst e.location) @@
+        Assert.assert_list_empty (bad_empty_arity cst e) lst
-        Assert.assert_list_empty lst
       in
       return @@ E_map []
     )
 
   | E_constant {cons_name=C_SET_LITERAL as cst; arguments=lst} -> (
       let%bind elt =
-        trace_option (bad_single_arity cst e.location) @@
+        trace_option (bad_single_arity cst e) @@
         List.to_singleton lst
       in
       let%bind lst =
-        trace_strong (bad_set_param_type cst e.location) @@
+        trace_option (bad_set_param_type cst e) @@
         get_e_list elt.expression_content
       in
       return @@ E_set lst
     )
   | E_constant {cons_name=C_SET_EMPTY as cst; arguments=lst} -> (
       let%bind () =
-        trace_strong (bad_empty_arity cst e.location) @@
+        Assert.assert_list_empty (bad_empty_arity cst e) lst
-        Assert.assert_list_empty lst
       in
       return @@ E_set []
     )

src/passes/03-self_ast_imperative/none_variant.ml

@@ -1,7 +1,8 @@
+open Errors
 open Ast_imperative
 open Trace
 
-let peephole_expression : expression -> expression result = fun e ->
+let peephole_expression : expression -> (expression , self_ast_imperative_error) result = fun e ->
   let return expression_content = ok { e with expression_content } in
   match e.expression_content with
   | E_constructor {constructor=Constructor "Some";element=e} -> return @@ E_constant {cons_name=C_SOME;arguments=[ e ]}

src/passes/03-self_ast_imperative/self_ast_imperative.ml

@@ -1,4 +1,5 @@
 open Trace
+module Errors = Errors
 
 let all_expression_mapper = [
   Tezos_type_annotation.peephole_expression ;

src/passes/03-self_ast_imperative/tezos_type_annotation.ml

@@ -1,21 +1,11 @@
+open Errors
 open Ast_imperative
 open Trace
 
-module Errors = struct
+let peephole_expression : expression -> (expression , self_ast_imperative_error) result = fun e ->
-  let bad_string_timestamp ts loc () =
-    let title = (thunk ("Badly formatted timestamp \""^ts^"\"")) in
-    let message () = "" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-end
-open Errors
-
-let peephole_expression : expression -> expression result = fun e ->
   let return expression_content = ok { e with expression_content } in
   match e.expression_content with
-  | E_ascription {anno_expr=e'; type_annotation=t} as e -> (
+  | E_ascription {anno_expr=e'; type_annotation=t} as ec -> (
       match (e'.expression_content , t.type_content) with
       | (E_literal (Literal_string s) , T_constant (TC_key_hash))  -> return @@ E_literal (Literal_key_hash (Ligo_string.extract s))
       | (E_literal (Literal_string s) , T_constant (TC_signature)) -> return @@ E_literal (Literal_signature (Ligo_string.extract s))
@@ -24,16 +14,16 @@ let peephole_expression : expression -> expression result = fun e ->
       | (E_literal (Literal_string str) , T_constant (TC_timestamp)) ->
         let str = Ligo_string.extract str in
         let%bind time =
-          trace_option (bad_string_timestamp str e'.location)
+          trace_option (bad_timestamp str e')
           @@ Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation str in
         let itime = Z.of_int64 @@ Tezos_utils.Time.Protocol.to_seconds time in
         return @@ E_literal (Literal_timestamp itime)
       | (E_literal (Literal_string str) , T_constant (TC_address)) -> return @@ E_literal (Literal_address (Ligo_string.extract str))
       | (E_literal (Literal_string str) , T_constant (TC_bytes)) -> (
           let str = Ligo_string.extract str in
-        let%bind e' = e'_bytes str in
+          let%bind e' = trace_option (bad_conversion_bytes e) @@ e'_bytes str in
           return e'
         )
-      | _ -> return e
+      | _ -> return ec
     )
   | e -> return e

src/passes/04-imperative_to_sugar/errors.ml

@@ -0,0 +1,38 @@
+open Trace
+open Simple_utils.Display
+
+let stage = "imperative_to_sugar"
+
+type imperative_to_sugar_error = [
+  | `Imperative_to_sugar_corner_case of string
+]
+
+let corner_case s = `Imperative_to_sugar_corner_case s
+
+let error_ppformat : display_format:string display_format ->
+  Format.formatter -> imperative_to_sugar_error -> unit =
+  fun ~display_format f a ->
+  match display_format with
+  | Human_readable | Dev -> (
+    match a with
+    | `Imperative_to_sugar_corner_case s ->
+      Format.fprintf f
+        "@[<hv>Corner case: %s@]"
+        s
+  )
+
+let error_jsonformat : imperative_to_sugar_error -> J.t = fun a ->
+  let json_error ~stage ~content =
+    `Assoc [
+      ("status", `String "error") ;
+      ("stage", `String stage) ;
+      ("content",  content )]
+  in
+  match a with
+  | `Imperative_to_sugar_corner_case s ->
+    let message = `String "corner case" in
+    let content = `Assoc [
+      ("message", message);
+      ("value", `String s)
+    ] in
+    json_error ~stage ~content

src/passes/04-imperative_to_sugar/imperative_to_sugar.ml

@@ -1,27 +1,8 @@
+module Errors = Errors
 module I = Ast_imperative
 module O = Ast_sugar
 open Trace
 
-module Errors = struct
-  let corner_case loc =
-    let title () = "corner case" in
-    let message () = Format.asprintf "corner case, please report to developers\n" in
-    let data = [
-      ("location",
-      fun () -> Format.asprintf  "%s" loc)
-    ] in
-    error ~data title message
-
-  let bad_collection expr =
-    let title () = "" in
-    let message () = Format.asprintf "\nCannot loop over this collection : %a\n" I.PP.expression expr in
-    let data = [
-      ("location",
-      fun () -> Format.asprintf  "%a" Location.pp expr.location)
-    ] in
-    error ~data title message
-end
-
 let rec add_to_end (expression: O.expression) to_add =
   match expression.expression_content with
   | O.E_let_in lt -> 
@@ -127,7 +108,7 @@ and restore_mutable_variable (expr : O.expression->O.expression) (free_vars : O.
     | Some e -> expr (ef e)
 
 
-let rec compile_type_expression : I.type_expression -> O.type_expression result =
+let rec compile_type_expression : I.type_expression -> (O.type_expression,Errors.imperative_to_sugar_error) result =
   fun te ->
   let return tc = ok @@ O.make_t ~loc:te.location tc in
   match te.type_content with
@@ -161,8 +142,8 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
     | I.T_variable type_variable -> return @@ T_variable type_variable 
     | I.T_constant type_constant -> return @@ T_constant type_constant
     | I.T_operator (TC_michelson_or, [l;r]) ->
-      let%bind (l, l_ann) = I.get_t_annoted l in
+      let%bind (l, l_ann) = trace_option (Errors.corner_case "not an annotated type") @@ I.get_t_annoted l in
-      let%bind (r, r_ann) = I.get_t_annoted r in
+      let%bind (r, r_ann) = trace_option (Errors.corner_case "not an annotated type") @@ I.get_t_annoted r in
       let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
       let sum : (O.constructor' * O.ctor_content) list = [
         (O.Constructor "M_left" , {ctor_type = l ; michelson_annotation = Some l_ann ; ctor_decl_pos = 0}); 
@@ -170,8 +151,8 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
       in
       return @@ O.T_sum (O.CMap.of_list sum)
     | I.T_operator (TC_michelson_pair, [l;r]) ->
-      let%bind (l, l_ann) = I.get_t_annoted l in
+      let%bind (l, l_ann) = trace_option (Errors.corner_case "not an annotated type") @@ I.get_t_annoted l in
-      let%bind (r, r_ann) = I.get_t_annoted r in
+      let%bind (r, r_ann) = trace_option (Errors.corner_case "not an annotated type") @@ I.get_t_annoted r in
       let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
       let sum : (O.label * O.field_content) list = [
         (O.Label "0" , {field_type = l ; michelson_annotation = Some l_ann ; field_decl_pos = 0}); 
@@ -183,12 +164,12 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
       return @@ T_operator (type_operator, lst)
     | I.T_annoted (ty, _) -> compile_type_expression ty
 
-let rec compile_expression : I.expression -> O.expression result =
+let rec compile_expression : I.expression -> (O.expression , _) result =
   fun e ->
   let%bind e = compile_expression' e in
   ok @@ e None
 
-and compile_expression' : I.expression -> (O.expression option -> O.expression) result =
+and compile_expression' : I.expression -> (O.expression option -> O.expression, Errors.imperative_to_sugar_error) result =
   fun e ->
   let return expr = ok @@ function
     | None -> expr 
@@ -317,7 +298,7 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
       let%bind w = compile_while w in
       ok @@ w
 
-and compile_path : I.access list -> O.access list result =
+and compile_path : I.access list -> (O.access list, Errors.imperative_to_sugar_error) result =
   fun path ->
   let aux a = match a with
     | I.Access_record s -> ok @@ O.Access_record s
@@ -328,14 +309,14 @@ and compile_path : I.access list -> O.access list result =
   in
   bind_map_list aux path
 
-and compile_lambda : I.lambda -> O.lambda result =
+and compile_lambda : I.lambda -> (O.lambda, _) result =
   fun {binder;input_type;output_type;result}->
     let%bind input_type = bind_map_option compile_type_expression input_type in
     let%bind output_type = bind_map_option compile_type_expression output_type in
     let%bind result = compile_expression result in
     ok @@ O.{binder;input_type;output_type;result}
 
-and compile_matching : I.matching -> Location.t -> (O.expression option -> O.expression) result =
+and compile_matching : I.matching -> Location.t -> (O.expression option -> O.expression, Errors.imperative_to_sugar_error) result =
   fun {matchee;cases} loc ->
   let return expr = ok @@ function
     | None -> expr 
@@ -547,12 +528,12 @@ let compile_declaration : I.declaration Location.wrap -> _ =
     let%bind te = compile_type_expression te in
     return @@ O.Declaration_type (n,te)
 
-let compile_program : I.program -> O.program result =
+let compile_program : I.program -> (O.program , Errors.imperative_to_sugar_error) result =
   fun p ->
   bind_map_list compile_declaration p
 
 (* uncompiling *)
-let rec uncompile_type_expression : O.type_expression -> I.type_expression result =
+let rec uncompile_type_expression : O.type_expression -> (I.type_expression , Errors.imperative_to_sugar_error) result =
   fun te ->
   let return te = ok @@ I.make_t te in
   match te.type_content with
@@ -590,7 +571,7 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
       let%bind lst = bind_map_list uncompile_type_expression lst in
       return @@ T_operator (type_operator, lst)
 
-let rec uncompile_expression : O.expression -> I.expression result =
+let rec uncompile_expression : O.expression -> (I.expression , Errors.imperative_to_sugar_error) result =
   fun e ->
   let return expr = ok @@ I.make_e ~loc:e.location expr in
   match e.expression_content with 
@@ -680,7 +661,7 @@ let rec uncompile_expression : O.expression -> I.expression result =
     return @@ I.E_sequence {expr1; expr2}
   | O.E_skip -> return @@ I.E_skip
 
-and uncompile_path : O.access list -> I.access list result =
+and uncompile_path : O.access list -> (I.access list, Errors.imperative_to_sugar_error) result =
   fun path -> let aux a = match a with
     | O.Access_record s -> ok @@ I.Access_record s
     | O.Access_tuple  i -> ok @@ I.Access_tuple  i
@@ -690,13 +671,13 @@ and uncompile_path : O.access list -> I.access list result =
   in
   bind_map_list aux path
 
-and uncompile_lambda : O.lambda -> I.lambda result =
+and uncompile_lambda : O.lambda -> (I.lambda , Errors.imperative_to_sugar_error) result =
   fun {binder;input_type;output_type;result}->
     let%bind input_type = bind_map_option uncompile_type_expression input_type in
     let%bind output_type = bind_map_option uncompile_type_expression output_type in
     let%bind result = uncompile_expression result in
     ok @@ I.{binder;input_type;output_type;result}
-and uncompile_matching : O.matching_expr -> I.matching_expr result =
+and uncompile_matching : O.matching_expr -> (I.matching_expr , Errors.imperative_to_sugar_error) result =
   fun m -> 
   match m with 
     | O.Match_list {match_nil;match_cons} ->

src/passes/05-self_ast_sugar/helpers.ml

@@ -16,8 +16,8 @@ let bind_map_lmap_t f map = bind_lmap (
       ok {field with field_type = field'}) 
     map)
 
-type 'a folder = 'a -> expression -> 'a result
+type ('a , 'err) folder = 'a -> expression -> ('a , 'err) result
-let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
+let rec fold_expression : ('a, 'err) folder -> 'a -> expression -> ('a, 'err) result = fun f init e ->
   let self = fold_expression f in 
   let%bind init' = f init e in
   match e.expression_content with
@@ -98,7 +98,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
     ok res
   )
      
-and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
+and fold_cases : ('a, 'err) folder -> 'a -> matching_expr -> ('a, 'err) result = fun f init m ->
   match m with
   | Match_variant lst -> (
       let aux init' ((_ , _) , e) =
@@ -130,12 +130,12 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
       ok res
     )
 
-type exp_mapper = expression -> expression result
+type 'err exp_mapper = expression -> (expression, 'err) result
-type ty_exp_mapper = type_expression -> type_expression result
+type 'err ty_exp_mapper = type_expression -> (type_expression, 'err) result
-type abs_mapper =
+type 'err abs_mapper =
-  | Expression of exp_mapper
+  | Expression of 'err exp_mapper
-  | Type_expression of ty_exp_mapper 
+  | Type_expression of 'err ty_exp_mapper 
-let rec map_expression : exp_mapper -> expression -> expression result = fun f e ->
+let rec map_expression : 'err exp_mapper -> expression -> (expression, 'err) result = fun f e ->
   let self = map_expression f in
   let%bind e' = f e in
   let return expression_content = ok { e' with expression_content } in
@@ -233,7 +233,7 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
   )
   | E_literal _ | E_variable _ | E_raw_code _ | E_skip as e' -> return e'
 
-and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
+and map_type_expression : 'err ty_exp_mapper -> type_expression -> (type_expression, 'err) result = fun f te ->
   let self = map_type_expression f in
   let%bind te' = f te in
   let return type_content = ok { type_content; location=te.location } in
@@ -254,7 +254,7 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
   | T_operator _
   | T_variable _ | T_constant _ -> ok te'
 
-and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
+and map_cases : 'err exp_mapper -> matching_expr -> (matching_expr, 'err) result = fun f m ->
   match m with
   | Match_variant lst -> (
       let aux ((a , b) , e) =
@@ -287,7 +287,7 @@ and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
       ok @@ Match_variable (name, ty_opt, e')
     )
 
-and map_program : abs_mapper -> program -> program result = fun m p ->
+and map_program : 'err abs_mapper -> program -> (program, 'err) result = fun m p ->
   let aux = fun (x : declaration) ->
     match x,m with
     | (Declaration_constant (t , o , i, e), Expression m') -> (
@@ -303,8 +303,8 @@ and map_program : abs_mapper -> program -> program result = fun m p ->
   in
   bind_map_list (bind_map_location aux) p
 
-type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
+type ('a, 'err) fold_mapper = 'a -> expression -> (bool * 'a * expression, 'err) result
-let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
+let rec fold_map_expression : ('a, 'err) fold_mapper -> 'a -> expression -> ('a * expression, 'err) result = fun f a e ->
   let self = fold_map_expression f in
   let%bind (continue, init',e') = f a e in
   if (not continue) then ok(init',e')
@@ -405,7 +405,7 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
     )
   | E_literal _ | E_variable _ | E_raw_code _ | E_skip as e' -> ok (init', return e')
 
-and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
+and fold_map_cases : ('a,'err) fold_mapper -> 'a -> matching_expr -> ('a * matching_expr, 'err) result = fun f init m ->
   match m with
   | Match_variant lst -> (
       let aux init ((a , b) , e) =

src/passes/06-sugar_to_core/sugar_to_core.ml

@@ -2,7 +2,12 @@ module I = Ast_sugar
 module O = Ast_core
 open Trace
 
-let rec compile_type_expression : I.type_expression -> O.type_expression result =
+module Errors = struct
+  type sugar_to_core_error = []
+end
+open Errors
+
+let rec compile_type_expression : I.type_expression -> (O.type_expression , sugar_to_core_error) result =
   fun te ->
   let return tc = ok @@ O.make_t ~loc:te.location tc in
   match te.type_content with
@@ -45,7 +50,7 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
       let%bind lst = bind_map_list compile_type_expression lst in
       return @@ T_operator (type_operator, lst)
 
-let rec compile_expression : I.expression -> O.expression result =
+let rec compile_expression : I.expression -> (O.expression , sugar_to_core_error) result =
   fun e ->
   let return expr = ok @@ O.make_e ~loc:e.location expr in
   match e.expression_content with
@@ -183,13 +188,13 @@ let rec compile_expression : I.expression -> O.expression result =
       let m = O.LMap.of_list lst in
       return @@ O.E_record m
 
-and compile_lambda : I.lambda -> O.lambda result =
+and compile_lambda : I.lambda -> (O.lambda , sugar_to_core_error) result =
   fun {binder;input_type;output_type;result}->
     let%bind input_type = bind_map_option compile_type_expression input_type in
     let%bind output_type = bind_map_option compile_type_expression output_type in
     let%bind result = compile_expression result in
     ok @@ O.{binder;input_type;output_type;result}
-and compile_matching : Location.t -> O.expression -> I.matching_expr -> O.expression result =
+and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expression, sugar_to_core_error) result =
   fun loc e m -> 
   match m with 
     | I.Match_list {match_nil;match_cons} ->
@@ -260,12 +265,12 @@ let compile_declaration : I.declaration Location.wrap -> _ =
     let%bind te = compile_type_expression te in
     return @@ O.Declaration_type (n,te)
 
-let compile_program : I.program -> O.program result =
+let compile_program : I.program -> (O.program , sugar_to_core_error) result =
   fun p ->
   bind_map_list compile_declaration p
 
 (* uncompiling *)
-let rec uncompile_type_expression : O.type_expression -> I.type_expression result =
+let rec uncompile_type_expression : O.type_expression -> (I.type_expression , sugar_to_core_error) result =
   fun te ->
   let return te = ok @@ I.make_t te in
   match te.type_content with
@@ -301,7 +306,7 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
       let%bind lst = bind_map_list uncompile_type_expression lst in
       return @@ T_operator (type_operator, lst)
 
-let rec uncompile_expression : O.expression -> I.expression result =
+let rec uncompile_expression : O.expression -> (I.expression , sugar_to_core_error) result =
   fun e ->
   let return expr = ok @@ I.make_e ~loc:e.location expr in
   match e.expression_content with 
@@ -364,13 +369,13 @@ let rec uncompile_expression : O.expression -> I.expression result =
     let%bind type_annotation = uncompile_type_expression type_annotation in
     return @@ I.E_ascription {anno_expr; type_annotation}
 
-and uncompile_lambda : O.lambda -> I.lambda result =
+and uncompile_lambda : O.lambda -> (I.lambda , sugar_to_core_error) result =
   fun {binder;input_type;output_type;result}->
     let%bind input_type = bind_map_option uncompile_type_expression input_type in
     let%bind output_type = bind_map_option uncompile_type_expression output_type in
     let%bind result = uncompile_expression result in
     ok @@ I.{binder;input_type;output_type;result}
-and uncompile_matching : O.matching_expr -> I.matching_expr result =
+and uncompile_matching : O.matching_expr -> (I.matching_expr , sugar_to_core_error) result =
   fun m -> 
   match m with 
     | O.Match_list {match_nil;match_cons} ->

src/passes/07-self_ast_core/helpers.ml

@@ -19,8 +19,8 @@ let bind_map_lmap_t f map = bind_lmap (
       ok {field with field_type = field'}) 
     map)
 
-type 'a folder = 'a -> expression -> 'a result
+type ('a,'err) folder = 'a -> expression -> ('a, 'err) result
-let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
+let rec fold_expression : ('a, 'err) folder -> 'a -> expression -> ('a,'err) result = fun f init e ->
   let self = fold_expression f in 
   let%bind init' = f init e in
   match e.expression_content with
@@ -70,7 +70,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
       let%bind res = self init' e in
       ok res
 
-and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
+and fold_cases : ('a , 'err) folder -> 'a -> matching_expr -> ('a , 'err) result = fun f init m ->
   match m with
   | Match_list { match_nil ; match_cons = (_ , _ , cons) } -> (
       let%bind res = fold_expression f init match_nil in
@@ -90,12 +90,12 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
       ok res
     )
 
-type exp_mapper = expression -> expression result
+type 'err exp_mapper = expression -> (expression , 'err) result
-type ty_exp_mapper = type_expression -> type_expression result
+type 'err ty_exp_mapper = type_expression -> (type_expression , 'err) result
-type abs_mapper =
+type 'err abs_mapper =
-  | Expression of exp_mapper
+  | Expression of 'err exp_mapper
-  | Type_expression of ty_exp_mapper 
+  | Type_expression of 'err ty_exp_mapper 
-let rec map_expression : exp_mapper -> expression -> expression result = fun f e ->
+let rec map_expression : 'err exp_mapper -> expression -> (expression , 'err) result = fun f e ->
   let self = map_expression f in
   let%bind e' = f e in
   let return expression_content = ok { e' with expression_content } in
@@ -150,7 +150,8 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
     )
   | E_literal _ | E_variable _ | E_raw_code _ as e' -> return e'
 
-and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f ({type_content ; location ; type_meta} as te) ->
+and map_type_expression : 'err ty_exp_mapper -> type_expression -> (type_expression , 'err) result =
+    fun f ({type_content ; location ; type_meta} as te) ->
   let self = map_type_expression f in
   let%bind te' = f te in
   let return type_content = ok { type_content; location ; type_meta } in
@@ -168,7 +169,7 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
   | T_operator _
   | T_variable _ | T_constant _ -> ok te'
 
-and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
+and map_cases : 'err exp_mapper -> matching_expr -> (matching_expr , 'err) result = fun f m ->
   match m with
   | Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
       let%bind match_nil = map_expression f match_nil in
@@ -189,7 +190,7 @@ and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
       ok @@ Match_variant lst'
     )
 
-and map_program : abs_mapper -> program -> program result = fun m p ->
+and map_program : 'err abs_mapper -> program -> (program , 'err) result = fun m p ->
   let aux = fun (x : declaration) ->
     match x,m with
     | (Declaration_constant (t , o , i, e), Expression m') -> (
@@ -205,8 +206,8 @@ and map_program : abs_mapper -> program -> program result = fun m p ->
   in
   bind_map_list (bind_map_location aux) p
 
-type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
+type ('a , 'err) fold_mapper = 'a -> expression -> (bool * 'a * expression , 'err) result
-let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
+let rec fold_map_expression : ('a , 'err) fold_mapper -> 'a -> expression -> ('a * expression , 'err) result = fun f a e ->
   let self = fold_map_expression f in
   let%bind (continue, init',e') = f a e in
   if (not continue) then ok(init',e')
@@ -264,7 +265,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
     )
   | E_literal _ | E_variable _ | E_raw_code _ as e' -> ok (init', return e')
 
-and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
+and fold_map_cases : ('a , 'err) fold_mapper -> 'a -> matching_expr -> ('a * matching_expr , 'err) result =
+    fun f init m ->
   match m with
   | Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
       let%bind (init, match_nil) = fold_map_expression f init match_nil in

src/passes/08-typer-common/constant_typers.ml

@@ -0,0 +1,753 @@
+open Trace
+open Helpers
+open Errors
+open Ast_typed
+
+(*
+  Each constant has its own type.
+
+  LIGO's type-system is currently too
+  weak to express the constant's type. For instance:
+  - "ADD" has a special kind of type of polymorphism. If "ADD" gets two `int`s,
+    it will return an `int`. If it gets two `nat`s, it will return a `nat`.
+    Regular polymorphism wouldn't work because "ADD" only accepts `int`s or
+    `nat`s.
+  - "NONE" (from Some/None) requires an annotation.
+
+  Instead of a LIGO type, constant types are representend as functions. These
+  functions take as parameters:
+  - The list of types of the arguments of the constants. When typing `2 + 2`,
+    the types might be `[ int ; int ]`.
+  - The expected type of the whole expression. It is optional. When typing
+    `[] : list(operation)`, it will be `Some ( list (operation) )`. When
+    typing `2 + 2` (with no additional context), it will be `None`.
+  The output is the type of the whole expression. An error is returned through
+  the Trace monad if it doesn't type-check (`"toto" + 42`).
+
+  Various helpers are defined bellow.
+*)
+
+
+let none = typer_0 "NONE" @@ fun tv_opt ->
+  match tv_opt with
+  | None -> fail not_annotated
+  | Some t -> ok t
+
+let set_empty = typer_0 "SET_EMPTY" @@ fun tv_opt ->
+  match tv_opt with
+  | None -> fail not_annotated
+  | Some t -> ok t
+
+let sub = typer_2 "SUB" @@ fun a b ->
+  if (eq_1 a (t_int ()) || eq_1 a (t_nat ()))
+  && (eq_1 b (t_int ()) || eq_1 b (t_nat ()))
+  then ok @@ t_int () else
+  if (eq_2 (a , b) (t_timestamp ()))
+  then ok @@ t_int () else
+  if (eq_1 a (t_timestamp ()) && eq_1 b (t_int ()))
+  then ok @@ t_timestamp () else
+  if (eq_2 (a , b) (t_mutez ()))
+  then ok @@ t_mutez () else
+    fail bad_substraction
+
+let some = typer_1 "SOME" @@ fun a -> ok @@ t_option a ()
+
+let map_remove : typer = typer_2 "MAP_REMOVE" @@ fun k m ->
+  let%bind (src , _) = bind_map_or (
+      (fun m -> trace_option (expected_map m) @@ get_t_map m) ,
+      (fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
+    ) m in
+  let%bind () = assert_eq src k in
+  ok m
+
+let map_empty = typer_0 "MAP_EMPTY" @@ fun tv_opt ->
+  match tv_opt with
+  | None -> fail not_annotated
+  | Some t -> 
+    let%bind (src, dst) = trace_option (expected_map t) @@ get_t_map t in
+    ok @@ t_map src dst ()
+
+let big_map_empty = typer_0 "BIG_MAP_EMPTY" @@ fun tv_opt ->
+  match tv_opt with
+  | None -> fail not_annotated
+  | Some t -> 
+    let%bind (src, dst) = trace_option (expected_big_map t) @@ get_t_big_map t in
+    ok @@ t_big_map src dst ()
+
+let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m ->
+  let%bind (src , dst) = bind_map_or (
+      (fun m -> trace_option (expected_map m) @@ get_t_map m) ,
+      (fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
+    ) m in
+  let%bind () = assert_eq src k in
+  let%bind () = assert_eq dst v in
+  ok m
+
+let map_update : typer = typer_3 "MAP_UPDATE" @@ fun k v m ->
+  let%bind (src , dst) = bind_map_or (
+      (fun m -> trace_option (expected_map m) @@ get_t_map m) ,
+      (fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
+    ) m in
+  let%bind () = assert_eq src k in
+  let%bind v' = trace_option (expected_option v) @@ get_t_option v in
+  let%bind () = assert_eq dst v' in
+  ok m
+
+let map_mem : typer = typer_2 "MAP_MEM" @@ fun k m ->
+  let%bind (src , _dst) = bind_map_or (
+      (fun m -> trace_option (expected_map m) @@ get_t_map m) ,
+      (fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
+    ) m in
+  let%bind () = assert_eq src k in
+  ok @@ t_bool ()
+
+let map_find : typer = typer_2 "MAP_FIND" @@ fun k m ->
+  let%bind (src , dst) = bind_map_or (
+      (fun m -> trace_option (expected_map m) @@ get_t_map m) ,
+      (fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
+    ) m in
+  let%bind () = assert_eq src k in
+  ok @@ dst
+
+let map_find_opt : typer = typer_2 "MAP_FIND_OPT" @@ fun k m ->
+  let%bind (src , dst) = bind_map_or (
+      (fun m -> trace_option (expected_map m) @@ get_t_map m) ,
+      (fun m -> trace_option (expected_big_map m) @@ get_t_big_map m)
+    ) m in
+  let%bind () = assert_eq src k in
+  ok @@ t_option dst ()
+
+let map_iter : typer = typer_2 "MAP_ITER" @@ fun f m ->
+  let%bind (k, v) = trace_option (expected_map m) @@ get_t_map m in
+  let%bind (arg , res) = trace_option (expected_function f) @@ get_t_function f in
+  let kv = t_pair k v () in
+  let unit = t_unit () in
+  let%bind () = assert_eq arg kv in
+  let%bind () = assert_eq res unit in
+  ok @@ t_unit ()
+
+let map_map : typer = typer_2 "MAP_MAP" @@ fun f m ->
+  let%bind (k, v) = trace_option (expected_map m) @@ get_t_map m in
+  let%bind (arg , res) = trace_option (expected_function f) @@ get_t_function f in
+  let kv = t_pair k v () in
+  let%bind () = assert_eq arg kv in
+  ok @@ t_map k res ()
+
+let size = typer_1 "SIZE" @@ fun t ->
+  let%bind () =
+    Assert.assert_true (wrong_size t) @@
+    (is_t_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t ) in
+  ok @@ t_nat ()
+
+let slice = typer_3 "SLICE" @@ fun i j s ->
+  let t_nat = t_nat () in
+  let%bind () = assert_eq i t_nat in
+  let%bind () = assert_eq j t_nat in
+  if eq_1 s (t_string ())
+  then ok @@ t_string ()
+  else if eq_1 s (t_bytes ())
+  then ok @@ t_bytes ()
+  else fail @@ typeclass_error
+                 [
+                   [t_nat;t_nat;t_string()] ;
+                   [t_nat;t_nat;t_bytes()] ;
+                 ]
+                 [i ; j ; s]
+
+let failwith_ = typer_1_opt "FAILWITH" @@ fun t opt ->
+  let%bind _ =
+    if eq_1 t (t_string ())
+    then ok ()
+    else if eq_1 t (t_nat ())
+    then ok ()
+    else if eq_1 t (t_int ())
+    then ok ()
+    else
+      fail @@ typeclass_error
+        [
+          [t_string()] ;
+          [t_nat()] ;
+          [t_int()] ;
+        ]
+        [t] in
+  let default = t_unit () in
+  ok @@ Simple_utils.Option.unopt ~default opt
+
+let int : typer = typer_1 "INT" @@ fun t ->
+  let%bind () = trace_option (expected_nat t) @@ assert_t_nat t in
+  ok @@ t_int ()
+
+let bytes_pack : typer = typer_1 "PACK" @@ fun _t ->
+  ok @@ t_bytes ()
+
+let bytes_unpack = typer_1_opt "UNPACK" @@ fun input output_opt ->
+  let%bind () = trace_option (expected_bytes input) @@ assert_t_bytes input in
+  trace_option not_annotated @@ output_opt
+
+let hash256 = typer_1 "SHA256" @@ fun t ->
+  let%bind () = trace_option (expected_bytes t) @@ assert_t_bytes t in
+  ok @@ t_bytes ()
+
+let hash512 = typer_1 "SHA512" @@ fun t ->
+  let%bind () = trace_option (expected_bytes t) @@ assert_t_bytes t in
+  ok @@ t_bytes ()
+
+let blake2b = typer_1 "BLAKE2b" @@ fun t ->
+  let%bind () = trace_option (expected_bytes t) @@ assert_t_bytes t in
+  ok @@ t_bytes ()
+
+let hash_key = typer_1 "HASH_KEY" @@ fun t ->
+  let%bind () = trace_option (expected_key t) @@ assert_t_key t in
+  ok @@ t_key_hash ()
+
+let check_signature = typer_3 "CHECK_SIGNATURE" @@ fun k s b ->
+  let%bind () = trace_option (expected_key k) @@ assert_t_key k in
+  let%bind () = trace_option (expected_signature s) @@ assert_t_signature s in
+  let%bind () = trace_option (expected_bytes b) @@ assert_t_bytes b in
+  ok @@ t_bool ()
+
+let sender = constant' "SENDER" @@ t_address ()
+
+let source = constant' "SOURCE" @@ t_address ()
+
+let unit = constant' "UNIT" @@ t_unit ()
+
+let amount = constant' "AMOUNT" @@ t_mutez ()
+
+let balance = constant' "BALANCE" @@ t_mutez ()
+
+let chain_id = constant' "CHAIN_ID" @@ t_chain_id ()
+
+let address = typer_1 "ADDRESS" @@ fun c ->
+  let%bind () = trace_option (expected_contract c) @@ assert_t_contract c in
+  ok @@ t_address ()
+
+let self_address = typer_0 "SELF_ADDRESS" @@ fun _ ->
+  ok @@ t_address ()
+
+let self = typer_1_opt "SELF" @@ fun entrypoint_as_string tv_opt ->
+  let%bind () = trace_option (expected_string entrypoint_as_string) @@ assert_t_string entrypoint_as_string in
+  match tv_opt with
+  | None -> fail not_annotated
+  | Some t -> ok @@ t
+
+let implicit_account = typer_1 "IMPLICIT_ACCOUNT" @@ fun key_hash ->
+  let%bind () = trace_option (expected_key_hash key_hash) @@ assert_t_key_hash key_hash in
+  ok @@ t_contract (t_unit () ) ()
+
+let now = constant' "NOW" @@ t_timestamp ()
+
+let transaction = typer_3 "CALL" @@ fun param amount contract ->
+  let%bind () = trace_option (expected_mutez amount) @@ assert_t_mutez amount in
+  let%bind contract_param = trace_option (expected_contract contract) @@ get_t_contract contract in
+  let%bind () = assert_eq param contract_param in
+  ok @@ t_operation ()
+
+let create_contract = typer_4 "CREATE_CONTRACT" @@ fun f kh_opt amount init_storage  ->
+  let%bind (args , ret) = trace_option (expected_function f) @@ get_t_function f in
+  let%bind (_,s) = trace_option (expected_pair args) @@ get_t_pair args in
+  let%bind (oplist,s') = trace_option (expected_pair ret) @@ get_t_pair ret in
+  let%bind () = trace_option (expected_mutez amount) @@ assert_t_mutez amount in
+  let%bind (delegate) = trace_option (expected_option kh_opt) @@ get_t_option kh_opt in
+  let%bind () = assert_eq s s' in
+  let%bind () = assert_eq s init_storage in
+  let%bind () = trace_option (expected_op_list oplist) @@ assert_t_list_operation oplist in
+  let%bind () = trace_option (expected_key_hash delegate) @@ assert_t_key_hash delegate in
+  ok @@ t_pair (t_operation ()) (t_address ()) ()
+
+let get_contract = typer_1_opt "CONTRACT" @@ fun addr_tv tv_opt ->
+  let t_addr = t_address () in
+  let%bind () = assert_eq addr_tv t_addr in
+  let%bind tv = trace_option not_annotated tv_opt in
+  let%bind tv' = trace_option (expected_contract tv) @@ get_t_contract tv in
+  ok @@ t_contract tv' ()
+
+let get_contract_opt = typer_1_opt "CONTRACT OPT" @@ fun addr_tv tv_opt ->
+  let t_addr = t_address () in
+  let%bind () = assert_eq addr_tv t_addr in
+  let%bind tv = trace_option not_annotated tv_opt in
+  let%bind tv = trace_option (expected_option tv) @@ get_t_option tv in
+  let%bind tv' = trace_option (expected_contract tv) @@ get_t_contract tv in
+  ok @@ t_option (t_contract tv' ()) ()
+
+let get_entrypoint = typer_2_opt "CONTRACT_ENTRYPOINT" @@ fun entry_tv addr_tv tv_opt ->
+  let t_string = t_string () in
+  let t_addr = t_address () in
+  let%bind () = assert_eq entry_tv t_string in
+  let%bind () = assert_eq addr_tv t_addr in
+  let%bind tv = trace_option not_annotated tv_opt in
+  let%bind tv' = trace_option (expected_contract tv) @@ get_t_contract tv in
+  ok @@ t_contract tv' ()
+
+let get_entrypoint_opt = typer_2_opt "CONTRACT_ENTRYPOINT_OPT" @@ fun entry_tv addr_tv tv_opt ->
+  let t_string = t_string () in
+  let t_addr = t_address () in
+  let%bind () = assert_eq entry_tv t_string in
+  let%bind () = assert_eq addr_tv t_addr in
+  let%bind tv = trace_option not_annotated tv_opt in
+  let%bind tv = trace_option (expected_option tv) @@ get_t_option tv in
+  let%bind tv' = trace_option (expected_contract tv) @@ get_t_contract tv in
+  ok @@ t_option (t_contract tv' ())()
+
+let set_delegate = typer_1 "SET_DELEGATE" @@ fun delegate_opt ->
+  let kh_opt = (t_option (t_key_hash ()) ()) in
+  let%bind () = assert_eq delegate_opt kh_opt in
+  ok @@ t_operation ()
+
+let abs = typer_1 "ABS" @@ fun t ->
+  let%bind () = trace_option (expected_int t) @@ assert_t_int t in
+  ok @@ t_nat ()
+
+let is_nat = typer_1 "ISNAT" @@ fun t ->
+  let%bind () = trace_option (expected_int t) @@ assert_t_int t in
+  ok @@ t_option (t_nat ()) ()
+
+let neg = typer_1 "NEG" @@ fun t ->
+  let%bind () = Assert.assert_true (wrong_neg t) @@ (eq_1 t (t_nat ()) || eq_1 t (t_int ())) in
+  ok @@ t_int ()
+
+let assertion = typer_1 "ASSERT" @@ fun a ->
+  let%bind () = trace_option (expected_bool a) @@ assert_t_bool a in
+  ok @@ t_unit ()
+
+let times = typer_2 "TIMES" @@ fun a b ->
+  if eq_2 (a , b) (t_nat ())
+  then ok @@ t_nat () else
+  if eq_2 (a , b) (t_int ())
+  then ok @@ t_int () else
+  if (eq_1 a (t_nat ()) && eq_1 b (t_mutez ())) || (eq_1 b (t_nat ()) && eq_1 a (t_mutez ()))
+  then ok @@ t_mutez () else
+    fail @@ typeclass_error
+              [
+                [t_nat();t_nat()] ;
+                [t_int();t_int()] ;
+                [t_nat();t_mutez()] ;
+                [t_mutez();t_nat()] ;
+              ]
+              [a; b]
+
+let ediv = typer_2 "EDIV" @@ fun a b ->
+  if eq_2 (a , b) (t_nat ())
+  then ok @@ t_option (t_pair (t_nat ()) (t_nat ()) ()) () else
+  if eq_2 (a , b) (t_int ())
+  then ok @@ t_option (t_pair (t_int ()) (t_nat ()) ()) () else
+  if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ())
+  then ok @@ t_option (t_pair (t_nat ()) (t_mutez ()) ()) () else
+  if eq_1 a (t_mutez ()) && eq_1 b (t_nat ())
+  then ok @@ t_option (t_pair (t_mutez ()) (t_mutez ()) ()) () else
+    fail @@ typeclass_error
+              [
+                [t_nat();t_nat()] ;
+                [t_int();t_int()] ;
+                [t_mutez();t_nat()] ;
+                [t_mutez();t_mutez()] ;
+              ]
+              [a; b]
+
+let div = typer_2 "DIV" @@ fun a b ->
+  if eq_2 (a , b) (t_nat ())
+  then ok @@ t_nat () else
+  if eq_2 (a , b) (t_int ())
+  then ok @@ t_int () else
+  if eq_1 a (t_mutez ()) && eq_1 b (t_nat ())
+  then ok @@ t_mutez () else
+  if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ())
+  then ok @@ t_nat () else
+    fail @@ typeclass_error
+              [
+                [t_nat();t_nat()] ;
+                [t_int();t_int()] ;
+                [t_mutez();t_nat()] ;
+                [t_mutez();t_mutez()] ;
+              ]
+              [a; b]
+
+let mod_ = typer_2 "MOD" @@ fun a b ->
+  if (eq_1 a (t_nat ()) || eq_1 a (t_int ())) && (eq_1 b (t_nat ()) || eq_1 b (t_int ()))
+  then ok @@ t_nat () else
+  if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ())
+  then ok @@ t_mutez () else
+    fail @@ typeclass_error
+              [
+                [t_nat();t_nat()] ;
+                [t_nat();t_int()] ;
+                [t_int();t_nat()] ;
+                [t_int();t_int()] ;
+                [t_mutez();t_mutez()] ;
+              ]
+              [a; b]
+
+let add = typer_2 "ADD" @@ fun a b ->
+  if eq_2 (a , b) (t_nat ())
+  then ok @@ t_nat () else
+  if eq_2 (a , b) (t_int ())
+  then ok @@ t_int () else
+  if eq_2 (a , b) (t_mutez ())
+  then ok @@ t_mutez () else
+  if (eq_1 a (t_nat ()) && eq_1 b (t_int ())) || (eq_1 b (t_nat ()) && eq_1 a (t_int ()))
+  then ok @@ t_int () else
+  if (eq_1 a (t_timestamp ()) && eq_1 b (t_int ())) || (eq_1 b (t_timestamp ()) && eq_1 a (t_int ()))
+  then ok @@ t_timestamp () else
+    fail @@ typeclass_error
+              [
+                [t_nat();t_nat()] ;
+                [t_int();t_int()] ;
+                [t_mutez();t_mutez()] ;
+                [t_nat();t_int()] ;
+                [t_int();t_nat()] ;
+                [t_timestamp();t_int()] ;
+                [t_int();t_timestamp()] ;
+              ]
+              [a; b]
+
+let set_mem = typer_2 "SET_MEM" @@ fun elt set ->
+  let%bind key = trace_option (expected_set set) @@ get_t_set set in
+  let%bind () = assert_eq elt key in
+  ok @@ t_bool ()
+
+let set_add = typer_2 "SET_ADD" @@ fun elt set ->
+  let%bind key = trace_option (expected_set set) @@ get_t_set set in
+  let%bind () = assert_eq elt key in
+  ok set
+
+let set_remove = typer_2 "SET_REMOVE" @@ fun elt set ->
+  let%bind key = trace_option (expected_set set) @@ get_t_set set in
+  let%bind () = assert_eq elt key in
+  ok set
+
+let set_iter = typer_2 "SET_ITER" @@ fun body set ->
+  let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
+  let%bind () = assert_eq res (t_unit ()) in
+  let%bind key = trace_option (expected_set set) @@ get_t_set set in
+  let%bind () = assert_eq key arg in
+  ok (t_unit ())
+
+let list_empty = typer_0 "LIST_EMPTY" @@ fun tv_opt ->
+  match tv_opt with
+  | None -> fail not_annotated
+  | Some t -> ok t
+
+let list_iter = typer_2 "LIST_ITER" @@ fun body lst ->
+  let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
+  let%bind () = assert_eq res (t_unit ()) in
+  let%bind key = trace_option (expected_list lst) @@ get_t_list lst in
+  let%bind () = assert_eq key arg in
+  ok (t_unit ())
+
+let list_map = typer_2 "LIST_MAP" @@ fun body lst ->
+  let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
+  let%bind key = trace_option (expected_list lst) @@ get_t_list lst in
+  let%bind () = assert_eq key arg in
+  ok (t_list res ())
+
+let list_fold = typer_3 "LIST_FOLD" @@ fun body lst init ->
+  let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
+  let%bind (prec , cur) = trace_option (expected_pair arg) @@ get_t_pair arg in
+  let%bind key = trace_option (expected_list lst) @@ get_t_list lst in
+  trace bad_list_fold_tracer @@
+    let%bind () = assert_eq key cur in
+    let%bind () = assert_eq prec res in
+    let%bind () = assert_eq res init in
+    ok res
+
+let set_fold = typer_3 "SET_FOLD" @@ fun body lst init ->
+  let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
+  let%bind (prec , cur) = trace_option (expected_pair arg) @@ get_t_pair arg in
+  let%bind key = trace_option (expected_set lst) @@ get_t_set lst in
+  trace bad_set_fold_tracer @@
+  let%bind () = assert_eq key cur in
+  let%bind () = assert_eq prec res in
+  let%bind () = assert_eq res init in
+  ok res
+
+let map_fold = typer_3 "MAP_FOLD" @@ fun body map init ->
+  let%bind (arg , res) = trace_option (expected_function body) @@ get_t_function body in
+  let%bind (prec , cur) = trace_option (expected_pair arg) @@ get_t_pair arg in
+  let%bind (key , value) = trace_option (expected_map map) @@ get_t_map map in
+  let kv = t_pair key value () in
+  trace bad_map_fold_tracer @@
+  let%bind () = assert_eq kv cur in
+  let%bind () = assert_eq prec res in
+  let%bind () = assert_eq res init in
+  ok res
+
+(** FOLD_WHILE is a fold operation that takes an initial value of a certain type
+    and then iterates on it until a condition is reached. The auxillary function
+    that does the fold returns either boolean true or boolean false to indicate
+    whether the fold should continue or not. Necessarily then the initial value
+    must match the input parameter of the auxillary function, and the auxillary
+    should return type (bool * input) *)
+let fold_while = typer_2 "FOLD_WHILE" @@ fun body init ->
+  let%bind (arg, result) = trace_option (expected_function body) @@ get_t_function body in
+  let%bind () = assert_eq arg init in
+  let%bind () = assert_eq (t_pair (t_bool ()) init ()) result
+  in ok init
+
+(* Continue and Stop are just syntactic sugar for building a pair (bool * a') *)
+let continue = typer_1 "CONTINUE" @@ fun arg ->
+  ok @@ t_pair (t_bool ()) arg ()
+
+let stop = typer_1 "STOP" @@ fun arg ->
+  ok (t_pair (t_bool ()) arg ())
+
+let not_ = typer_1 "NOT" @@ fun elt ->
+  if eq_1 elt (t_bool ())
+  then ok @@ t_bool ()
+  else if eq_1 elt (t_nat ()) || eq_1 elt (t_int ())
+  then ok @@ t_int ()
+  else fail @@ wrong_not elt
+
+let or_ = typer_2 "OR" @@ fun a b ->
+  if eq_2 (a , b) (t_bool ())
+  then ok @@ t_bool ()
+  else if eq_2 (a , b) (t_nat ())
+  then ok @@ t_nat ()
+  else fail @@ typeclass_error
+                 [
+                   [t_bool();t_bool()] ;
+                   [t_nat();t_nat()] ;
+                 ]
+                 [a; b]
+
+let xor = typer_2 "XOR" @@ fun a b ->
+  if eq_2 (a , b) (t_bool ())
+  then ok @@ t_bool ()
+  else if eq_2 (a , b) (t_nat ())
+  then ok @@ t_nat ()
+  else fail @@ typeclass_error
+                 [
+                   [t_bool();t_bool()] ;
+                   [t_nat();t_nat()] ;
+                 ]
+                 [a; b]
+
+let and_ = typer_2 "AND" @@ fun a b ->
+  if eq_2 (a , b) (t_bool ())
+  then ok @@ t_bool ()
+  else if eq_2 (a , b) (t_nat ()) || (eq_1 b (t_nat ()) && eq_1 a (t_int ()))
+  then ok @@ t_nat ()
+  else fail @@ typeclass_error
+                 [
+                   [t_bool();t_bool()] ;
+                   [t_nat();t_nat()] ;
+                   [t_int();t_nat()] ;
+                 ]
+                 [a; b]
+
+let lsl_ = typer_2 "LSL" @@ fun a b ->
+  if eq_2 (a , b) (t_nat ())
+  then ok @@ t_nat ()
+  else fail @@ typeclass_error
+                 [
+                   [t_nat();t_nat()] ;
+                 ]
+                 [a; b]
+
+let lsr_ = typer_2 "LSR" @@ fun a b ->
+  if eq_2 (a , b) (t_nat ())
+  then ok @@ t_nat ()
+  else fail @@ typeclass_error
+                 [
+                   [t_nat();t_nat()] ;
+                 ]
+                 [a; b]
+
+let concat = typer_2 "CONCAT" @@ fun a b ->
+  if eq_2 (a , b) (t_string ())
+  then ok @@ t_string ()
+  else if eq_2 (a , b) (t_bytes ())
+  then ok @@ t_bytes ()
+  else fail @@ typeclass_error
+                 [
+                   [t_string();t_string()] ;
+                   [t_bytes();t_bytes()] ;
+                 ]
+                 [a; b]
+
+let cons = typer_2 "CONS" @@ fun hd tl ->
+  let%bind elt = trace_option (expected_list tl) @@ get_t_list tl in
+  let%bind () = assert_eq hd elt in
+  ok tl
+
+let convert_to_right_comb = typer_1 "CONVERT_TO_RIGHT_COMB" @@ fun t ->
+  match t.type_content with
+    | T_record lmap ->
+      let kvl = LMap.to_kv_list lmap in
+      let%bind () = Michelson_type_converter.record_checks kvl t.location in
+      let pair = Michelson_type_converter.convert_pair_to_right_comb kvl in
+      ok {t with type_content = pair}
+    | T_sum cmap ->
+      let kvl = CMap.to_kv_list cmap in
+      let%bind () = Michelson_type_converter.variant_checks kvl t.location in
+      let michelson_or = Michelson_type_converter.convert_variant_to_right_comb kvl in
+      ok {t with type_content = michelson_or}
+    | _ -> fail @@ wrong_converter t
+
+let convert_to_left_comb = typer_1 "CONVERT_TO_LEFT_COMB" @@ fun t ->
+  match t.type_content with
+    | T_record lmap ->
+      let kvl =  LMap.to_kv_list lmap in
+      let%bind () = Michelson_type_converter.record_checks kvl t.location in
+      let pair = Michelson_type_converter.convert_pair_to_left_comb kvl in
+      ok {t with type_content = pair}
+    | T_sum cmap ->
+      let kvl = CMap.to_kv_list cmap in
+      let%bind () = Michelson_type_converter.variant_checks kvl t.location in
+      let michelson_or = Michelson_type_converter.convert_variant_to_left_comb kvl in
+      ok {t with type_content = michelson_or}
+    | _ -> fail @@ wrong_converter t
+
+let convert_from_right_comb = typer_1_opt "CONVERT_FROM_RIGHT_COMB" @@ fun t opt ->
+  let%bind dst_t = trace_option not_annotated opt in
+  match t.type_content with
+    | T_record src_lmap ->
+      let%bind dst_lmap = trace_option (expected_record dst_t) @@ get_t_record dst_t in
+      let%bind record = Michelson_type_converter.convert_pair_from_right_comb src_lmap dst_lmap in
+      ok {t with type_content = record}
+    | T_sum src_cmap ->
+      let%bind dst_cmap = trace_option (expected_variant dst_t) @@ get_t_sum dst_t in
+      let%bind variant = Michelson_type_converter.convert_variant_from_right_comb src_cmap dst_cmap in
+      ok {t with type_content = variant}
+    | _ -> fail @@ wrong_converter t
+
+let convert_from_left_comb = typer_1_opt "CONVERT_FROM_LEFT_COMB" @@ fun t opt ->
+  let%bind dst_t = trace_option not_annotated opt in
+  match t.type_content with
+    | T_record src_lmap ->
+      let%bind dst_lmap = trace_option (expected_record dst_t) @@ get_t_record dst_t in
+      let%bind record = Michelson_type_converter.convert_pair_from_left_comb src_lmap dst_lmap in
+      ok {t with type_content = record}
+    | T_sum src_cmap ->
+      let%bind dst_cmap = trace_option (expected_variant dst_t) @@ get_t_sum dst_t in
+      let%bind variant = Michelson_type_converter.convert_variant_from_left_comb src_cmap dst_cmap in
+      ok {t with type_content = variant}
+    | _ -> fail @@ wrong_converter t
+
+let simple_comparator : string -> typer = fun s -> typer_2 s @@ fun a b ->
+  let%bind () =
+    Assert.assert_true (uncomparable_types a b) @@
+    List.exists (eq_2 (a , b)) [
+      t_int () ;
+      t_nat () ;
+      t_bool () ;
+      t_mutez () ;
+      t_string () ;
+      t_bytes () ;
+      t_address () ;
+      t_timestamp () ;
+      t_key_hash () ;
+    ] in
+  ok @@ t_bool ()
+
+let rec pair_comparator : string -> typer = fun s -> typer_2 s @@ fun a b ->
+  let%bind () =
+    Assert.assert_true (uncomparable_types a b) @@ eq_1 a b
+  in
+  let%bind (a_k, a_v) = 
+    trace_option (comparator_composed a) @@
+    get_t_pair a in
+  let%bind (b_k, b_v) = trace_option (expected_pair b) @@ get_t_pair b in
+  let%bind _ = simple_comparator s [a_k;b_k] None
+  in
+  comparator s [a_v;b_v] None
+    
+and comparator : string -> typer = fun s -> typer_2 s @@ fun a b ->
+  bind_or (simple_comparator s [a;b] None, pair_comparator s [a;b] None)
+
+let constant_typers c : (typer , typer_error) result = match c with
+  | C_INT                 -> ok @@ int ;
+  | C_UNIT                -> ok @@ unit ;
+  | C_NOW                 -> ok @@ now ;
+  | C_IS_NAT              -> ok @@ is_nat ;
+  | C_SOME                -> ok @@ some ;
+  | C_NONE                -> ok @@ none ;
+  | C_ASSERTION           -> ok @@ assertion ;
+  | C_FAILWITH            -> ok @@ failwith_ ;
+  (* LOOPS *)
+  | C_FOLD_WHILE          -> ok @@ fold_while ;
+  | C_FOLD_CONTINUE       -> ok @@ continue ;
+  | C_FOLD_STOP           -> ok @@ stop ;
+   (* MATH *)
+  | C_NEG                 -> ok @@ neg ;
+  | C_ABS                 -> ok @@ abs ;
+  | C_ADD                 -> ok @@ add ;
+  | C_SUB                 -> ok @@ sub ;
+  | C_MUL                 -> ok @@ times ;
+  | C_EDIV                -> ok @@ ediv ;
+  | C_DIV                 -> ok @@ div ;
+  | C_MOD                 -> ok @@ mod_ ;
+  (* LOGIC *)
+  | C_NOT                 -> ok @@ not_ ;
+  | C_AND                 -> ok @@ and_ ;
+  | C_OR                  -> ok @@ or_ ;
+  | C_XOR                 -> ok @@ xor ;
+  | C_LSL                 -> ok @@ lsl_;
+  | C_LSR                 -> ok @@ lsr_;
+  (* COMPARATOR *)
+  | C_EQ                  -> ok @@ comparator "EQ" ;
+  | C_NEQ                 -> ok @@ comparator "NEQ" ;
+  | C_LT                  -> ok @@ comparator "LT" ;
+  | C_GT                  -> ok @@ comparator "GT" ;
+  | C_LE                  -> ok @@ comparator "LE" ;
+  | C_GE                  -> ok @@ comparator "GE" ;
+  (* BYTES / STRING *)
+  | C_SIZE                -> ok @@ size ;
+  | C_CONCAT              -> ok @@ concat ;
+  | C_SLICE               -> ok @@ slice ;
+  | C_BYTES_PACK          -> ok @@ bytes_pack ;
+  | C_BYTES_UNPACK        -> ok @@ bytes_unpack ;
+  (* SET  *)
+  | C_SET_EMPTY           -> ok @@ set_empty ;
+  | C_SET_ADD             -> ok @@ set_add ;
+  | C_SET_REMOVE          -> ok @@ set_remove ;
+  | C_SET_ITER            -> ok @@ set_iter ;
+  | C_SET_FOLD            -> ok @@ set_fold ;
+  | C_SET_MEM             -> ok @@ set_mem ;
+
+  (* LIST *)
+  | C_CONS                -> ok @@ cons ;
+  | C_LIST_EMPTY          -> ok @@ list_empty ;
+  | C_LIST_ITER           -> ok @@ list_iter ;
+  | C_LIST_MAP            -> ok @@ list_map ;
+  | C_LIST_FOLD           -> ok @@ list_fold ;
+  (* MAP *)
+  | C_MAP_EMPTY           -> ok @@ map_empty ;
+  | C_BIG_MAP_EMPTY       -> ok @@ big_map_empty ;
+  | C_MAP_ADD             -> ok @@ map_add ;
+  | C_MAP_REMOVE          -> ok @@ map_remove ;
+  | C_MAP_UPDATE          -> ok @@ map_update ;
+  | C_MAP_ITER            -> ok @@ map_iter ;
+  | C_MAP_MAP             -> ok @@ map_map ;
+  | C_MAP_FOLD            -> ok @@ map_fold ;
+  | C_MAP_MEM             -> ok @@ map_mem ;
+  | C_MAP_FIND            -> ok @@ map_find ;
+  | C_MAP_FIND_OPT        -> ok @@ map_find_opt ;
+  (* BIG MAP *)
+  (* CRYPTO *)
+  | C_SHA256              -> ok @@ hash256 ;
+  | C_SHA512              -> ok @@ hash512 ;
+  | C_BLAKE2b             -> ok @@ blake2b ;
+  | C_HASH_KEY            -> ok @@ hash_key ;
+  | C_CHECK_SIGNATURE     -> ok @@ check_signature ;
+  | C_CHAIN_ID            -> ok @@ chain_id ;
+  (*BLOCKCHAIN *)
+  | C_CONTRACT            -> ok @@ get_contract ;
+  | C_CONTRACT_OPT        -> ok @@ get_contract_opt ;
+  | C_CONTRACT_ENTRYPOINT -> ok @@ get_entrypoint ;
+  | C_CONTRACT_ENTRYPOINT_OPT -> ok @@ get_entrypoint_opt ;
+  | C_AMOUNT              -> ok @@ amount ;
+  | C_BALANCE             -> ok @@ balance ;
+  | C_CALL                -> ok @@ transaction ;
+  | C_SENDER              -> ok @@ sender ;
+  | C_SOURCE              -> ok @@ source ;
+  | C_ADDRESS             -> ok @@ address ;
+  | C_SELF                -> ok @@ self;
+  | C_SELF_ADDRESS        -> ok @@ self_address;
+  | C_IMPLICIT_ACCOUNT    -> ok @@ implicit_account;
+  | C_SET_DELEGATE        -> ok @@ set_delegate ;
+  | C_CREATE_CONTRACT     -> ok @@ create_contract ;
+  | C_CONVERT_TO_RIGHT_COMB -> ok @@ convert_to_right_comb ;
+  | C_CONVERT_TO_LEFT_COMB  -> ok @@ convert_to_left_comb ;
+  | C_CONVERT_FROM_RIGHT_COMB -> ok @@ convert_from_right_comb ;
+  | C_CONVERT_FROM_LEFT_COMB  -> ok @@ convert_from_left_comb ;
+  | _                     -> fail (corner_case "typer not implemented for constant")

src/passes/08-typer-common/constant_typers_new.ml

@@ -0,0 +1,182 @@
+open Errors
+open Ast_typed
+open Trace
+
+module Operators_types = struct
+  open Typesystem.Shorthands
+
+  let tc_subarg   a b c = tc "arguments for (-)"        [a;b;c] [ (*TODO…*) ]
+  let tc_sizearg  a     = tc "arguments for size"       [a]     [ [int] ]
+  let tc_packable a     = tc "packable"                 [a]     [ [int] ; [string] ; [bool] (*TODO…*) ]
+  let tc_timargs  a b c = tc "arguments for ( * )"      [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ]
+  let tc_edivargs a b c = tc "arguments for ediv"       [a;b;c] [ (*TODO…*) ]
+  let tc_divargs  a b c = tc "arguments for div"        [a;b;c] [ (*TODO…*) ]
+  let tc_modargs  a b c = tc "arguments for mod"        [a;b;c] [ (*TODO…*) ]
+  let tc_addargs  a b c = tc "arguments for (+)"        [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ]
+  let tc_comparable a   = tc "comparable"               [a]     [ [nat] ; [int] ; [mutez] ; [timestamp] ]
+  let tc_concatable a   = tc "concatenable"             [a]     [ [string] ; [bytes] ]
+  let tc_storable a     = tc "storable"                 [a]     [ [string] ; [bytes] ; (*Humm .. TODO ?*) ]
+
+  let t_none         = forall "a" @@ fun a -> option a
+
+  let t_sub          = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_subarg a b c] => tuple2 a b --> c (* TYPECLASS *)
+  let t_some         = forall "a" @@ fun a -> a --> option a
+  let t_map_remove   = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> map src dst
+  let t_map_add      = forall2 "src" "dst" @@ fun src dst -> tuple3 src dst (map src dst) --> map src dst
+  let t_map_update   = forall2 "src" "dst" @@ fun src dst -> tuple3 src (option dst) (map src dst) --> map src dst
+  let t_map_mem      = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> bool
+  let t_map_find     = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> dst
+  let t_map_find_opt = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> option dst
+  let t_map_fold     = forall3 "src" "dst" "acc" @@ fun src dst acc -> tuple3 ( ( (src * dst) * acc ) --> acc ) (map src dst) acc --> acc
+  let t_map_map      = forall3 "k" "v" "result" @@ fun k v result -> tuple2 ((k * v) --> result) (map k v) --> map k result
+
+  (* TODO: the type of map_map_fold might be wrong, check it. *)
+  let t_map_map_fold = forall4 "k" "v" "acc" "dst" @@ fun k v acc dst -> tuple3 ( ((k * v) * acc) --> acc * dst ) (map k v) (k * v) --> (map k dst * acc)
+  let t_map_iter     = forall2 "k" "v" @@ fun k v -> tuple2 ( (k * v) --> unit ) (map k v) --> unit
+  let t_size         = forall_tc "c" @@ fun c -> [tc_sizearg c] => tuple1 c --> nat (* TYPECLASS *)
+  let t_slice        = tuple3 nat nat string --> string
+  let t_failwith     = tuple1 string --> unit
+  let t_get_force    = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> dst
+  let t_int          = tuple1 nat --> int
+  let t_bytes_pack   = forall_tc "a" @@ fun a -> [tc_packable a] => tuple1 a --> bytes (* TYPECLASS *)
+  let t_bytes_unpack = forall_tc "a" @@ fun a -> [tc_packable a] => tuple1 bytes --> a (* TYPECLASS *)
+  let t_hash256      = tuple1 bytes --> bytes
+  let t_hash512      = tuple1 bytes --> bytes
+  let t_blake2b      = tuple1 bytes --> bytes
+  let t_hash_key     = tuple1 key --> key_hash
+  let t_is_nat       = tuple1 int --> bool
+  let t_check_signature = tuple3 key signature bytes --> bool
+  let t_chain_id     = tuple0 --> chain_id
+  let t_sender       = tuple0 --> address
+  let t_source       = tuple0 --> address
+  let t_unit         = tuple0 --> unit
+  let t_amount       = tuple0 --> mutez
+  let t_balance      = tuple0 --> mutez
+  let t_address      = tuple0 --> address
+  let t_now          = tuple0 --> timestamp
+  let t_transaction  = forall "a" @@ fun a -> tuple3 a mutez (contract a) --> operation
+  let t_get_contract = forall "a" @@ fun a -> tuple0 --> contract a
+  let t_abs          = tuple1 int --> nat
+  let t_cons         = forall "a" @@ fun a -> tuple2 a (list a) --> list a
+  let t_assertion    = tuple1 bool --> unit
+  let t_times        = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_timargs a b c] => tuple2 a b --> c (* TYPECLASS *)
+  let t_ediv         = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_edivargs a b c] => tuple2 a b --> c (* TYPECLASS *)
+  let t_div          = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_divargs a b c] => tuple2 a b --> c (* TYPECLASS *)
+  let t_mod          = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_modargs a b c] => tuple2 a b --> c (* TYPECLASS *)
+  let t_add          = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_addargs a b c] => tuple2 a b --> c (* TYPECLASS *)
+  let t_set_mem      = forall "a" @@ fun a -> tuple2 a (set a) --> bool
+  let t_set_add      = forall "a" @@ fun a -> tuple2 a (set a) --> set a
+  let t_set_remove   = forall "a" @@ fun a -> tuple2 a (set a) --> set a
+  let t_not          = tuple1 bool --> bool
+
+  let t_continuation = forall "a" @@ fun a -> tuple2 bool a --> pair bool a
+  let t_fold_while   = forall "a" @@ fun a -> tuple2 (a --> pair bool a) a --> a
+  let t_neg          = tuple1 int --> int
+  let t_and          = tuple2 bool bool --> bool
+  let t_or           = tuple2 bool bool --> bool
+  let t_xor          = tuple2 bool bool --> bool
+  let t_lsl          = tuple2 nat nat --> nat
+  let t_lsr          = tuple2 nat nat --> nat
+  let t_comp         = forall_tc "a" @@ fun a -> [tc_comparable a] => tuple2 a a --> bool
+  let t_concat       = forall_tc "a" @@ fun a -> [tc_concatable a] => tuple2 a a --> a
+  let t_set_empty    = forall_tc "a" @@ fun a -> [tc_comparable a] => tuple0 --> set a
+  let t_set_iter     = forall_tc "a" @@ fun a -> [tc_comparable a] => tuple2 (a --> unit) (set a) --> unit
+  (* TODO: check that the implementation has this type *)
+  let t_set_fold     = forall2_tc "a" "b" @@ fun a b -> [tc_comparable b] => tuple3 (pair a b --> a) (set b) a --> a
+  let t_list_iter    = forall "a" @@ fun a -> tuple2 (a --> unit) (list a) --> unit
+  let t_list_map     = forall "a" @@ fun a -> tuple2 (a --> a) (list a) --> (list a)
+  (* TODO: check that the implementation has this type *)
+  let t_list_fold    = forall2 "a" "b" @@ fun a b -> tuple3 (pair a b --> a) (list b) a --> a
+  let t_self_address = tuple0 --> address
+  let t_implicit_account = forall_tc "a" @@ fun a -> [tc_storable a] => tuple1 key_hash --> contract a
+  let t_set_delegate = tuple1 (option key_hash) --> operation
+
+  let constant_type : constant' -> (Typesystem.Core.type_value, typer_error) result = function
+    | C_INT                 -> ok @@ t_int ;
+    | C_UNIT                -> ok @@ t_unit ;
+    | C_NOW                 -> ok @@ t_now ;
+    | C_IS_NAT              -> ok @@ t_is_nat ;
+    | C_SOME                -> ok @@ t_some ;
+    | C_NONE                -> ok @@ t_none ;
+    | C_ASSERTION           -> ok @@ t_assertion ;
+    | C_FAILWITH            -> ok @@ t_failwith ;
+    (* LOOPS *)
+    | C_FOLD_WHILE          -> ok @@ t_fold_while ;
+    | C_FOLD_CONTINUE       -> ok @@ t_continuation ;
+    | C_FOLD_STOP           -> ok @@ t_continuation ;
+    (* MATH *)
+    | C_NEG                 -> ok @@ t_neg ;
+    | C_ABS                 -> ok @@ t_abs ;
+    | C_ADD                 -> ok @@ t_add ;
+    | C_SUB                 -> ok @@ t_sub ;
+    | C_MUL                 -> ok @@ t_times ;
+    | C_EDIV                -> ok @@ t_ediv ;
+    | C_DIV                 -> ok @@ t_div ;
+    | C_MOD                 -> ok @@ t_mod ;
+    (* LOGIC *)
+    | C_NOT                 -> ok @@ t_not ;
+    | C_AND                 -> ok @@ t_and ;
+    | C_OR                  -> ok @@ t_or ;
+    | C_XOR                 -> ok @@ t_xor ;
+    | C_LSL                 -> ok @@ t_lsl ;
+    | C_LSR                 -> ok @@ t_lsr ;
+    (* COMPARATOR *)
+    | C_EQ                  -> ok @@ t_comp ;
+    | C_NEQ                 -> ok @@ t_comp ;
+    | C_LT                  -> ok @@ t_comp ;
+    | C_GT                  -> ok @@ t_comp ;
+    | C_LE                  -> ok @@ t_comp ;
+    | C_GE                  -> ok @@ t_comp ;
+    (* BYTES / STRING *)
+    | C_SIZE                -> ok @@ t_size ;
+    | C_CONCAT              -> ok @@ t_concat ;
+    | C_SLICE               -> ok @@ t_slice ;
+    | C_BYTES_PACK          -> ok @@ t_bytes_pack ;
+    | C_BYTES_UNPACK        -> ok @@ t_bytes_unpack ;
+    | C_CONS                -> ok @@ t_cons ;
+    (* SET  *)
+    | C_SET_EMPTY           -> ok @@ t_set_empty ;
+    | C_SET_ADD             -> ok @@ t_set_add ;
+    | C_SET_REMOVE          -> ok @@ t_set_remove ;
+    | C_SET_ITER            -> ok @@ t_set_iter ;
+    | C_SET_FOLD            -> ok @@ t_set_fold ;
+    | C_SET_MEM             -> ok @@ t_set_mem ;
+
+    (* LIST *)
+    | C_LIST_ITER           -> ok @@ t_list_iter ;
+    | C_LIST_MAP            -> ok @@ t_list_map ;
+    | C_LIST_FOLD           -> ok @@ t_list_fold ;
+
+    (* MAP *)
+    | C_MAP_ADD             -> ok @@ t_map_add ;
+    | C_MAP_REMOVE          -> ok @@ t_map_remove ;
+    | C_MAP_UPDATE          -> ok @@ t_map_update ;
+    | C_MAP_ITER            -> ok @@ t_map_iter ;
+    | C_MAP_MAP             -> ok @@ t_map_map ;
+    | C_MAP_FOLD            -> ok @@ t_map_fold ;
+    | C_MAP_MEM             -> ok @@ t_map_mem ;
+    | C_MAP_FIND            -> ok @@ t_map_find ;
+    | C_MAP_FIND_OPT        -> ok @@ t_map_find_opt ;
+    (* BIG MAP *)
+    (* CRYPTO *)
+    | C_SHA256              -> ok @@ t_hash256 ;
+    | C_SHA512              -> ok @@ t_hash512 ;
+    | C_BLAKE2b             -> ok @@ t_blake2b ;
+    | C_HASH_KEY            -> ok @@ t_hash_key ;
+    | C_CHECK_SIGNATURE     -> ok @@ t_check_signature ;
+    | C_CHAIN_ID            -> ok @@ t_chain_id ;
+    (*BLOCKCHAIN *)
+    | C_CONTRACT            -> ok @@ t_get_contract ;
+    | C_CONTRACT_ENTRYPOINT -> ok @@ failwith "t_get_entrypoint" ;
+    | C_AMOUNT              -> ok @@ t_amount ;
+    | C_BALANCE             -> ok @@ t_balance ;
+    | C_CALL                -> ok @@ t_transaction ;
+    | C_SENDER              -> ok @@ t_sender ;
+    | C_SOURCE              -> ok @@ t_source ;
+    | C_ADDRESS             -> ok @@ t_address ;
+    | C_SELF_ADDRESS        -> ok @@ t_self_address;
+    | C_IMPLICIT_ACCOUNT    -> ok @@ t_implicit_account;
+    | C_SET_DELEGATE        -> ok @@ t_set_delegate ;
+    | c                     -> fail (corner_case (Format.asprintf "Typer not implemented for constant %a" Ast_typed.PP.constant c))
+end
+

src/passes/08-typer-common/dune

@@ -0,0 +1,14 @@
+(library
+  (name typer_common)
+  (public_name ligo.typer_common)
+  (libraries
+    simple-utils
+    typesystem
+    ast_core
+    ast_typed
+  )
+  (preprocess
+    (pps ppx_let bisect_ppx --conditional)
+  )
+  (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
+)

src/passes/08-typer-common/helpers.ml

@@ -0,0 +1,89 @@
+open Errors
+open Ast_typed
+open Trace
+
+let assert_type_expression_eq ((tv',tv):type_expression * type_expression) : (unit,typer_error) result = 
+  trace_option (assert_equal tv' tv) @@
+    assert_type_expression_eq (tv' , tv)
+
+type typer = type_expression list -> type_expression option -> (type_expression, typer_error) result
+
+let typer_0 : string -> (type_expression option -> (type_expression, typer_error) result) -> typer = fun s f lst tv_opt ->
+  match lst with
+  | [] -> (
+    let%bind tv' = f tv_opt in
+    ok (tv')
+  )
+  | _ -> fail @@ wrong_param_number s 0 lst
+
+let typer_1 : string -> (type_expression -> (type_expression, typer_error) result) -> typer = fun s f lst _ ->
+  match lst with
+  | [ a ] -> (
+      let%bind tv' = f a in
+      ok (tv')
+    )
+  | _ -> fail @@ wrong_param_number s 1 lst
+
+let typer_1_opt : string -> (type_expression -> type_expression option -> (type_expression , typer_error) result) -> typer = fun s f lst tv_opt ->
+  match lst with
+  | [ a ] -> (
+      let%bind tv' = f a tv_opt in
+      ok (tv')
+    )
+  | _ -> fail @@ wrong_param_number s 1 lst
+
+let typer_2 : string -> (type_expression -> type_expression -> (type_expression, typer_error) result) -> typer = fun s f lst _ ->
+  match lst with
+  | [ a ; b ] -> (
+      let%bind tv' = f a b in
+      ok (tv')
+    )
+  | _ -> fail @@ wrong_param_number s 2 lst
+
+let typer_2_opt : string -> (type_expression -> type_expression -> type_expression option -> (type_expression, typer_error) result) -> typer = fun s f lst tv_opt ->
+  match lst with
+  | [ a ; b ] -> (
+      let%bind tv' = f a b tv_opt in
+      ok (tv')
+    )
+  | _ -> fail @@ wrong_param_number s 2 lst
+
+let typer_3 : string -> (type_expression -> type_expression -> type_expression -> (type_expression, typer_error) result) -> typer = fun s f lst _ ->
+  match lst with
+  | [ a ; b ; c ] -> (
+      let%bind tv' = f a b c in
+      ok (tv')
+    )
+  | _ -> fail @@ wrong_param_number s 3 lst
+
+let typer_4 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> (type_expression , typer_error) result) -> typer = fun s f lst _ ->
+  match lst with
+  | [ a ; b ; c ; d ] -> (
+      let%bind tv' = f a b c d in
+      ok (tv')
+    )
+  | _ -> fail @@ wrong_param_number s 4 lst
+
+let typer_5 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> (type_expression, typer_error) result) -> typer = fun s f lst _ ->
+  match lst with
+  | [ a ; b ; c ; d ; e ] -> (
+      let%bind tv' = f a b c d e in
+      ok (tv')
+    )
+  | _ -> fail @@ wrong_param_number s 5 lst
+
+let typer_6 : string
+  -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> (type_expression, typer_error) result) -> typer = fun s f lst _ ->
+  match lst with
+  | [ a ; b ; c ; d ; e ; f_ ] -> (
+      let%bind tv' = f a b c d e f_ in
+      ok (tv')
+    )
+  | _ -> fail @@ wrong_param_number s 6 lst
+
+let constant' name cst = typer_0 name (fun _ -> ok cst)
+let eq_1 a cst = type_expression_eq (a , cst)
+let eq_2 (a , b) cst = type_expression_eq (a , cst) && type_expression_eq (b , cst)
+
+let assert_eq_1 a b = if eq_1 a b then Some () else None
+let assert_eq a b = trace_option (not_matching a b) @@ assert_eq_1 a b

src/passes/08-typer-common/michelson_type_converter.ml

@@ -0,0 +1,179 @@
+open Errors
+open Ast_typed
+open Trace
+
+let record_checks kvl loc =
+  let%bind () = Assert.assert_true
+    (too_small_record loc)
+    (List.length kvl >=2) in
+  let all_undefined = List.for_all (fun (_,{field_decl_pos;_}) -> field_decl_pos = 0) kvl in
+  let%bind () = Assert.assert_true
+    (declaration_order_record loc)
+    (not all_undefined) in
+  ok ()
+
+let variant_checks kvl loc =
+  let%bind () = Assert.assert_true
+    (too_small_variant loc)
+    (List.length kvl >=2) in
+  let all_undefined = List.for_all (fun (_,{ctor_decl_pos;_}) -> ctor_decl_pos = 0) kvl in
+  let%bind () = Assert.assert_true
+    (declaration_order_variant loc)
+    (not all_undefined) in
+  ok ()
+
+let annotate_field (field:field_content) (ann:string) : field_content =
+  {field with michelson_annotation=Some ann}
+
+let annotate_ctor (ctor:ctor_content) (ann:string) : ctor_content =
+  {ctor with michelson_annotation=Some ann}
+
+let comb_pair (t:type_content) : field_content =
+  let field_type = {
+    type_content = t ;
+    type_meta = None ;
+    location = Location.generated ; } in
+  {field_type ; michelson_annotation = Some "" ; field_decl_pos = 0}
+
+let comb_ctor (t:type_content) : ctor_content =
+  let ctor_type = {
+    type_content = t ;
+    type_meta = None ;
+    location = Location.generated ; } in
+  {ctor_type ; michelson_annotation = Some "" ; ctor_decl_pos = 0}
+
+let rec to_right_comb_pair l new_map =
+  match l with
+  | [] -> new_map
+  | [ (Label ann_l, field_content_l) ; (Label ann_r, field_content_r) ] ->
+    LMap.add_bindings [
+      (Label "0" , annotate_field field_content_l ann_l) ;
+      (Label "1" , annotate_field field_content_r ann_r) ] new_map
+  | (Label ann, field)::tl ->
+    let new_map' = LMap.add (Label "0") (annotate_field field ann) new_map in
+    LMap.add (Label "1") (comb_pair (T_record (to_right_comb_pair tl new_map'))) new_map'
+
+let rec to_right_comb_variant l new_map =
+  match l with
+  | [] -> new_map
+  | [ (Constructor ann_l, field_content_l) ; (Constructor ann_r, field_content_r) ] ->
+    CMap.add_bindings [
+      (Constructor "M_left" , annotate_ctor field_content_l ann_l) ;
+      (Constructor "M_right" , annotate_ctor field_content_r ann_r) ] new_map
+  | (Constructor ann, field)::tl ->
+    let new_map' = CMap.add (Constructor "M_left") (annotate_ctor field ann) new_map in
+    CMap.add (Constructor "M_right") (comb_ctor (T_sum (to_right_comb_variant tl new_map'))) new_map'
+
+let rec to_left_comb_pair' first l new_map =
+  match l with
+  | [] -> new_map
+  | (Label ann_l, field_content_l) :: (Label ann_r, field_content_r) ::tl when first ->
+    let new_map' = LMap.add_bindings [
+      (Label "0" , annotate_field field_content_l ann_l) ;
+      (Label "1" , annotate_field field_content_r ann_r) ] LMap.empty in
+    to_left_comb_pair' false tl new_map'
+  | (Label ann, field)::tl ->
+    let new_map' = LMap.add_bindings [
+      (Label "0" , comb_pair (T_record new_map)) ;
+      (Label "1" , annotate_field field ann ) ;] LMap.empty in
+    to_left_comb_pair' first tl new_map'
+let to_left_comb_pair = to_left_comb_pair' true
+
+let rec to_left_comb_variant' first l new_map =
+  match l with
+  | [] -> new_map
+  | (Constructor ann_l, ctor_content_l) :: (Constructor ann_r, ctor_content_r) ::tl when first ->
+    let new_map' = CMap.add_bindings [
+      (Constructor "M_left" , annotate_ctor ctor_content_l ann_l) ;
+      (Constructor "M_right" , annotate_ctor ctor_content_r ann_r) ] CMap.empty in
+    to_left_comb_variant' false tl new_map'
+  | (Constructor ann, ctor)::tl ->
+    let new_map' = CMap.add_bindings [
+      (Constructor "M_left" , comb_ctor (T_sum new_map)) ;
+      (Constructor "M_right" , annotate_ctor ctor ann ) ;] CMap.empty in
+    to_left_comb_variant' first tl new_map'
+let to_left_comb_variant = to_left_comb_variant' true
+
+let rec from_right_comb_pair (l:field_content label_map) (size:int) : (field_content list , typer_error) result =
+  let l' = List.rev @@ LMap.to_kv_list l in
+  match l' , size with
+  | [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
+  | [ (_,l) ; (_,{field_type=tr;_}) ], _ ->
+    let%bind comb_lmap = trace_option (expected_record tr) @@ get_t_record tr in
+    let%bind next = from_right_comb_pair comb_lmap (size-1) in
+    ok (l :: next)
+  | _ -> fail (corner_case "Could not convert michelson_pair_right_comb pair to a record")
+
+let rec from_left_comb_pair (l:field_content label_map) (size:int) : (field_content list , typer_error) result =
+  let l' = List.rev @@ LMap.to_kv_list l in
+  match l' , size with
+  | [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
+  | [ (_,{field_type=tl;_}) ; (_,r) ], _ ->
+    let%bind comb_lmap = trace_option (expected_record tl) @@ get_t_record tl in
+    let%bind next = from_left_comb_pair comb_lmap (size-1) in
+    ok (List.append next [r])
+  | _ -> fail (corner_case "Could not convert michelson_pair_left_comb pair to a record")
+
+let rec from_right_comb_variant (l:ctor_content constructor_map) (size:int) : (ctor_content list , typer_error) result =
+  let l' = List.rev @@ CMap.to_kv_list l in
+  match l' , size with
+  | [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
+  | [ (_,l) ; (_,{ctor_type=tr;_}) ], _ ->
+    let%bind comb_cmap = trace_option (expected_variant tr) @@ get_t_sum tr in
+    let%bind next = from_right_comb_variant comb_cmap (size-1) in
+    ok (l :: next)
+  | _ -> fail (corner_case "Could not convert michelson_or right comb to a variant")
+
+let rec from_left_comb_variant (l:ctor_content constructor_map) (size:int) : (ctor_content list , typer_error) result =
+  let l' = List.rev @@ CMap.to_kv_list l in
+  match l' , size with
+  | [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
+  | [ (_,{ctor_type=tl;_}) ; (_,r) ], _ ->
+    let%bind comb_cmap = trace_option (expected_variant tl) @@ get_t_sum tl in
+    let%bind next = from_left_comb_variant comb_cmap (size-1) in
+    ok (List.append next [r])
+  | _ -> fail (corner_case "Could not convert michelson_or left comb to a record")
+
+let convert_pair_to_right_comb l =
+  let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in
+  T_record (to_right_comb_pair l' LMap.empty)
+
+let convert_pair_to_left_comb l =
+  let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in
+  T_record (to_left_comb_pair l' LMap.empty)
+
+let convert_pair_from_right_comb (src: field_content label_map) (dst: field_content label_map) : (type_content , typer_error) result =
+  let%bind fields = from_right_comb_pair src (LMap.cardinal dst) in
+  let labels = List.map (fun (l,_) -> l) @@
+    List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b ) @@
+    LMap.to_kv_list dst in
+  ok @@ (T_record (LMap.of_list @@ List.combine labels fields))
+
+let convert_pair_from_left_comb (src: field_content label_map) (dst: field_content label_map) : (type_content , typer_error) result =
+  let%bind fields = from_left_comb_pair src (LMap.cardinal dst) in
+  let labels = List.map (fun (l,_) -> l) @@
+    List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b ) @@
+    LMap.to_kv_list dst in
+  ok @@ (T_record (LMap.of_list @@ List.combine labels fields))
+
+let convert_variant_to_right_comb l =
+  let l' = List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b) l in
+  T_sum (to_right_comb_variant l' CMap.empty)
+
+let convert_variant_to_left_comb l =
+  let l' = List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b) l in
+  T_sum (to_left_comb_variant l' CMap.empty)
+
+let convert_variant_from_right_comb (src: ctor_content constructor_map) (dst: ctor_content constructor_map) : (type_content , typer_error) result =
+  let%bind ctors = from_right_comb_variant src (CMap.cardinal dst) in
+  let ctors_name = List.map (fun (l,_) -> l) @@
+    List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b ) @@
+    CMap.to_kv_list dst in
+  ok @@ (T_sum (CMap.of_list @@ List.combine ctors_name ctors))
+
+let convert_variant_from_left_comb (src: ctor_content constructor_map) (dst: ctor_content constructor_map) : (type_content , typer_error) result =
+  let%bind ctors = from_left_comb_variant src (CMap.cardinal dst) in
+  let ctors_name = List.map (fun (l,_) -> l) @@
+    List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b ) @@
+    CMap.to_kv_list dst in
+  ok @@ (T_sum (CMap.of_list @@ List.combine ctors_name ctors))

src/passes/08-typer-common/typer_common.ml

@@ -0,0 +1,5 @@
+module Errors = Errors
+module Michelson_type_converter = Michelson_type_converter
+module Constant_typers = Constant_typers
+module Constant_typers_new = Constant_typers_new
+module Helpers = Helpers

src/passes/08-typer-new/dune

@@ -9,6 +9,7 @@
     operators
     UnionFind
     environment
+    typer_common
   )
   (preprocess
     (pps ppx_let)

src/passes/08-typer-new/errors.ml

@@ -1,157 +0,0 @@
-open Trace
-module I = Ast_core
-module O = Ast_typed
-module Environment = O.Environment
-type environment = Environment.t
-
-let unbound_type_variable (e:environment) (tv:I.type_variable) (loc:Location.t) () =
-  let title = (thunk "unbound type variable") in
-  let message () = "" in
-  let data = [
-      ("variable" , fun () -> Format.asprintf "%a" I.PP.type_variable tv) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-      ("in" , fun () -> Format.asprintf "%a" Environment.PP.environment e)
-    ] in
-  error ~data title message ()
-
-let unbound_variable (e:environment) (n:I.expression_variable) (loc:Location.t) () =
-  let name () = Format.asprintf "%a" I.PP.expression_variable n in
-  let title = (thunk ("unbound variable "^(name ()))) in
-  let message () = "" in
-  let data = [
-      ("variable" , name) ;
-      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-  error ~data title message ()
-
-let match_empty_variant : I.matching_expr -> 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 : I.matching_expr -> 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 : I.matching_expr -> Location.t -> unit -> _ =
-  fun matching loc () ->
-  let title = (thunk "redundant 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) (c:I.constructor') (loc:Location.t) () =
-  let title = (thunk "unbound constructor") in
-  let message () = "" in
-  let data = [
-      ("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c) ;
-      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-  error ~data title message ()
-
-let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
-  let title () = "wrong arity" in
-  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 data = [
-      ("program" , fun () -> Format.asprintf "%a" I.PP.program p)
-    ] in
-  error ~data title message ()
-
-let constant_declaration_error (name: I.expression_variable) (ae:I.expr) (expected: O.type_expression option) () =
-  let title = (thunk "typing constant declaration") in
-  let message () = "" in
-  let data = [
-      ("constant" , fun () -> Format.asprintf "%a" I.PP.expression_variable name) ; (* Todo : remove Stage_common*)
-      ("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_expression expected) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
-    ] in
-  error ~data title message ()
-
-let match_error : ?msg:string -> expected: I.matching_expr -> actual: O.type_expression -> 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_expression 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 : I.expression) (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" I.PP.expression expression) ;
- *     ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
- *   ] in
- *   error ~data title message () *)
-
-let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
-  let title = (thunk "type error") in
-  let message () = msg in
-  let data = [
-      ("expected"   , fun () -> Format.asprintf "%a" O.PP.type_expression expected);
-      ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
-      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-  error ~data title message ()
-
-let bad_type_operator type_op =
-  let title () = Format.asprintf "bad type operator %a" I.PP.type_expression type_op in
-  let message () = "" in
-  error title message

src/passes/08-typer-new/solver.ml

@@ -67,7 +67,7 @@ let select_and_propagate_all' : ex_propagator_state list -> type_constraint_simp
 
 (* Takes a list of constraints, applies all selector+propagator pairs
    to each in turn. *)
-let rec select_and_propagate_all : typer_state -> type_constraint selector_input list -> typer_state result =
+let rec select_and_propagate_all : typer_state -> type_constraint selector_input list -> (typer_state,_) result =
   fun { already_selected_and_propagators ; structured_dbs } new_constraints ->
   match new_constraints with
   | [] -> ok { already_selected_and_propagators ; structured_dbs }

src/passes/08-typer-new/typer.ml

@@ -7,16 +7,20 @@ module DEnv = Environment
 module Environment = O.Environment
 module Solver = Solver
 type environment = Environment.t
-module Errors = Errors
+module Errors = Typer_common.Errors
 open Errors
 module Map = RedBlackTrees.PolyMap
 
 open Todo_use_fold_generator
 
+let assert_type_expression_eq ((tv',tv):O.type_expression * O.type_expression) : (unit,typer_error) result = 
+  trace_option (assert_equal tv' tv) @@
+    O.assert_type_expression_eq (tv' , tv)
+
 (*
   Extract pairs of (name,type) in the declaration and add it to the environment
 *)
-let rec type_declaration env state : I.declaration -> (environment * O'.typer_state * O.declaration option) result = function
+let rec type_declaration env state : I.declaration -> (environment * O'.typer_state * O.declaration option, typer_error) result = function
   | Declaration_type (type_name , type_expression) ->
     let%bind tv = evaluate_type env type_expression in
     let env' = Environment.add_type (type_name) tv env in
@@ -27,17 +31,17 @@ let rec type_declaration env state : I.declaration -> (environment * O'.typer_st
     *)
       let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
       let%bind (expr , state') =
-        trace (constant_declaration_error binder expression tv'_opt) @@
+        trace (constant_declaration_tracer binder expression tv'_opt) @@
         type_expression env state expression in
       let post_env = Environment.add_ez_declaration binder expr env in
       ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline} ))
     )
 
-and type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state) result =
+and type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state, typer_error) result =
-  fun e state t i ae loc -> match i with
+  fun e state t i _ae loc -> match i with
     | Match_option {match_none ; match_some} ->
       let%bind tv =
-        trace_strong (match_error ~expected:i ~actual:t loc)
+        trace_option (match_error ~expected:i ~actual:t loc)
         @@ get_t_option t in
       let%bind (match_none , state') = type_expression e state match_none in
       let (opt, b) = match_some in
@@ -46,7 +50,7 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
       ok (O.Match_option {match_none ; match_some = { opt; body; tv}} , state'')
     | Match_list {match_nil ; match_cons} ->
       let%bind t_elt =
-        trace_strong (match_error ~expected:i ~actual:t loc)
+        trace_option (match_error ~expected:i ~actual:t loc)
         @@ get_t_list t in
       let%bind (match_nil , state') = type_expression e state match_nil in
       let (hd, tl, b) = match_cons in
@@ -62,38 +66,31 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
             Environment.get_constructor constructor_name e in
           let%bind acc = match acc with
             | None -> ok (Some variant)
-            | Some variant' -> (
+            | Some variant' ->
-                trace (type_error
+                let%bind () = trace_option (not_matching variant variant') @@
-                         ~msg:"in match variant"
+                  Ast_typed.assert_type_expression_eq (variant , variant') in
-                         ~expected:variant
-                         ~actual:variant'
-                         ~expression:ae
-                         loc
-                      ) @@
-                Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () ->
                 ok (Some variant)
-              ) in
+            in
           ok acc in
-        trace (simple_info "in match variant") @@
+        trace (in_match_variant_tracer i) @@
         bind_fold_list aux None lst in
       let%bind variant =
         trace_option (match_empty_variant i loc) @@
         variant_opt in
       let%bind () =
         let%bind variant_cases' =
-          trace (match_error ~expected:i ~actual:t loc)
+          trace_option (match_error ~expected:i ~actual:t loc)
           @@ Ast_typed.Combinators.get_t_sum variant in
         let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' in
         let match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
         let test_case = fun c ->
-          Assert.assert_true (List.mem c match_cases)
+          Assert.assert_true (corner_case "match case") (List.mem c match_cases)
         in
         let%bind () =
           trace_strong (match_missing_case i loc) @@
           bind_iter_list test_case variant_cases in
-        let%bind () =
+        let%bind () = Assert.assert_true (match_redundant_case i loc) @@
-          trace_strong (match_redundant_case i loc) @@
+          List.(length variant_cases = length match_cases) in
-          Assert.assert_true List.(length variant_cases = length match_cases) in
         ok ()
       in
       let%bind (state'' , cases) =
@@ -113,7 +110,7 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
   Recursively search the type_expression and return a result containing the
   type_value at the leaves
 *)
-and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
+and evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result =
   let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in
   match t.type_content with
   | T_arrow {type1;type2} ->
@@ -146,40 +143,63 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
   | T_constant cst ->
       return (T_constant (convert_type_constant cst))
   | T_operator (op, lst) ->
-      let%bind opt = match op,lst with
+      ( match op,lst with
         | TC_set, [s] ->
             let%bind s = evaluate_type e s in
-            ok @@ O.TC_set (s)
+            return @@ T_operator (O.TC_set s)
         | TC_option, [o] ->
             let%bind o = evaluate_type e o in
-            ok @@ O.TC_option (o)
+            return @@ T_operator  (O.TC_option o)
         | TC_list, [l] ->
             let%bind l = evaluate_type e l in
-            ok @@ O.TC_list (l)
+            return @@ T_operator  (O.TC_list l)
         | TC_map, [k;v] ->
             let%bind k = evaluate_type e k in
             let%bind v = evaluate_type e v in
-            ok @@ O.TC_map {k;v}
+            return @@ T_operator (O.TC_map {k;v})
         | TC_big_map, [k;v] ->
             let%bind k = evaluate_type e k in
             let%bind v = evaluate_type e v in
-            ok @@ O.TC_big_map {k;v}
+            return @@ T_operator (O.TC_big_map {k;v})
         | TC_map_or_big_map, [k;v] ->
             let%bind k = evaluate_type e k in
             let%bind v = evaluate_type e v in
-            ok @@ O.TC_map_or_big_map {k;v}
+            return @@ T_operator (O.TC_map_or_big_map {k;v})
         | TC_contract, [c] ->
             let%bind c = evaluate_type e c in
-            ok @@ O.TC_contract c
+            return @@ T_operator (O.TC_contract c)
-        | TC_michelson_pair_right_comb, _c | TC_michelson_pair_left_comb, _c 
+        | TC_michelson_pair_right_comb, [c] ->
-        | TC_michelson_or_right_comb, _c | TC_michelson_or_left_comb, _c ->
+            let%bind c' = evaluate_type e c in
-          (* not really sure what to do in the new typer, should be converted to a pair using functions defined in Helpers.Typer.Converter *)
+            let%bind lmap = match c'.type_content with
-          simple_fail "to be implemented"
+              | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
-        | _ -> fail @@ bad_type_operator t
+              | _ -> fail (michelson_comb_no_record t.location) in
-        in
+            let record = Typer_common.Michelson_type_converter.convert_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
-      return (T_operator (opt))
+            return @@ record
+        | TC_michelson_pair_left_comb, [c] ->
+            let%bind c' = evaluate_type e c in
+            let%bind lmap = match c'.type_content with
+              | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
+              | _ -> fail (michelson_comb_no_record t.location) in
+            let record = Typer_common.Michelson_type_converter.convert_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
+            return @@ record
+        | TC_michelson_or_right_comb, [c] ->
+            let%bind c' = evaluate_type e c in
+            let%bind cmap = match c'.type_content with
+              | T_sum cmap -> ok cmap
+              | _ -> fail (michelson_comb_no_variant t.location) in
+            let pair = Typer_common.Michelson_type_converter.convert_variant_to_right_comb (Ast_typed.CMap.to_kv_list cmap) in
+            return @@ pair
+        | TC_michelson_or_left_comb, [c] ->
+            let%bind c' = evaluate_type e c in
+            let%bind cmap = match c'.type_content with
+              | T_sum cmap -> ok cmap
+              | _ -> fail (michelson_comb_no_variant t.location) in
+            let pair = Typer_common.Michelson_type_converter.convert_variant_to_left_comb (Ast_typed.CMap.to_kv_list cmap) in
+            return @@ pair
+        | _ -> fail @@ unrecognized_type_op t
+      )
 
-and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result = fun e state ?tv_opt ae ->
+and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result = fun e state ?tv_opt ae ->
   let () = ignore tv_opt in     (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *)
   let open Solver in
   let module L = Logger.Stateful() in
@@ -190,16 +210,7 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
     let expr' = make_e ~location expr tv in
     ok @@ (expr' , new_state) in
   let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in
-  let main_error =
+  trace (expression_tracer ae) @@
-    let title () = "typing expression" in
-    let content () = "" in
-    let data = [
-      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp @@ ae.location) ;
-      ("misc" , fun () -> L.get ()) ;
-    ] in
-    error ~data title content in
-  trace main_error @@
   match ae.expression_content with
 
   (* TODO: this file should take care only of the order in which program fragments
@@ -271,19 +282,10 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
 
   (* Sum *)
   | E_constructor {constructor;element} ->
-    let%bind (c_tv, sum_tv) =
+    let%bind (c_tv, sum_tv) = trace_option (unbound_constructor e constructor ae.location) @@
-      let error =
-        let title () = "no such constructor" in
-        let content () =
-          Format.asprintf "%a in:\n%a\n"
-            Stage_common.PP.constructor constructor
-            O.Environment.PP.environment e
-        in
-        error title content in
-      trace_option error @@
       Environment.get_constructor constructor e in
     let%bind (expr' , state') = type_expression e state element in
-    let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
+    let%bind _assert = assert_type_expression_eq (expr'.type_expression, c_tv) in
     let wrapped = Wrap.constructor expr'.type_expression c_tv sum_tv in
     let constructor = convert_constructor' constructor in
     return_wrapped (E_constructor {constructor; element=expr'}) state' wrapped
@@ -312,7 +314,7 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
       )
       | _ -> failwith "Update an expression which is not a record"
     in
-    let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
+    let%bind () = assert_type_expression_eq (tv, get_type_expression update) in
     return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
   (* Data-structure *)
   | E_application {lamb;args} ->
@@ -381,7 +383,7 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
 
   | E_constant {cons_name=name; arguments=lst} ->
     let name = convert_constant' name in
-    let%bind t = Operators.Typer.Operators_types.constant_type name in
+    let%bind t = Typer_common.Constant_typers_new.Operators_types.constant_type name in
     let aux acc expr =
       let (lst , state) = acc in
       let%bind (expr, state') = type_expression e state expr in
@@ -416,14 +418,14 @@ and type_lambda e state {
       let wrapped = Wrap.lambda fresh input_type' output_type' result.type_expression in
       ok (({binder;result}:O.lambda),state',wrapped)
 
-and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
+and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression, Typer_common.Errors.typer_error) result =
   let name = convert_constant' name in
-  let%bind typer = Operators.Typer.constant_typers name in
+  let%bind typer = Typer_common.Constant_typers.constant_typers name in
   let%bind tv = typer lst tv_opt in
   ok(name, tv)
 
 (* Apply type_declaration on every node of the AST_core from the root p *)
-let type_program_returns_state ((env, state, p) : environment * O'.typer_state * I.program) : (environment * O'.typer_state * O.program) result =
+let type_program_returns_state ((env, state, p) : environment * O'.typer_state * I.program) : (environment * O'.typer_state * O.program, Typer_common.Errors.typer_error) result =
   let aux ((e : environment), (s : O'.typer_state) , (ds : O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
     let%bind (e' , s' , d'_opt) = type_declaration e s (Location.unwrap d) in
     let ds' = match d'_opt with
@@ -433,12 +435,14 @@ let type_program_returns_state ((env, state, p) : environment * O'.typer_state *
     ok (e' , s' , ds')
   in
   let%bind (env' , state' , declarations) =
-    trace (fun () -> program_error p ()) @@
+    trace (program_error_tracer p) @@
     bind_fold_list aux (env , state , []) p in
   let declarations = List.rev declarations in (* Common hack to have O(1) append: prepend and then reverse *)
   ok (env', state', declarations)
 
-let type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (apply_substs : 'b Typesystem.Misc.Substitution.Pattern.w) (type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b) Trace.result) : ('b * O'.typer_state) result =
+let type_and_subst_xyz
+  (env_state_node : environment * O'.typer_state * 'a) (apply_substs : ('b, Typer_common.Errors.typer_error) Typesystem.Misc.Substitution.Pattern.w)
+  (type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b, typer_error) Trace.result) : ('b * O'.typer_state, typer_error) result =
   let%bind (env, state, node) = type_xyz_returns_state env_state_node in
   let subst_all =
     let aliases = state.structured_dbs.aliases in
@@ -446,15 +450,16 @@ let type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (app
     let substs : variable: I.type_variable -> _ = fun ~variable ->
       to_option @@
       let%bind root =
-        trace_option (simple_error (Format.asprintf "can't find alias root of variable %a" Var.pp variable)) @@
+        trace_option (corner_case (Format.asprintf "can't find alias root of variable %a" Var.pp variable)) @@
           (* TODO: after upgrading UnionFind, this will be an option, not an exception. *)
           try Some (Solver.UF.repr variable aliases) with Not_found -> None in
       let%bind assignment =
-        trace_option (simple_error (Format.asprintf "can't find assignment for root %a" Var.pp root)) @@
+        trace_option (corner_case (Format.asprintf "can't find assignment for root %a" Var.pp root)) @@
           (Map.find_opt root assignments) in
       let O.{ tv ; c_tag ; tv_list } = assignment in
       let () = ignore tv (* I think there is an issue where the tv is stored twice (as a key and in the element itself) *) in
-      let%bind (expr : O.type_content) = Typesystem.Core.type_expression'_of_simple_c_constant (c_tag , (List.map (fun s -> O.t_variable s ()) tv_list)) in
+      let%bind (expr : O.type_content) = trace_option (corner_case "wrong constant tag") @@
+        Typesystem.Core.type_expression'_of_simple_c_constant (c_tag , (List.map (fun s -> O.t_variable s ()) tv_list)) in
       ok @@ expr
     in
     let p = apply_substs ~substs node in
@@ -463,17 +468,17 @@ let type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (app
   let () = ignore env in        (* TODO: shouldn't we use the `env` somewhere? *)
   ok (node, state)
 
-let type_program (p : I.program) : (O.program * O'.typer_state) result =
+let type_program (p : I.program) : (O.program * O'.typer_state, typer_error) result =
   let empty_env = DEnv.default in
   let empty_state = Solver.initial_state in
   type_and_subst_xyz (empty_env , empty_state , p) Typesystem.Misc.Substitution.Pattern.s_program type_program_returns_state
 
-let type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression) Trace.result =
+let type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression, typer_error) result =
   fun (env, state, e) ->
   let%bind (e , state) = type_expression env state e in
   ok (env, state, e)
 
-let type_expression_subst (env : environment) (state : O'.typer_state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * O'.typer_state) result =
+let type_expression_subst (env : environment) (state : O'.typer_state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * O'.typer_state , typer_error) result =
   let () = ignore tv_opt in     (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *)
   type_and_subst_xyz (env , state , e) Typesystem.Misc.Substitution.Pattern.s_expression type_expression_returns_state
 
@@ -481,14 +486,14 @@ let untype_type_expression  = Untyper.untype_type_expression
 let untype_expression       = Untyper.untype_expression
 
 (* These aliases are just here for quick navigation during debug, and can safely be removed later *)
-let [@warning "-32"] (*rec*) type_declaration _env _state : I.declaration -> (environment * O'.typer_state * O.declaration option) result = type_declaration _env _state
+let [@warning "-32"] (*rec*) type_declaration _env _state : I.declaration -> (environment * O'.typer_state * O.declaration option, typer_error) result = type_declaration _env _state
-and [@warning "-32"] type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state) result = type_match
+and [@warning "-32"] type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state, typer_error) result = type_match
-and [@warning "-32"] evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result = evaluate_type e t
+and [@warning "-32"] evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result = evaluate_type e t
-and [@warning "-32"] type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result = type_expression
+and [@warning "-32"] type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result = type_expression
 and [@warning "-32"] type_lambda e state lam = type_lambda e state lam
-and [@warning "-32"] type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result = type_constant name lst tv_opt
+and [@warning "-32"] type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression, typer_error) result = type_constant name lst tv_opt
-let [@warning "-32"] type_program_returns_state ((env, state, p) : environment * O'.typer_state * I.program) : (environment * O'.typer_state * O.program) result = type_program_returns_state (env, state, p)
+let [@warning "-32"] type_program_returns_state ((env, state, p) : environment * O'.typer_state * I.program) : (environment * O'.typer_state * O.program, typer_error) result = type_program_returns_state (env, state, p)
-let [@warning "-32"] type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (apply_substs : 'b Typesystem.Misc.Substitution.Pattern.w) (type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b) Trace.result) : ('b * O'.typer_state) result = type_and_subst_xyz env_state_node apply_substs type_xyz_returns_state
+let [@warning "-32"] type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (apply_substs : ('b,typer_error) Typesystem.Misc.Substitution.Pattern.w) (type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b, typer_error) result) : ('b * O'.typer_state, typer_error) result = type_and_subst_xyz env_state_node apply_substs type_xyz_returns_state
-let [@warning "-32"] type_program (p : I.program) : (O.program * O'.typer_state) result = type_program p
+let [@warning "-32"] type_program (p : I.program) : (O.program * O'.typer_state, typer_error) result = type_program p
-let [@warning "-32"] type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression) Trace.result = type_expression_returns_state
+let [@warning "-32"] type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression, typer_error) Trace.result = type_expression_returns_state
-let [@warning "-32"] type_expression_subst (env : environment) (state : O'.typer_state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * O'.typer_state) result = type_expression_subst env state ?tv_opt e
+let [@warning "-32"] type_expression_subst (env : environment) (state : O'.typer_state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * O'.typer_state, typer_error) result = type_expression_subst env state ?tv_opt e

src/passes/08-typer-new/typer.mli

@@ -1,5 +1,7 @@
 open Trace
 
+open Typer_common.Errors
+module Errors = Typer_common.Errors
 module I = Ast_core
 module O = Ast_typed
 module O' = Typesystem.Solver_types
@@ -10,41 +12,12 @@ module Solver = Solver
 
 type environment = Environment.t
 
-module Errors : sig
+val type_program : I.program -> (O.program * O'.typer_state, typer_error) result
-  (*
+val type_declaration : environment -> O'.typer_state -> I.declaration -> (environment * O'.typer_state * O.declaration option, typer_error) result
-  val unbound_type_variable : environment -> string -> unit -> error
+val evaluate_type : environment -> I.type_expression -> (O.type_expression, typer_error) result
-  val unbound_variable : environment -> string -> Location.t -> unit -> error
+val type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result
-  val match_empty_variant : 'a I.matching -> Location.t -> unit -> error
+val type_expression_subst : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result
-  val match_missing_case : 'a I.matching -> Location.t -> unit -> error
+val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression, typer_error) result
-  val match_redundant_case : 'a I.matching -> Location.t -> unit -> error
-  val unbound_constructor : environment -> string -> Location.t -> unit -> error
-  val unrecognized_constant : string -> Location.t -> unit -> error
-  *)
-  val wrong_arity : string -> int -> int -> Location.t -> unit -> error
-  (*
-  val match_tuple_wrong_arity : 'a list -> 'b list -> Location.t -> unit -> error
 
-  (* TODO: this should be a trace_info? *)
+val untype_type_expression : O.type_expression -> (I.type_expression, typer_error) result
-  val program_error : I.program -> unit -> error
+val untype_expression : O.expression -> (I.expression, typer_error) result
-  val constant_declaration_error : string -> I.expr -> O.type_value option -> unit -> error
-  val match_error : ?msg:string -> expected:'a I.matching -> actual:O.type_value -> Location.t -> unit -> error
-  val needs_annotation : I.expression -> string -> unit -> error
-  val type_error_approximate : ?msg:string -> expected:string -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error
-  val type_error : ?msg:string -> expected:O.type_value -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error
-  val bad_tuple_index : int -> I.expression -> O.type_value -> Location.t -> unit -> error
-  val bad_record_access : string -> I.expression -> O.type_value -> Location.t -> unit -> error
-  val not_supported_yet : string -> I.expression -> unit -> error
-  val not_supported_yet_untranspile : string -> O.expression -> unit -> error
-  val constant_error : Location.t -> O.type_value list -> O.type_value option -> unit -> error
-  *)
-end
-
-val type_program : I.program -> (O.program * O'.typer_state) result
-val type_declaration : environment -> O'.typer_state -> I.declaration -> (environment * O'.typer_state * O.declaration option) result
-val evaluate_type : environment -> I.type_expression -> O.type_expression result
-val type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result
-val type_expression_subst : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result
-val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression) result
-
-val untype_type_expression : O.type_expression -> I.type_expression result
-val untype_expression : O.expression -> I.expression result

src/passes/08-typer-new/untyper.ml

@@ -1,4 +1,5 @@
 open Trace
+open Typer_common.Errors
 
 module I = Ast_core
 module O = Ast_typed
@@ -140,15 +141,15 @@ let unconvert_constant' : O.constant' -> I.constant' = function
   | C_CONVERT_FROM_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB
   | C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_COMB
 
-let untype_type_value (t:O.type_expression) : (I.type_expression) result =
+let untype_type_value (t:O.type_expression) : (I.type_expression, typer_error) result =
   match t.type_meta with
   | Some s -> ok s
-  | _ -> fail @@ internal_assertion_failure "trying to untype generated type"
+  | _ -> fail @@ corner_case "trying to untype generated type"
 
 (*
   Tranform a Ast_typed type_expression into an ast_core type_expression
 *)
-let rec untype_type_expression (t:O.type_expression) : (I.type_expression) result =
+let rec untype_type_expression (t:O.type_expression) : (I.type_expression, typer_error) result =
   (* TODO: or should we use t.core if present? *)
   let%bind t = match t.type_content with
   | O.T_sum x ->
@@ -213,7 +214,7 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
 (*
   Tranform a Ast_typed literal into an ast_core literal
 *)
-let untype_literal (l:O.literal) : I.literal result =
+let untype_literal (l:O.literal) : (I.literal, typer_error) result =
   let open I in
   match l with
   | Literal_unit -> ok Literal_unit
@@ -234,7 +235,7 @@ let untype_literal (l:O.literal) : I.literal result =
 (*
   Tranform a Ast_typed expression into an ast_core matching
 *)
-let rec untype_expression (e:O.expression) : (I.expression) result =
+let rec untype_expression (e:O.expression) : (I.expression, typer_error) result =
   let open I in
   let return e = ok e in
   match e.expression_content with
@@ -290,8 +291,8 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
       let%bind fun_type = untype_type_expression fun_type in
       return @@ e_recursive fun_name fun_type lambda
 
-and untype_lambda ty {binder; result} : I.lambda result =
+and untype_lambda ty {binder; result} : (I.lambda, typer_error) result =
-      let%bind io = get_t_function ty in
+      let%bind io = trace_option (corner_case "TODO") @@ get_t_function ty in
       let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
       let%bind result = untype_expression result in
       ok ({binder;input_type = Some input_type; output_type = Some output_type; result}: I.lambda)
@@ -299,7 +300,7 @@ and untype_lambda ty {binder; result} : I.lambda result =
 (*
   Tranform a Ast_typed matching into an ast_core matching
 *)
-and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
+and untype_matching : (O.expression -> (I.expression, typer_error) result) -> O.matching_expr -> (I.matching_expr, typer_error) result = fun f m ->
   let open I in
   match m with
   | Match_option {match_none ; match_some = {opt; body;tv=_}} ->

src/passes/08-typer-new/wrap.ml

@@ -1,4 +1,3 @@
-open Trace
 open Ast_typed.Misc
 module Core = Typesystem.Core
 
@@ -6,21 +5,6 @@ module I = Ast_core
 module T = Ast_typed
 module O = Core
 
-module Errors = struct
-
-  let unknown_type_constructor (ctor : string) (te : T.type_expression) () =
-    let title = (thunk "unknown type constructor") in
-    (* TODO: sanitize the "ctor" argument before displaying it. *)
-    let message () = ctor in
-    let data = [
-        ("ctor" , fun () -> ctor) ;
-        ("expression" , fun () -> Format.asprintf "%a"  T.PP.type_expression te) ;
-        (* ("location" , fun () -> Format.asprintf "%a" Location.pp te.location) *) (* TODO *)
-      ] in
-    error ~data title message ()
-end
-
-
 type constraints = O.type_constraint list
 
 (* let add_type state t = *)

src/passes/08-typer-old/dune

@@ -2,6 +2,7 @@
   (name typer_old)
   (public_name ligo.typer_old)
   (libraries
+    typer_common
     simple-utils
     tezos-utils
     ast_core

src/passes/08-typer-old/typer.ml

@@ -1,4 +1,5 @@
 open Trace
+open Typer_common.Errors
 
 module I = Ast_core
 module O = Ast_typed
@@ -12,220 +13,7 @@ module Solver = Typer_new.Solver
 
 type environment = Environment.t
 
-module Errors = struct
+let assert_type_expression_eq = Typer_common.Helpers.assert_type_expression_eq
-  let michelson_comb_no_record (loc:Location.t) () =
-    let title = (thunk "bad michelson_pair_right_comb type parameter") in
-    let message () = "michelson_pair_right_comb type operator must be used on a record type" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-    ] in
-    error ~data title message ()
-
-  let michelson_comb_no_variant (loc:Location.t) () =
-    let title = (thunk "bad michelson_or_right_comb type parameter") in
-    let message () = "michelson_or_right_comb type operator must be used on a variant type" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-    ] in
-    error ~data title message ()
-
-  let unbound_type_variable (e:environment) (tv:I.type_variable) (loc:Location.t) () =
-    let name = Var.to_name tv in
-    let suggestion = match name with
-        | "integer" -> "int"
-        | "str" -> "string"
-        | "boolean" -> "bool"
-        | _ -> "no suggestion" in
-    let title = (thunk "unbound type variable") in
-    let message () = "" in
-    let data = [
-      ("variable" , fun () -> Format.asprintf "%a" I.PP.type_variable tv) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-      ("in" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
-      ("did_you_mean" , fun () -> suggestion)
-    ] in
-    error ~data title message ()
-
-  let unbound_variable (e:environment) (n:I.expression_variable) () =
-    let name () = Format.asprintf "%a" I.PP.expression_variable n in
-    let title = (thunk ("unbound variable "^(name ()))) in
-    let message () = "" in
-    let data = [
-      ("variable" , name) ;
-      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
-    ] in
-    error ~data title message ()
-
-  let match_empty_variant : I.matching_expr -> 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 : I.matching_expr -> 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 : I.matching_expr -> Location.t -> unit -> _ =
-    fun matching loc () ->
-    let title = (thunk "redundant 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) (c:I.constructor') (loc:Location.t) () =
-    let title = (thunk "unbound constructor") in
-    let message () = "" in
-    let data = [
-      ("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c);
-      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-
-  let redundant_constructor (e:environment) (c:I.constructor') () =
-    let title = (thunk "redundant constructor") in
-    let message () = "" in
-    let data = [
-      ("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c);
-      ("environment" , fun () -> Format.asprintf "%a" Environment.PP.environment e) ;
-    ] in
-    error ~data title message ()
-  
-  let michelson_or (c:I.constructor') loc () =
-    let title = (thunk "michelson_or types must be annotated") in
-    let message () = "" in
-    let data = [
-      ("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c);
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-
-  let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
-    let title () = "wrong arity" in
-    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 ()
-
-  (* TODO: this should be a trace_info? *)
-  let program_error (p:I.program) () =
-    let message () = "" in
-    let title = (thunk "typing program") in
-    let data = [
-      ("program" , fun () -> Format.asprintf "%a" I.PP.program p)
-    ] in
-    error ~data title message ()
-
-  let constant_declaration_error (name:I.expression_variable) (ae:I.expr) (expected: O.type_expression option) () =
-    let title = (thunk "typing constant declaration") in
-    let message () = "" in
-    let data = [
-      ("constant" , fun () -> Format.asprintf "%a" I.PP.expression_variable 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_expression expected) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
-    ] in
-    error ~data title message ()
-
-  let match_error : ?msg:string -> expected: I.matching_expr -> actual: O.type_expression -> 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_expression 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 fvs_in_create_contract_lambda (e : I.expression) (fvar : Ast_typed.expression_variable) () =
-    let title = (thunk "No free variable allowed in this lambda") in
-    let message () = Format.asprintf "variable '%a'" Var.pp fvar 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 create_contract_lambda (cst : I.constant') (e : I.expression) () =
-    let title () = Format.asprintf "%a first argument must be inlined" I.PP.constant cst in
-    let message () = Format.asprintf "contract code can be inlined using a lambda" 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_expression) ~(expression : I.expression) (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_expression actual);
-      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-
-  let _type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
-    let title = (thunk "type error") in
-    let message () = msg in
-    let data = [
-      ("expected"   , fun () -> Format.asprintf "%a" O.PP.type_expression expected);
-      ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
-      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-
-  let bad_record_access (field : I.label) (ae : I.expression) (t : O.type_expression) (loc:Location.t) () =
-    let title = (thunk "invalid record field") in
-    let message () = "" in
-    let data = [
-      ("field" , fun () -> Format.asprintf "%a" I.PP.label field) ;
-      ("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
-      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_expression t) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-
-  let bad_type_operator type_op =
-    let title () = Format.asprintf "bad type operator %a" I.PP.type_expression type_op in
-    let message () = "" in
-    error title message
-
-end
-open Errors
 
 let convert_constructor' (I.Constructor c) = O.Constructor c
 let unconvert_constructor' (O.Constructor c) = I.Constructor c
@@ -484,7 +272,7 @@ let unconvert_constant' : O.constant' -> I.constant' = function
   | C_CONVERT_FROM_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB
   | C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_COMB
 
-let rec type_program (p:I.program) : (O.program * O'.typer_state) result =
+let rec type_program (p:I.program) : (O.program * O'.typer_state, typer_error) result =
   let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
     let%bind ed' = (bind_map_location (type_declaration e (Solver.placeholder_for_state_of_new_typer ()))) d in
     let loc : 'a . 'a Location.wrap -> _ -> _ = fun x v -> Location.wrap ~loc:x.location v in
@@ -492,11 +280,12 @@ let rec type_program (p:I.program) : (O.program * O'.typer_state) result =
     ok (e', loc ed' d' :: acc)
   in
   let%bind (_, lst) =
-    trace (fun () -> program_error p ()) @@
+    trace (program_error_tracer p) @@
     bind_fold_list aux (DEnv.default, []) p in
   ok @@ (List.rev lst , (Solver.placeholder_for_state_of_new_typer ()))
 
-and type_declaration env (_placeholder_for_state_of_new_typer : O'.typer_state) : I.declaration -> (environment * O'.typer_state * O.declaration) result = function
+
+and type_declaration env (_placeholder_for_state_of_new_typer : O'.typer_state) : I.declaration -> (environment * O'.typer_state * O.declaration, typer_error) result = function
   | Declaration_type (type_binder , type_expr) ->
       let%bind tv = evaluate_type env type_expr in
       let env' = Environment.add_type (type_binder) tv env in
@@ -504,17 +293,17 @@ and type_declaration env (_placeholder_for_state_of_new_typer : O'.typer_state)
   | Declaration_constant (binder , tv_opt , inline, expression) -> (
       let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
       let%bind expr =
-        trace (constant_declaration_error binder expression tv'_opt) @@
+        trace (constant_declaration_error_tracer binder expression tv'_opt) @@
         type_expression' ?tv_opt:tv'_opt env expression in
       let post_env = Environment.add_ez_declaration binder expr env in
       ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline}))
     )
 
-and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result =
+and type_match : (environment -> I.expression -> (O.expression , typer_error) result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr, typer_error) result =
   fun f e t i _ae loc -> match i with
   | Match_option {match_none ; match_some} ->
       let%bind tv =
-        trace_strong (match_error ~expected:i ~actual:t loc)
+        trace_option (match_error ~expected:i ~actual:t loc)
         @@ get_t_option t in
       let%bind match_none = f e match_none in
       let (opt, b) = match_some in
@@ -523,7 +312,7 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
       ok (O.Match_option {match_none ; match_some = {opt; body; tv}})
   | Match_list {match_nil ; match_cons} ->
       let%bind t_elt =
-        trace_strong (match_error ~expected:i ~actual:t loc)
+        trace_option (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
@@ -533,19 +322,18 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
       ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}})
   | Match_variant lst ->
       let%bind variant_cases' =
-        trace (match_error ~expected:i ~actual:t loc)
+        trace_option (match_error ~expected:i ~actual:t loc)
         @@ Ast_typed.Combinators.get_t_sum t in
       let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' in
       let match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
       let test_case = fun c ->
-        Assert.assert_true (List.mem c match_cases)
+        Assert.assert_true (corner_case "match case") (List.mem c match_cases)
       in
       let%bind () =
         trace_strong (match_missing_case i loc) @@
         bind_iter_list test_case variant_cases in
       let%bind () =
-        trace_strong (match_redundant_case i loc) @@
+        Assert.assert_true (match_redundant_case i loc) List.(length variant_cases = length match_cases) in
-        Assert.assert_true List.(length variant_cases = length match_cases) in
       let%bind cases =
         let aux ((constructor_name , pattern) , b) =
           let%bind {ctor_type=constructor;_} =
@@ -559,7 +347,7 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
         bind_map_list aux lst in
       ok (O.Match_variant { cases ; tv=t })
 
-and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
+and evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result =
   let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in
   match t.type_content with
   | T_arrow {type1;type2} ->
@@ -574,7 +362,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
           | Some _ ->
             if I.CMap.mem (Constructor "M_left") m || I.CMap.mem (Constructor "M_right") m then
               ok ()
-            else fail (redundant_constructor e k)
+            else fail (redundant_constructor e k t.location)
           | None -> ok () in
         let v' : O.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in
         ok @@ O.CMap.add (convert_constructor' k) v' prev'
@@ -627,61 +415,52 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
         let%bind lmap = match c'.type_content with
           | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
           | _ -> fail (michelson_comb_no_record t.location) in
-        let record = Operators.Typer.Converter.convert_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
+        let record = Typer_common.Michelson_type_converter.convert_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
         return @@ record
     | TC_michelson_pair_left_comb, [c] ->
         let%bind c' = evaluate_type e c in
         let%bind lmap = match c'.type_content with
           | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
           | _ -> fail (michelson_comb_no_record t.location) in
-        let record = Operators.Typer.Converter.convert_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
+        let record = Typer_common.Michelson_type_converter.convert_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
         return @@ record
     | TC_michelson_or_right_comb, [c] ->
         let%bind c' = evaluate_type e c in
         let%bind cmap = match c'.type_content with
           | T_sum cmap -> ok cmap
           | _ -> fail (michelson_comb_no_variant t.location) in
-        let pair = Operators.Typer.Converter.convert_variant_to_right_comb (Ast_typed.CMap.to_kv_list cmap) in
+        let pair = Typer_common.Michelson_type_converter.convert_variant_to_right_comb (Ast_typed.CMap.to_kv_list cmap) in
         return @@ pair
     | TC_michelson_or_left_comb, [c] ->
         let%bind c' = evaluate_type e c in
         let%bind cmap = match c'.type_content with
           | T_sum cmap -> ok cmap
           | _ -> fail (michelson_comb_no_variant t.location) in
-        let pair = Operators.Typer.Converter.convert_variant_to_left_comb (Ast_typed.CMap.to_kv_list cmap) in
+        let pair = Typer_common.Michelson_type_converter.convert_variant_to_left_comb (Ast_typed.CMap.to_kv_list cmap) in
         return @@ pair
-    | _ -> fail @@ bad_type_operator t
+    | _ -> fail @@ unrecognized_type_op t
   )
 
-and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result
+and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state, typer_error) result
   = fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
     let%bind res = type_expression' e ?tv_opt ae in
     ok (res, (Solver.placeholder_for_state_of_new_typer ()))
 
-and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression -> O.expression result = fun e ?tv_opt ae ->
+and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression -> (O.expression, typer_error) result = fun e ?tv_opt ae ->
   let module L = Logger.Stateful() in
   let return expr tv =
     let%bind () =
       match tv_opt with
       | None -> ok ()
-      | Some tv' -> O.assert_type_expression_eq (tv' , tv) in
+      | Some tv' -> assert_type_expression_eq (tv' , tv) in
     let location = ae.location in
     ok @@ make_e ~location expr tv in
-  let main_error =
+  trace (expression_tracer ae) @@
-    let title () = "typing expression" in
-    let content () = "" in
-    let data = [
-      ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) ;
-      ("misc" , fun () -> L.get ()) ;
-    ] in
-    error ~data title content in
-  trace main_error @@
   match ae.expression_content with
   (* Basic *)
   | 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_unit ->
@@ -713,49 +492,41 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
       return (e_operation op) (t_operation ())
   | E_record_accessor {record;path} ->
       let%bind e' = type_expression' e record in
-      let aux (prev:O.expression) (a:I.label) : O.expression result =
+      let aux (prev:O.expression) (a:I.label) : (O.expression , typer_error) result =
             let property = a in
-            let%bind r_tv = get_t_record prev.type_expression in
+            let%bind r_tv = trace_option (bad_record_access property ae prev.type_expression ae.location) @@
+             get_t_record prev.type_expression in
             let%bind tv =
-              generic_try (bad_record_access property ae prev.type_expression ae.location)
+              trace_option (bad_record_access property ae prev.type_expression ae.location) @@
-              @@ (fun () -> let ({field_type;_} : O.field_content) = O.LMap.find (convert_label property) r_tv in field_type) in
+              O.LMap.find_opt (convert_label property) r_tv in
             let location = ae.location in
-            ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv
+            ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv.field_type
       in
       let%bind ae =
-      trace (simple_info "accessing") @@ aux e' path in
+      trace (record_access_tracer e') @@ aux e' path in
       (* check type annotation of the final accessed element *)
       let%bind () =
         match tv_opt with
         | None -> ok ()
-        | Some tv' -> O.assert_type_expression_eq (tv' , ae.type_expression) in
+        | Some tv' -> assert_type_expression_eq (tv' , ae.type_expression) in
       ok(ae)
   | E_constructor {constructor = Constructor s ; element} when String.equal s "M_left" || String.equal s "M_right" -> (
-    let%bind t = trace_option (Errors.michelson_or (Constructor s) ae.location) @@ tv_opt in 
+    let%bind t = trace_option (michelson_or (Constructor s) ae.location) @@ tv_opt in 
     let%bind expr' = type_expression' e element in
     ( match t.type_content with
       | T_sum c ->
         let {ctor_type ; _} : O.ctor_content = O.CMap.find (O.Constructor s) c in
-        let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, ctor_type) in
+        let%bind () = assert_type_expression_eq (expr'.type_expression, ctor_type) in
         return (E_constructor {constructor = Constructor s; element=expr'}) t
-      | _ -> simple_fail "ll" 
+      | _ -> fail (michelson_or (Constructor s) ae.location)
     )
   )
   (* Sum *)
   | E_constructor {constructor; element} ->
-      let%bind (c_tv, sum_tv) =
+      let%bind (c_tv, sum_tv) = trace_option (unbound_constructor e constructor ae.location) @@
-        let error =
-          let title () = "no such constructor" in
-          let content () =
-            Format.asprintf "%a in:\n%a\n"
-              Stage_common.PP.constructor constructor 
-              O.Environment.PP.environment e
-          in
-          error title content in
-        trace_option error @@
         Environment.get_constructor constructor e in
       let%bind expr' = type_expression' e element in
-      let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
+      let%bind _assert = assert_type_expression_eq (expr'.type_expression, c_tv) in
       let constructor = convert_constructor' constructor in
       return (E_constructor {constructor; element=expr'}) sum_tv
   (* Record *)
@@ -765,9 +536,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
         ok (O.LMap.add (convert_label k) expr' prev)
       in
       let%bind m' = Stage_common.Helpers.bind_fold_lmap aux (ok O.LMap.empty) m in
-      (* let () = match tv_opt with
-        Some _ -> Format.printf "YES"
-       | None -> Format.printf "NO" in *)
       let lmap = O.LMap.map (fun e -> ({field_type = get_type_expression e; michelson_annotation = None; field_decl_pos=0}:O.field_content)) m' in
       return (E_record m') (t_record lmap ())
   | E_record_update {record; path; update} ->
@@ -785,7 +553,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
       )
       | _ -> failwith "Update an expression which is not a record"
     in
-    let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
+    let%bind () = assert_type_expression_eq (tv, get_type_expression update) in
     return (E_record_update {record; path; update}) wrapped
   (* Data-structure *)
   | E_lambda lambda -> 
@@ -801,7 +569,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
                     collect ; 
                     init_record ;
                   ]} ->
-      (* this special case is here force annotation of the untyped lambda
+      (* this special case is here to force annotation of the untyped lambda
          generated by pascaligo's for_collect loop *)
       let%bind (v_col , v_initr ) = bind_map_pair (type_expression' e) (collect , init_record ) in
       let tv_col = get_type_expression v_col   in (* this is the type of the collection  *)
@@ -809,10 +577,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
       let%bind input_type = match tv_col.type_content with
         | O.T_operator ( TC_list t | TC_set t) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",t)])
         | O.T_operator ( TC_map {k;v}| TC_big_map {k;v}) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",make_t_ez_record [("0",k);("1",v)])])
-        | _ ->
+        | _ -> fail @@ bad_collect_loop tv_col ae.location in
-          let wtype = Format.asprintf
-            "Loops over collections expect lists, sets or maps, got type %a" O.PP.type_expression tv_col in 
-          fail @@ simple_error wtype in 
       let e' = Environment.add_ez_binder lname input_type e in
       let%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in
       let output_type = body.type_expression in
@@ -896,14 +661,12 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
       let%bind args' = type_expression' e args in
       let%bind tv = match lamb'.type_expression.type_content with
         | T_arrow {type1;type2} ->
-            let%bind _ = O.assert_type_expression_eq (type1, args'.type_expression) in
+            let%bind _ = assert_type_expression_eq (type1, args'.type_expression) in
             ok type2
         | _ ->
           fail @@ type_error_approximate
-            ~expected:"should be a function type"
             ~expression:lamb
             ~actual:lamb'.type_expression
-            lamb'.location
       in
       return (E_application {lamb=lamb'; args=args'}) tv
   (* Advanced *)
@@ -921,7 +684,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
         let%bind () =
           match prec with
           | None -> ok ()
-          | Some cur' -> Ast_typed.assert_type_expression_eq (cur , cur') in
+          | Some cur' -> assert_type_expression_eq (cur , cur') in
         ok (Some cur) in
       let%bind tv_opt = bind_fold_list aux None tvs in
       let%bind tv =
@@ -937,7 +700,8 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
     let%bind let_result = type_expression' e' let_result in
     return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression
   | E_raw_code {language;code} ->
-    let%bind (code,type_expression) = I.get_e_ascription code.expression_content in
+    let%bind (code,type_expression) = trace_option (expected_ascription code) @@
+      I.get_e_ascription code.expression_content in
     let%bind code = type_expression' e code in
     let%bind type_expression = evaluate_type e type_expression in
     let code = {code with type_expression} in
@@ -951,15 +715,16 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
     let%bind tv = evaluate_type e type_annotation in
     let%bind expr' = type_expression' ~tv_opt:tv e anno_expr in
     let%bind type_annotation =
+      trace_option (corner_case "merge_annotations (Some ...) (Some ...) failed") @@
       O.merge_annotation
         (Some tv)
         (Some expr'.type_expression)
-        (internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in
+        O.assert_type_expression_eq in
     (* check type annotation of the expression as a whole (e.g. let x : t = (v : t') ) *)
     let%bind () =
       match tv_opt with
       | None -> ok ()
-      | Some tv' -> O.assert_type_expression_eq (tv' , type_annotation) in
+      | Some tv' -> assert_type_expression_eq (tv' , type_annotation) in
     ok {expr' with type_expression=type_annotation}
 
 and type_lambda e {
@@ -999,18 +764,18 @@ and type_lambda e {
 
 
 
-and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
+and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression , typer_error) result =
   let name = convert_constant' name in
-  let%bind typer = Operators.Typer.constant_typers name in
+  let%bind typer = Typer_common.Constant_typers.constant_typers name in
   let%bind tv = typer lst tv_opt in
-  ok(name, tv)
+  ok (name, tv)
 
-let untype_type_expression (t:O.type_expression) : (I.type_expression) result =
+let untype_type_expression (t:O.type_expression) : (I.type_expression , typer_error) result =
   match t.type_meta with
   | Some s -> ok s
-  | _ -> fail @@ internal_assertion_failure "trying to untype generated type"
+  | _ -> fail @@ corner_case "Trying to untype generated type"
 
-let untype_literal (l:O.literal) : I.literal result =
+let untype_literal (l:O.literal) : (I.literal , typer_error) result =
   let open I in
   match l with
   | Literal_unit -> ok Literal_unit
@@ -1029,9 +794,9 @@ let untype_literal (l:O.literal) : I.literal result =
   | Literal_address s -> ok (Literal_address s)
   | Literal_operation s -> ok (Literal_operation s)
 
-let rec untype_expression (e:O.expression) : (I.expression) result =
+let rec untype_expression (e:O.expression) : (I.expression , typer_error) result =
   untype_expression_content e.type_expression e.expression_content
-  and untype_expression_content ty (ec:O.expression_content) : (I.expression) result =
+  and untype_expression_content ty (ec:O.expression_content) : (I.expression , typer_error) result =
   let open I in
   let return e = ok e in
   match ec with
@@ -1048,7 +813,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
       let%bind arg' = untype_expression args in
       return (e_application f' arg')
   | E_lambda {binder ; result} -> (
-      let%bind io = get_t_function ty in
+      let io = get_t_function_exn ty in
       let%bind (input_type , output_type) = bind_map_pair untype_type_expression io in
       let%bind result = untype_expression result in
       return (e_lambda (binder) (Some input_type) (Some output_type) result)
@@ -1087,7 +852,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
       let lambda = match unty_expr.expression_content with I.E_lambda l -> l | _ -> failwith "impossible case" in
       return @@ e_recursive fun_name fun_type lambda
 
-and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
+and untype_matching : (O.expression -> (I.expression , typer_error) result) -> O.matching_expr -> (I.matching_expr , typer_error) result = fun f m ->
   let open I in
   match m with
   | Match_option {match_none ; match_some = {opt; body ; tv=_}} ->

src/passes/08-typer-old/typer.mli

@@ -1,3 +1,4 @@
+open Typer_common.Errors
 open Trace
 
 module I = Ast_core
@@ -10,46 +11,16 @@ module Solver : module type of Typer_new.Solver
 
 type environment = Environment.t
 
-module Errors : sig
+val type_program : I.program -> (O.program * O'.typer_state , typer_error) result
-  (*
+val type_declaration : environment -> O'.typer_state -> I.declaration -> (environment * O'.typer_state * O.declaration , typer_error) result
-  val unbound_type_variable : environment -> string -> unit -> error
+val evaluate_type : environment -> I.type_expression -> (O.type_expression , typer_error) result
-  val unbound_variable : environment -> string -> Location.t -> unit -> error
+val type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state , typer_error) result
-  val match_empty_variant : 'a I.matching -> Location.t -> unit -> error
+val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression , typer_error) result
-  val match_missing_case : 'a I.matching -> Location.t -> unit -> error
-  val match_redundant_case : 'a I.matching -> Location.t -> unit -> error
-  val unbound_constructor : environment -> string -> Location.t -> unit -> error
-  val unrecognized_constant : string -> Location.t -> unit -> error
-  *)
-  val wrong_arity : string -> int -> int -> Location.t -> unit -> error
-  (*
-  val match_tuple_wrong_arity : 'a list -> 'b list -> Location.t -> unit -> error
-
-  (* TODO: this should be a trace_info? *)
-  val program_error : I.program -> unit -> error
-  val constant_declaration_error : string -> I.expr -> O.type_value option -> unit -> error
-  val match_error : ?msg:string -> expected:'a I.matching -> actual:O.type_value -> Location.t -> unit -> error
-  val needs_annotation : I.expression -> string -> unit -> error
-  val type_error_approximate : ?msg:string -> expected:string -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error
-  val type_error : ?msg:string -> expected:O.type_value -> actual:O.type_value -> expression:I.expression -> Location.t -> unit -> error
-  val bad_tuple_index : int -> I.expression -> O.type_value -> Location.t -> unit -> error
-  val bad_record_access : string -> I.expression -> O.type_value -> Location.t -> unit -> error
-  val not_supported_yet : string -> I.expression -> unit -> error
-  val not_supported_yet_untranspile : string -> O.expression -> unit -> error
-  val constant_error : Location.t -> O.type_value list -> O.type_value option -> unit -> error
-  *)
-end
-
-val type_program : I.program -> (O.program * O'.typer_state) result
-val type_declaration : environment -> O'.typer_state -> I.declaration -> (environment * O'.typer_state * O.declaration) result
-(* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
-val evaluate_type : environment -> I.type_expression -> O.type_expression result
-val type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result
-val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression) result
 (*
 val untype_type_value : O.type_value -> (I.type_expression) result
 val untype_literal : O.literal -> I.literal result
 *)
-val untype_expression : O.expression -> I.expression result
+val untype_expression : O.expression -> (I.expression , typer_error) result
 (*
 val untype_matching : ('o -> 'i result) -> 'o O.matching -> ('i I.matching) result
 *)

src/passes/08-typer/typer.ml

@@ -3,6 +3,7 @@ let use_new_typer = false
 module I = Ast_core
 module O = Ast_typed
 module O' = Typesystem.Solver_types
+module Errors = Typer_common.Errors
 
 module Environment = O.Environment
 
@@ -10,6 +11,9 @@ module Solver = Typer_new.Solver (* Both the old typer and the new typer use the
 
 type environment = Environment.t
 
-let type_program = if use_new_typer then Typer_new.type_program else Typer_old.type_program
+(* let type_program = if use_new_typer then Typer_new.type_program else Typer_old.type_program *)
+let type_program = Typer_old.type_program
 let type_expression_subst = if use_new_typer then Typer_new.type_expression_subst else Typer_old.type_expression (* the old typer does not have unification variables that would need substitution, so no need to "subst" anything. *)
 let untype_expression = if use_new_typer then Typer_new.untype_expression else Typer_old.untype_expression
+
+let assert_type_expression_eq = Typer_common.Helpers.assert_type_expression_eq

src/passes/08-typer/typer.mli

@@ -5,13 +5,15 @@ open Trace
 module I = Ast_core
 module O = Ast_typed
 module O' = Typesystem.Solver_types
-
 module Environment = O.Environment
+module Errors = Typer_common.Errors
 
 module Solver = Typer_new.Solver
 
 type environment = Environment.t
 
-val type_program : I.program -> (O.program * O'.typer_state) result
+val type_program : I.program -> (O.program * O'.typer_state, Errors.typer_error) result
-val type_expression_subst : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result
+val type_expression_subst : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state , Errors.typer_error) result
-val untype_expression : O.expression -> I.expression result
+val untype_expression : O.expression -> (I.expression , Errors.typer_error) result
+
+val assert_type_expression_eq : O.type_expression * O.type_expression -> (unit, Errors.typer_error) result

src/passes/09-self_ast_typed/contract_passes.ml

@@ -1,3 +1,4 @@
+open Errors
 open Ast_typed.Types
 open Trace
 
@@ -6,41 +7,6 @@ type contract_pass_data = {
   main_name : string ;
 }
 
-module Errors = struct
-  let bad_self_type expected got loc () =
-    let title = thunk "bad self type" in
-    let message () = Format.asprintf "expected %a but got %a" Ast_typed.PP.type_expression expected Ast_typed.PP.type_expression got in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-  
-  let bad_format_entrypoint_ann ep loc () =
-    let title = thunk "bad entrypoint format" in
-    let message () = Format.asprintf "entrypoint \"%s\" is badly formatted. We expect \"%%bar\" for entrypoint Bar and \"%%default\" when no entrypoint used" ep in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-    ] in
-    error ~data title message ()
-
-  let entrypoint_annotation_not_literal loc () =
-    let title = thunk "entrypoint annotation must be a string literal" in
-    let message () = Format.asprintf "" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-    ] in
-    error ~data title message ()
-  
-  let unmatched_entrypoint loc () =
-    let title = thunk "No constructor matches the entrypoint annotation" in
-    let message () = Format.asprintf "" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
-    ] in
-    error ~data title message ()
-
-end
-
 let check_entrypoint_annotation_format ep (exp: expression) =
   match String.split_on_char '%' ep with
     | [ "" ; ep'] ->
@@ -50,7 +16,7 @@ let check_entrypoint_annotation_format ep (exp: expression) =
     | _ -> fail @@ Errors.bad_format_entrypoint_ann ep exp.location 
 
 
-let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data * expression) result = fun dat e ->
+let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data * expression , self_ast_typed_error) result = fun dat e ->
   let bad_self_err () = Errors.bad_self_type
     e.type_expression 
     {e.type_expression with type_content = T_operator (TC_contract dat.contract_type.parameter)}
@@ -68,7 +34,7 @@ let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data
         ok ctor_type
       | t -> ok {dat.contract_type.parameter with type_content = t} in
     let%bind () =
-      trace_strong (bad_self_err ()) @@
+      trace_option (bad_self_err ()) @@
       Ast_typed.assert_type_expression_eq (entrypoint_t , t) in
     ok (true, dat, e)
   | _ -> ok (true,dat,e)

src/passes/09-self_ast_typed/errors.ml

@@ -0,0 +1,257 @@
+open Simple_utils.Display
+open Trace
+
+let stage = "self_ast_typed"
+
+type self_ast_typed_error = [
+  | `Self_ast_typed_rec_call of Ast_typed.expression_variable * Location.t
+  | `Self_ast_typed_bad_self_type of Ast_typed.type_expression * Ast_typed.type_expression * Location.t
+  | `Self_ast_typed_format_entrypoint_ann of string * Location.t
+  | `Self_ast_typed_entrypoint_ann_not_literal of Location.t
+  | `Self_ast_typed_unmatched_entrypoint of Location.t
+  | `Self_ast_typed_nested_big_map of Location.t
+  | `Self_ast_typed_corner_case of string
+  | `Self_ast_typed_contract_io of string * Ast_typed.expression
+  | `Self_ast_typed_contract_list_ops of string * Ast_typed.type_expression * Ast_typed.expression
+  | `Self_ast_typed_expected_same_entry of
+    string * Ast_typed.type_expression * Ast_typed.type_expression * Ast_typed.expression
+  | `Self_ast_typed_pair_in of Location.t
+  | `Self_ast_typed_pair_out of Location.t
+]
+let recursive_call_is_only_allowed_as_the_last_operation name loc =
+  `Self_ast_typed_rec_call (name,loc)
+let bad_self_type expected got loc =
+  `Self_ast_typed_bad_self_type (expected,got,loc)
+let bad_format_entrypoint_ann ep loc =
+  `Self_ast_typed_format_entrypoint_ann (ep,loc)
+let entrypoint_annotation_not_literal loc =
+  `Self_ast_typed_entrypoint_ann_not_literal loc
+let unmatched_entrypoint loc =
+  `Self_ast_typed_unmatched_entrypoint loc
+let nested_bigmap loc = `Self_ast_typed_nested_big_map loc
+let corner_case s = `Self_ast_typed_corner_case s
+let bad_contract_io entrypoint e = `Self_ast_typed_contract_io (entrypoint, e)
+let expected_list_operation entrypoint got e =
+  `Self_ast_typed_contract_list_ops (entrypoint, got, e)
+let expected_same entrypoint t1 t2 e =
+  `Self_ast_typed_expected_same_entry (entrypoint,t1,t2,e)
+let expected_pair_in loc = `Self_ast_typed_pair_in loc
+let expected_pair_out loc = `Self_ast_typed_pair_out loc
+
+let error_ppformat : display_format:string display_format ->
+  Format.formatter -> self_ast_typed_error -> unit =
+  fun ~display_format f a ->
+  match display_format with
+  | Human_readable | Dev -> (
+    match a with
+    | `Self_ast_typed_rec_call (_name,loc) ->
+      Format.fprintf f
+        "@[<hv>%a@ Recursion must be achieved through tail-calls only@]"
+        Location.pp loc
+    | `Self_ast_typed_bad_self_type (expected,got,loc) ->
+      Format.fprintf f
+        "@[<hv>%a@ Bad self type@ expected %a@ got %a@]"
+        Location.pp loc
+        Ast_typed.PP.type_expression expected
+        Ast_typed.PP.type_expression got 
+    | `Self_ast_typed_format_entrypoint_ann (ep,loc) ->
+      Format.fprintf f
+        "@[<hv>%a@ Bad entrypoint format '%s'@ We expect '%%bar' for entrypoint Bar and '%%default' when no entrypoint used"
+        Location.pp loc
+        ep
+    | `Self_ast_typed_entrypoint_ann_not_literal loc ->
+      Format.fprintf f
+        "@[<hv>%a@ Entrypoint annotation must be a string literal@]"
+        Location.pp loc
+    | `Self_ast_typed_unmatched_entrypoint loc ->
+      Format.fprintf f
+        "@[<hv>%a@ No constructor matches the entrypoint annotation@]"
+        Location.pp loc
+    | `Self_ast_typed_nested_big_map loc ->
+      Format.fprintf f
+        "@[<hv>%a@ It looks like you have nested a big map inside another big map, this is not supported@]"
+        Location.pp loc
+    | `Self_ast_typed_corner_case desc ->
+      Format.fprintf f
+        "@[<hv>Internal error: %s @]"
+        desc
+    | `Self_ast_typed_contract_io (_entrypoint, e) ->
+      Format.fprintf f
+        "@[<hv>%a@ Badly typed contract:@ unexpected entrypoint type %a@]"
+        Location.pp e.location
+        Ast_typed.PP.type_expression e.type_expression
+    | `Self_ast_typed_contract_list_ops (_entrypoint, got, e) ->
+      Format.fprintf f
+        "@[<hv>%a@ Badly typed contract:@ expected %a but got %a@]"
+        Location.pp e.location
+        Ast_typed.PP.type_expression {got with type_content= T_operator (TC_list {got with type_content=T_constant TC_operation})}
+        Ast_typed.PP.type_expression got
+    | `Self_ast_typed_expected_same_entry (entrypoint,t1,t2,e) ->
+      Format.fprintf f
+        "@[<hv>%a@ Badly typed contract %s:@ expected storage type as right member of a pair in the input and output, \
+        but got:@ - %a in the input@ - %a in the output @]"
+        Location.pp e.location
+        entrypoint
+        Ast_typed.PP.type_expression t1
+        Ast_typed.PP.type_expression t2
+    | `Self_ast_typed_pair_in loc ->
+      Format.fprintf f
+        "@[<hv>%a@ Badly typed contract:@ expected a pair as parameter@]"
+        Location.pp loc
+    | `Self_ast_typed_pair_out loc ->
+      Format.fprintf f
+        "@[<hv>%a@ Badly typed contract:@ expected a pair as return type@]"
+        Location.pp loc
+  )
+
+let error_jsonformat : self_ast_typed_error -> J.t = fun a ->
+  let json_error ~stage ~content =
+    `Assoc [
+      ("status", `String "error") ;
+      ("stage", `String stage) ;
+      ("content",  content )]
+  in
+  match a with
+  | `Self_ast_typed_rec_call (name,loc) ->
+    let message = `String "recursion must be achieved through tail-calls only" in
+    let loc = `String (Format.asprintf "%a" Location.pp loc) in
+    let fn = `String (Format.asprintf "%a" Ast_typed.PP.expression_variable name) in
+    let content = `Assoc [
+       ("message", message);
+       ("location", loc);
+       ("function", fn);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_bad_self_type (expected,got,loc) ->
+    let message = `String "bad self type" in
+    let loc = `String (Format.asprintf "%a" Location.pp loc) in
+    let expected = `String (Format.asprintf "%a" Ast_typed.PP.type_expression expected) in
+    let actual = `String (Format.asprintf "%a" Ast_typed.PP.type_expression got) in
+    let content = `Assoc [
+       ("message", message);
+       ("location", loc);
+       ("expected", expected);
+       ("actual", actual);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_format_entrypoint_ann (ep,loc) ->
+    let message = `String "bad entrypoint format" in
+    let loc = `String (Format.asprintf "%a" Location.pp loc) in
+    let entrypoint = `String ep in
+    let hint = `String "we expect '%%bar' for entrypoint Bar and '%%default' when no entrypoint used" in
+    let content = `Assoc [
+       ("message", message);
+       ("location", loc);
+       ("hint", hint);
+       ("entrypoint", entrypoint);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_entrypoint_ann_not_literal loc ->
+    let message = `String "entrypoint annotation must be a string literal" in
+    let loc = `String (Format.asprintf "%a" Location.pp loc) in
+    let content = `Assoc [
+       ("message", message);
+       ("location", loc);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_unmatched_entrypoint loc ->
+    let message = `String "no constructor matches the entrypoint annotation" in
+    let loc = `String (Format.asprintf "%a" Location.pp loc) in
+    let content = `Assoc [
+       ("message", message);
+       ("location", loc);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_nested_big_map loc ->
+    let message = `String "it looks like you have nested a big map inside another big map, this is not supported" in
+    let loc = `String (Format.asprintf "%a" Location.pp loc) in
+    let content = `Assoc [
+       ("message", message);
+       ("location", loc);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_corner_case desc ->
+    let message = `String "internal error" in
+    let description = `String desc in
+    let content = `Assoc [
+       ("message", message);
+       ("description", description);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_contract_io (entrypoint, e) ->
+    let message = `String "badly typed contract" in
+    let description = `String "unexpected entrypoint type" in
+    let entrypoint = `String entrypoint in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let eptype = `String (Format.asprintf "%a" Ast_typed.PP.type_expression e.type_expression) in
+    let content = `Assoc [
+       ("message", message);
+       ("description", description);
+       ("entrypoint", entrypoint);
+       ("location", loc);
+       ("type", eptype);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_contract_list_ops (entrypoint, got, e) ->
+    let entrypoint = `String entrypoint in
+    let message = `String "badly typed contract" in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let actual = `String (Format.asprintf "%a"
+      Ast_typed.PP.type_expression {got with type_content= T_operator (TC_list {got with type_content=T_constant TC_operation})}) in
+    let expected = `String (Format.asprintf "%a" Ast_typed.PP.type_expression got) in
+    let content = `Assoc [
+       ("message", message);
+       ("entrypoint", entrypoint);
+       ("location", loc);
+       ("expected", expected);
+       ("actual", actual);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_expected_same_entry (entrypoint,t1,t2,e) ->
+    let entrypoint = `String entrypoint in
+    let message = `String "badly typed contract" in
+    let description = `String "expected storages" in
+    let loc = `String (Format.asprintf "%a" Location.pp e.location) in
+    let t1 = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t1) in
+    let t2 = `String (Format.asprintf "%a" Ast_typed.PP.type_expression t2) in
+    let content = `Assoc [
+       ("entrypoint", entrypoint);
+       ("message", message);
+       ("location", loc);
+       ("description", description);
+       ("type1", t1);
+       ("type2", t2);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_pair_in loc ->
+    let message = `String "badly typed contract" in
+    let description = `String "expected a pair as parameter" in
+    let loc = `String (Format.asprintf "%a" Location.pp loc) in
+    let content = `Assoc [
+       ("message", message);
+       ("location", loc);
+       ("description", description);
+       ]
+    in
+    json_error ~stage ~content
+  | `Self_ast_typed_pair_out loc ->
+    let message = `String "badly typed contract" in
+    let description = `String "expected a pair as return type" in
+    let loc = `String (Format.asprintf "%a" Location.pp loc) in
+    let content = `Assoc [
+       ("message", message);
+       ("location", loc);
+       ("description", description);
+       ]
+    in
+    json_error ~stage ~content

src/passes/09-self_ast_typed/helpers.ml

@@ -1,9 +1,10 @@
+open Errors
 open Ast_typed
 open Trace
 open Ast_typed.Helpers
 
-type 'a folder = 'a -> expression -> 'a result
+type ('a ,'err) folder = 'a -> expression -> ('a , 'err) result
-let rec fold_expression : 'a . 'a folder -> 'a -> expression -> 'a result = fun f init e ->
+let rec fold_expression : ('a , self_ast_typed_error) folder -> 'a -> expression -> ('a , self_ast_typed_error) result = fun f init e ->
   let self = fold_expression f in 
   let%bind init' = f init e in
   match e.expression_content with
@@ -51,7 +52,7 @@ let rec fold_expression : 'a . 'a folder -> 'a -> expression -> 'a result = fun
       ok res
     )
 
-and fold_cases : 'a . 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
+and fold_cases : ('a , 'err) folder -> 'a -> matching_expr -> ('a , 'err) result = fun f init m ->
   match m with
   | Match_list { match_nil ; match_cons = {hd=_; tl=_ ; body; tv=_} } -> (
       let%bind res = fold_expression f init match_nil in
@@ -71,8 +72,8 @@ and fold_cases : 'a . 'a folder -> 'a -> matching_expr -> 'a result = fun f init
       ok res
     )
 
-type mapper = expression -> expression result
+type 'err mapper = expression -> (expression , 'err) result
-let rec map_expression : mapper -> expression -> expression result = fun f e ->
+let rec map_expression : self_ast_typed_error mapper -> expression -> (expression , self_ast_typed_error) result = fun f e ->
   let self = map_expression f in
   let%bind e' = f e in
   let return expression_content = ok { e' with expression_content } in
@@ -124,7 +125,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
   | E_literal _ | E_variable _ | E_raw_code _ as e' -> return e'
 
 
-and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
+and map_cases : self_ast_typed_error mapper -> matching_expr -> (matching_expr , self_ast_typed_error) result = fun f m ->
   match m with
   | Match_list { match_nil ; match_cons = {hd ; tl ; body ; tv} } -> (
       let%bind match_nil = map_expression f match_nil in
@@ -145,7 +146,7 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
       ok @@ Match_variant {cases ; tv}
     )
 
-and map_program : mapper -> program -> program result = fun m p ->
+and map_program : self_ast_typed_error mapper -> program -> (program, self_ast_typed_error) result = fun m p ->
   let aux = fun (x : declaration) ->
     match x with
     | Declaration_constant {binder; expr ; inline} -> (
@@ -156,8 +157,8 @@ and map_program : mapper -> program -> program result = fun m p ->
   in
   bind_map_list (bind_map_location aux) p
 
-type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
+type ('a , 'err) fold_mapper = 'a -> expression -> (bool * 'a * expression , 'err) result
-let rec fold_map_expression : 'a . 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
+let rec fold_map_expression : ('a , 'err) fold_mapper -> 'a -> expression -> ('a * expression , 'err) result = fun f a e ->
   let self = fold_map_expression f in
   let%bind (continue, init',e') = f a e in
   if (not continue) then ok(init',e')
@@ -211,7 +212,7 @@ let rec fold_map_expression : 'a . 'a fold_mapper -> 'a -> expression -> ('a * e
     )
   | E_literal _ | E_variable _ | E_raw_code _ as e' -> ok (init', return e')
 
-and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
+and fold_map_cases : ('a , self_ast_typed_error) fold_mapper -> 'a -> matching_expr -> ('a * matching_expr , self_ast_typed_error) result = fun f init m ->
   match m with
   | Match_list { match_nil ; match_cons = { hd ; tl ; body ; tv } } -> (
       let%bind (init, match_nil) = fold_map_expression f init match_nil in
@@ -232,7 +233,7 @@ and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matchin
       ok @@ (init, Match_variant {cases ; tv})
     )
 
-and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p ->
+and fold_map_program : ('a, self_ast_typed_error) fold_mapper -> 'a -> program -> ('a * program , self_ast_typed_error) result = fun m init p ->
   let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
     match Location.unwrap x with
     | Declaration_constant {binder ; expr ; inline} -> (
@@ -247,50 +248,12 @@ and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) re
   in
   bind_fold_list aux (init,[]) p
 
-module Errors = struct
-  let bad_contract_io entrypoint (e:expression) () =
-    let title = thunk "badly typed contract" in
-    let message () = Format.asprintf "unexpected entrypoint type" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp e.location);
-      ("entrypoint" , fun () -> entrypoint);
-      ("entrypoint_type" , fun () -> Format.asprintf "%a" Ast_typed.PP.type_expression e.type_expression)
-    ] in
-    error ~data title message ()
-
-  let expected_list_operation entrypoint got (e:expression) () =
-    let title = thunk "bad return type" in
-    let message () = Format.asprintf "expected %a, got %a"
-      Ast_typed.PP.type_expression {got with type_content= T_operator (TC_list {got with type_content=T_constant TC_operation})}
-      Ast_typed.PP.type_expression got
-    in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp e.location);
-      ("entrypoint" , fun () -> entrypoint)
-    ] in
-    error ~data title message ()
-
-  let expected_same entrypoint t1 t2 (e:expression) () =
-    let title = thunk "badly typed contract" in
-    let message () = Format.asprintf "expected {%a} and {%a} to be the same in the entrypoint type"
-      Ast_typed.PP.type_expression t1
-      Ast_typed.PP.type_expression t2
-    in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp e.location);
-      ("entrypoint" , fun () -> entrypoint);
-      ("entrypoint_type" , fun () -> Format.asprintf "%a" Ast_typed.PP.type_expression e.type_expression)
-    ] in
-    error ~data title message ()
-  
-end
-
 type contract_type = {
   parameter : Ast_typed.type_expression ;
   storage : Ast_typed.type_expression ;
 }
 
-let fetch_contract_type : string -> program -> contract_type result = fun main_fname program ->
+let fetch_contract_type : string -> program -> (contract_type, self_ast_typed_error) result = fun main_fname program ->
   let aux declt = match Location.unwrap declt with
     | Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
        if String.equal (Var.to_name binder) main_fname
@@ -300,7 +263,7 @@ let fetch_contract_type : string -> program -> contract_type result = fun main_f
   in
   let main_decl_opt = List.find_map aux @@ List.rev  program in
   let%bind main_decl =
-    trace_option (simple_error ("Entrypoint '"^main_fname^"' does not exist")) @@
+    trace_option (corner_case ("Entrypoint '"^main_fname^"' does not exist")) @@
       main_decl_opt
     in
   let { binder=_ ; expr ; inline=_ } = main_decl in
@@ -308,14 +271,14 @@ let fetch_contract_type : string -> program -> contract_type result = fun main_f
   | T_arrow {type1 ; type2} -> (
     match type1.type_content , type2.type_content with
     | T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) ->
-       let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in
+       let%bind (parameter,storage) = trace_option (expected_pair_in expr.location) @@ Ast_typed.Helpers.get_pair tin in
-       let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in
+       let%bind (listop,storage') = trace_option (expected_pair_out expr.location) @@ Ast_typed.Helpers.get_pair tout in
-       let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@
+       let%bind () = trace_option (expected_list_operation main_fname listop expr) @@
                        Ast_typed.assert_t_list_operation listop in
-       let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@
+       let%bind () = trace_option (expected_same main_fname storage storage' expr) @@
                        Ast_typed.assert_type_expression_eq (storage,storage') in
        (* TODO: on storage/parameter : assert_storable, assert_passable ? *)
        ok { parameter ; storage }
-    |  _ -> fail @@ Errors.bad_contract_io main_fname expr
+    |  _ -> fail @@ bad_contract_io main_fname expr
   )
-  | _ -> fail @@ Errors.bad_contract_io main_fname expr
+  | _ -> fail @@ bad_contract_io main_fname expr

src/passes/09-self_ast_typed/michelson_layout.ml

@@ -1,3 +1,4 @@
+open Errors
 open Ast_typed
 open Trace
 
@@ -145,7 +146,7 @@ let rec from_left_comb_record
 let from_left_comb prev src_lmap dst_kvl conv_map =
   from_left_comb_record prev src_lmap (List.rev dst_kvl) conv_map
 
-let rec from_right_comb_or (to_convert:expression) (e:expression) (matchee_t,bodies) : expression result =
+let rec from_right_comb_or (to_convert:expression) (e:expression) (matchee_t,bodies) : (expression, self_ast_typed_error) result =
   match matchee_t , bodies with
   | [m] , bl::br::[] ->
     let cases = [
@@ -166,9 +167,9 @@ let rec from_right_comb_or (to_convert:expression) (e:expression) (matchee_t,bod
         pattern = Var.of_name "x";
         body } ] in
     ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression })
-  | _ -> simple_fail "corner case"
+  | _ -> fail @@ corner_case "from_right_comb conversion"
 
-let rec from_left_comb_or (to_convert:expression) (e:expression) (matchee_t,bodies) : expression result =
+let rec from_left_comb_or (to_convert:expression) (e:expression) (matchee_t,bodies) : (expression , self_ast_typed_error) result =
   match matchee_t , bodies with
   | [m] , bl::br::[] ->
     let cases = [
@@ -189,14 +190,14 @@ let rec from_left_comb_or (to_convert:expression) (e:expression) (matchee_t,bodi
         pattern = Var.of_name "x";
         body } ] in
     ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression })
-  | _ -> simple_fail "corner case"
+  | _ -> fail @@ corner_case "from_left_comb conversion"
 
 (**
   converts pair/record of a given layout to record/pair to another
   - foo = (a,(b,(c,d))) -> foo_converted = { a=foo.0 ; b=foo.1.0 ; c=foo.1.1.0 ; d=foo.1.1.1 }
   - foo = M_left(a) -> foo_converted = match foo with M_left x -> Foo x | M_right x -> Bar x
 **)
-let peephole_expression : expression -> expression result = fun e ->
+let peephole_expression : expression -> (expression , self_ast_typed_error) result = fun e ->
   let return expression_content = ok { e with expression_content } in
   match e.expression_content with
   | E_constant {cons_name= (C_CONVERT_TO_LEFT_COMB);arguments= [ to_convert ] } -> (
@@ -205,7 +206,7 @@ let peephole_expression : expression -> expression result = fun e ->
         let src_kvl = to_sorted_kv_list_l src_lmap in
         return @@ E_record (to_left_comb_record to_convert src_kvl LMap.empty)
       | T_sum src_cmap ->
-        let%bind dst_cmap = get_t_sum e.type_expression in
+        let%bind dst_cmap = trace_option (corner_case "to_left_comb conversion") @@ get_t_sum e.type_expression in
         let src_kvl = to_sorted_kv_list_c src_cmap in
         let bodies = left_comb_variant_combination e dst_cmap src_kvl in
         let to_cases ((constructor,{ctor_type=_;_}),body) =
@@ -225,7 +226,7 @@ let peephole_expression : expression -> expression result = fun e ->
         let src_kvl = to_sorted_kv_list_l src_lmap in
         return @@ E_record (to_right_comb_record to_convert src_kvl LMap.empty)
       | T_sum src_cmap ->
-        let%bind dst_cmap = get_t_sum e.type_expression in
+        let%bind dst_cmap = trace_option (corner_case "to_right_comb conversion") @@ get_t_sum e.type_expression in
         let src_kvl = to_sorted_kv_list_c src_cmap in
         let bodies = right_comb_variant_combination e dst_cmap src_kvl in
         let to_cases ((constructor,{ctor_type=_;_}),body) =
@@ -242,11 +243,11 @@ let peephole_expression : expression -> expression result = fun e ->
   | E_constant {cons_name= (C_CONVERT_FROM_RIGHT_COMB); arguments= [ to_convert ] } -> (
     match to_convert.type_expression.type_content with
       | T_record src_lmap ->
-        let%bind dst_lmap = get_t_record e.type_expression in
+        let%bind dst_lmap = trace_option (corner_case "from_right_comb conversion") @@ get_t_record e.type_expression in
         let dst_kvl = to_sorted_kv_list_l dst_lmap in
         return @@ E_record (from_right_comb_record to_convert src_lmap dst_kvl LMap.empty)
       | T_sum src_cmap ->
-        let%bind dst_lmap = get_t_sum e.type_expression in
+        let%bind dst_lmap = trace_option (corner_case "from_right_comb conversion") @@ get_t_sum e.type_expression in
         let dst_kvl = to_sorted_kv_list_c dst_lmap in
         let intermediary_types i = descend_types "M_right" src_cmap i in
         let matchee = to_convert :: (List.map (fun t -> match_var t) @@ intermediary_types ((List.length dst_kvl)-2)) in
@@ -260,11 +261,11 @@ let peephole_expression : expression -> expression result = fun e ->
   | E_constant {cons_name= (C_CONVERT_FROM_LEFT_COMB); arguments= [ to_convert ] } -> (
     match to_convert.type_expression.type_content with
       | T_record src_lmap ->
-        let%bind dst_lmap = get_t_record e.type_expression in
+        let%bind dst_lmap = trace_option (corner_case "from_left_comb conversion") @@ get_t_record e.type_expression in
         let dst_kvl = to_sorted_kv_list_l dst_lmap in
         return @@ E_record (from_left_comb to_convert src_lmap dst_kvl LMap.empty)
       | T_sum src_cmap ->
-        let%bind dst_lmap = get_t_sum e.type_expression in
+        let%bind dst_lmap = trace_option (corner_case "from_left_comb conversion") @@  get_t_sum e.type_expression in
         let dst_kvl = to_sorted_kv_list_c dst_lmap in
         let intermediary_types i = descend_types "M_left" src_cmap i in
         let matchee = to_convert :: (List.map (fun t -> match_var t) @@ intermediary_types ((List.length dst_kvl)-2)) in

src/passes/09-self_ast_typed/no_nested_big_map.ml

@@ -1,22 +1,13 @@
+open Errors
 open Ast_typed
 open Trace
 
 type contract_pass_data = Contract_passes.contract_pass_data
 
-module Errors = struct
-  let no_nested_bigmap () =
-    let title = (thunk ("It looks like you have nested a big map inside another big map. This is not supported. ")) in
-    let message () = "" in
-    let data = [
-      (* ("location" , fun () -> Format.asprintf "%a" Location.pp loc) TODO once types have an actual location *)
-    ] in
-    error ~data title message ()
-end
-
 let rec check_no_nested_bigmap is_in_bigmap e = 
   match e.type_content with
   | T_operator (TC_big_map _) when is_in_bigmap  -> 
-    fail @@ Errors.no_nested_bigmap
+    fail @@ nested_bigmap e.location
   | T_operator (TC_big_map {k ; v}) ->
     let%bind _ = check_no_nested_bigmap false k in
     let%bind _ = check_no_nested_bigmap true  v in
@@ -51,6 +42,6 @@ let rec check_no_nested_bigmap is_in_bigmap e =
   | T_constant _ -> 
     ok ()
 
-let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data * expression) result = fun dat el ->
+let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data * expression , self_ast_typed_error) result = fun dat el ->
   let%bind _ = check_no_nested_bigmap false el.type_expression in 
   ok (true, dat, el)

src/passes/09-self_ast_typed/self_ast_typed.ml

@@ -1,4 +1,5 @@
 open Trace
+module Errors = Errors
 
 let all_passes = [
   Tail_recursion.peephole_expression ;

src/passes/09-self_ast_typed/tail_recursion.ml

@@ -1,27 +1,16 @@
+open Errors
 open Ast_typed
 open Trace
 
-module Errors = struct
+let rec check_recursive_call : expression_variable -> bool -> expression -> (unit, self_ast_typed_error) result = fun n final_path e ->
-  let recursive_call_is_only_allowed_as_the_last_operation name loc () =
-    let title = (thunk ("Recursion must be achieved through tail-calls only")) in
-    let message () = "" in
-    let data = [
-      ("function" , fun () -> Format.asprintf "%a" PP.expression_variable name);
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-end
-open Errors
-
-let rec check_recursive_call : expression_variable -> bool -> expression -> unit result = fun n final_path e ->
   match e.expression_content with
   | E_literal _   -> ok ()
   | E_constant c  ->
     let%bind _ = bind_map_list (check_recursive_call n false) c.arguments in
     ok ()
   | E_variable v  -> (
-    let%bind _ = trace_strong (recursive_call_is_only_allowed_as_the_last_operation n e.location) @@
+    let%bind _ = Assert.assert_true (recursive_call_is_only_allowed_as_the_last_operation n e.location)
-    Assert.assert_true (final_path || n <> v) in
+      (final_path || n <> v) in
     ok ()
     )
   | E_application {lamb;args} ->
@@ -78,7 +67,7 @@ and check_recursive_call_in_matching = fun n final_path c ->
     ok ()
     
 
-let peephole_expression : expression -> expression result = fun e ->
+let peephole_expression : expression -> (expression, self_ast_typed_error) result = fun e ->
   let return expression_content = ok { e with expression_content } in
   match e.expression_content with
   | E_recursive {fun_name; lambda} as e-> (

src/passes/10-interpreter/interpreter.ml

@@ -5,8 +5,11 @@ include Ast_typed.Types
 
 module Env = Ligo_interpreter.Environment
 
+(*TODO, maybe the interpreter should never fail ?*)
+type interpreter_error = []
 
-let apply_comparison : Ast_typed.constant' -> value list -> value result =
+
+let apply_comparison : Ast_typed.constant' -> value list -> (value , interpreter_error) result =
   fun c operands -> match (c,operands) with
     | ( comp , [ V_Ct (C_int a'      ) ; V_Ct (C_int b'      ) ] )
     | ( comp , [ V_Ct (C_nat a'      ) ; V_Ct (C_nat b'      ) ] )
@@ -49,10 +52,10 @@ let apply_comparison : Ast_typed.constant' -> value list -> value result =
       ok @@ v_bool (f_op a' b')
     | _ ->
       let () = List.iter (fun el -> Format.printf "%s" (Ligo_interpreter.PP.pp_value el)) operands in
-      simple_fail "unsupported comparison"
+      failwith "unsupported comparison"
 
 (* applying those operators does not involve extending the environment *)
-let rec apply_operator : Ast_typed.constant' -> value list -> value result =
+let rec apply_operator : Ast_typed.constant' -> value list -> (value, interpreter_error) result =
   fun c operands ->
   let return_ct v = ok @@ V_Ct v in
   let return_none () = ok @@ v_none () in
@@ -160,9 +163,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
       aux @@ v_pair (v_bool true,init)
     (* tertiary *)
     | ( C_SLICE , [ V_Ct (C_nat st) ; V_Ct (C_nat ed) ; V_Ct (C_string s) ] ) ->
-      generic_try (simple_error "bad slice") @@ (fun () ->
+      ok @@ V_Ct (C_string (String.sub s (Z.to_int st) (Z.to_int ed)))
-        V_Ct (C_string (String.sub s (Z.to_int st) (Z.to_int ed)))
-      )
     | ( C_LIST_FOLD , [ V_Func_val (arg_name, body, env) ; V_List elts ; init ] ) ->
       bind_fold_list
         (fun prev elt ->
@@ -188,7 +189,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
     | ( C_MAP_UPDATE , [ k ; V_Construct (option,v) ; V_Map kvs] ) -> (match option with
       | "Some" -> ok @@ V_Map ((k,v)::(List.remove_assoc k kvs))
       | "None" -> ok @@ V_Map (List.remove_assoc k kvs)
-      | _ -> simple_fail "update without an option"
+      | _ -> failwith "update without an option"
     )
     | ( C_SET_EMPTY, []) -> ok @@ V_Set ([])
     | ( C_SET_ADD , [ v ; V_Set l ] ) -> ok @@ V_Set (List.sort_uniq compare (v::l))
@@ -212,7 +213,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
     | _ ->
       let () = Format.printf "%a\n" Ast_typed.PP.constant c in
       let () = List.iter ( fun e -> Format.printf "%s\n" (Ligo_interpreter.PP.pp_value e)) operands in
-      simple_fail "Unsupported constant op"
+      failwith "Unsupported constant op"
   )
 
 (* TODO
@@ -253,7 +254,7 @@ C_STEPS_TO_QUOTA
 *)
 
 (*interpreter*)
-and eval_literal : Ast_typed.literal -> value result = function
+and eval_literal : Ast_typed.literal -> (value , _) result = function
   | Literal_unit        -> ok @@ V_Ct (C_unit)
   | Literal_int i       -> ok @@ V_Ct (C_int i)
   | Literal_nat n       -> ok @@ V_Ct (C_nat n)
@@ -267,9 +268,9 @@ and eval_literal : Ast_typed.literal -> value result = function
   | Literal_key_hash s  -> ok @@ V_Ct (C_key_hash s)
   | Literal_chain_id s  -> ok @@ V_Ct (C_key_hash s)
   | Literal_operation o -> ok @@ V_Ct (C_operation o)
-  | Literal_void -> simple_fail "iguess ?"
+  | Literal_void -> failwith "iguess ?"
 
-and eval : Ast_typed.expression -> env -> value result
+and eval : Ast_typed.expression -> env -> (value , _) result
   = fun term env ->
     match term.expression_content with
     | E_application ({lamb = f; args}) -> (
@@ -283,7 +284,7 @@ and eval : Ast_typed.expression -> env -> value result
         let f_env' = Env.extend f_env (arg_names, args') in
         let f_env'' = Env.extend f_env' (fun_name, f') in
         eval body f_env''
-      | _ -> simple_fail "trying to apply on something that is not a function"
+      | _ -> failwith "trying to apply on something that is not a function"
     )
     | E_lambda {binder; result;} ->
       ok @@ V_Func_val (binder,result,env)
@@ -306,10 +307,9 @@ and eval : Ast_typed.expression -> env -> value result
       let%bind record' = eval record env in
       match record' with
       | V_Record recmap ->
-        let%bind a = trace_option (simple_error "unknown record field") @@
+        let a = LMap.find path recmap in
-          LMap.find_opt path recmap in
         ok a
-      | _ -> simple_fail "trying to access a non-record"
+      | _ -> failwith "trying to access a non-record"
     )
     | E_record_update {record ; path ; update} -> (
       let%bind record' = eval record env in
@@ -319,8 +319,8 @@ and eval : Ast_typed.expression -> env -> value result
           let%bind field' = eval update env in
           ok @@ V_Record (LMap.add path field' recmap)
         else
-          simple_fail "field l does not exist in record"
+          failwith "field l does not exist in record"
-      | _ -> simple_fail "this expression isn't a record"
+      | _ -> failwith "this expression isn't a record"
     )
     | E_constant {cons_name ; arguments} -> (
       let%bind operands' = bind_map_list
@@ -360,14 +360,14 @@ and eval : Ast_typed.expression -> env -> value result
         eval body env'
       | Match_option cases, V_Construct ("None" , V_Ct C_unit) ->
         eval cases.match_none env
-      | _ -> simple_fail "not yet supported case"
+      | _ -> failwith "not yet supported case"
         (* ((ctor,name),body) *)
     )
     | E_recursive {fun_name; fun_type=_; lambda} ->
       ok @@ V_Func_rec (fun_name, lambda.binder, lambda.result, env)
-    | E_raw_code _ -> simple_fail "Can't evaluate a raw code insertion"
+    | E_raw_code _ -> failwith "Can't evaluate a raw code insertion"
 
-let dummy : Ast_typed.program -> string result =
+let eval : Ast_typed.program -> (string , _) result =
   fun prg ->
   let aux  (pp,top_env) el =
     match Location.unwrap el with