merge

src/lib_utils/dictionary.ml

@@ -23,7 +23,7 @@ module Assoc : DICTIONARY = struct
 
   let get_exn x y = List.assoc y x
 
-  let get x y = generic_try (simple_error "Dictionry.get") @@ fun () -> get_exn x y
+  let get x y = generic_try (fun () -> simple_error (thunk "Dictionry.get") ()) @@ fun () -> get_exn x y
 
   let set ?equal lst a b =
     let equal : 'a -> 'a -> bool =

src/lib_utils/trace.ml

@@ -1,21 +1,31 @@
-type error = {
+type expanded_error = {
   message : string ;
   title : string ;
 }
+type error_thunk = unit -> expanded_error
+type error = error_thunk
 
 type 'a result =
     Ok of 'a
-  | Errors of error list
+  | Errors of error_thunk list
 
 let ok x = Ok x
 let fail err = Errors [err]
 
-let simple_error str = {
+(* When passing a constant string where a thunk is expected, we wrap it with thunk, as follows:
+   (thunk "some string")
+   We always put the parentheses around the call, to increase grep and sed efficiency.
+
+   When a trace function is called, it is passed a `(fun () -> …)`.
+   If the `…` is e.g. error then we write `(fun () -> error title msg ()` *)
+let thunk x () = x
+
+let simple_error str () = {
   message = "" ;
-  title = str ;
+  title = str () ;
 }
 
-let error title message = { title ; message }
+let error title message () = { title = title () ; message = message () }
 
 let simple_fail str = fail @@ simple_error str
 
@@ -42,6 +52,17 @@ let trace err = function
   | Ok _ as o -> o
   | Errors errs -> Errors (err :: errs)
 
+let trace_r err_thunk_may_fail = function
+  | Ok _ as o -> o
+  | Errors errs ->
+      match err_thunk_may_fail () with
+      | Ok err -> Errors (err :: errs)
+      | Errors errors_while_generating_error ->
+          (* TODO: the complexity could be O(n*n) in the worst case,
+             this should use some catenable lists. *)
+          Errors (errors_while_generating_error
+                  @ errs)
+
 let trace_f f error x =
   trace error @@ f x
 
@@ -49,10 +70,10 @@ let trace_f_2 f error x y =
   trace error @@ f x y
 
 let trace_f_ez f name =
-  trace_f f (error "in function" name)
+  trace_f f (error (thunk "in function") name)
 
 let trace_f_2_ez f name =
-  trace_f_2 f (error "in function" name)
+  trace_f_2 f (error (thunk "in function") name)
 
 let to_option = function
   | Ok o -> Some o
@@ -133,8 +154,8 @@ module AE = Memory_proto_alpha.Alpha_environment
 module TP = Tezos_base__TzPervasives
 
 let of_tz_error (err:X_error_monad.error) : error =
-  let str = X_error_monad.(to_string err) in
-  error "alpha error" str
+  let str () = X_error_monad.(to_string err) in
+  error (thunk "alpha error") str
 
 let of_alpha_tz_error err = of_tz_error (AE.Ecoproto_error err)
 
@@ -151,9 +172,26 @@ let trace_tzresult err =
   | Result.Ok x -> ok x
   | Error errs -> Errors (err :: List.map of_tz_error errs)
 
+(* TODO: should be a combination of trace_tzresult and trace_r *)
+let trace_tzresult_r err_thunk_may_fail =
+  function
+  | Result.Ok x -> ok x
+  | Error errs ->
+      let tz_errs = List.map of_tz_error errs in
+      match err_thunk_may_fail () with
+      | Ok err -> Errors (err :: tz_errs)
+      | Errors errors_while_generating_error ->
+          (* TODO: the complexity could be O(n*n) in the worst case,
+             this should use some catenable lists. *)
+          Errors (errors_while_generating_error
+                  @ tz_errs)
+
 let trace_tzresult_lwt err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result =
   trace_tzresult err @@ Lwt_main.run x
 
+let trace_tzresult_lwt_r err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result =
+  trace_tzresult_r err @@ Lwt_main.run x
+
 let generic_try err f =
   try (
     ok @@ f ()
@@ -162,11 +200,11 @@ let generic_try err f =
 let specific_try handler f =
   try (
     ok @@ f ()
-  ) with exn -> fail (handler exn)
+  ) with exn -> fail ((handler ()) exn)
 
 let sys_try f =
-  let handler = function
-    | Sys_error str -> error "Sys_error" str
+  let handler () = function
+    | Sys_error str -> error (thunk "Sys_error") (thunk str)
     | exn -> raise exn
   in
   specific_try handler f
@@ -174,7 +212,7 @@ let sys_try f =
 let sys_command command =
   sys_try (fun () -> Sys.command command) >>? function
   | 0 -> ok ()
-  | n -> fail (error "Nonzero return code" (string_of_int n))
+  | n -> fail (fun () -> error (thunk "Nonzero return code") (fun () -> (string_of_int n)) ())
 
 let sequence f lst =
   let rec aux acc = function
@@ -211,7 +249,7 @@ let pp_to_string pp () x =
 let errors_to_string = pp_to_string errors_pp
 
 module Assert = struct
-  let assert_true ?(msg="not true") = function
+  let assert_true ?(msg=(thunk "not true")) = function
     | true -> ok ()
     | false -> simple_fail msg
 
@@ -219,19 +257,21 @@ module Assert = struct
     assert_true ?msg (expected = actual)
 
   let assert_equal_int ?msg expected actual =
-    let default = Format.asprintf "Not equal int : expected %d, got %d" expected actual in
-    let msg = Option.unopt ~default msg in
+    let msg () =
+      let default = Format.asprintf "Not equal int : expected %d, got %d" expected actual in
+      Option.unopt ~default msg in
     assert_equal ~msg expected actual
 
   let assert_equal_bool ?msg expected actual =
-    let default = Format.asprintf "Not equal bool : expected %b, got %b" expected actual in
-    let msg = Option.unopt ~default msg in
+    let msg () =
+      let default = Format.asprintf "Not equal bool : expected %b, got %b" expected actual in
+      Option.unopt ~default msg in
     assert_equal ~msg expected actual
 
-  let assert_list_size ?(msg="lst doesn't have the right size") lst n =
+  let assert_list_size ?(msg=(thunk "lst doesn't have the right size")) lst n =
     assert_true ~msg List.(length lst = n)
 
-  let assert_list_same_size ?(msg="lists don't have same size") a b =
+  let assert_list_same_size ?(msg=(thunk "lists don't have same size")) a b =
     assert_true ~msg List.(length a = length b)
 
   let assert_list_size_2 ~msg = function

src/ligo/ast_simplified.ml

@@ -247,7 +247,7 @@ module Rename = struct
                   in
                   let%bind tl' = match tl with
                     | Access_record n -> ok n
-                    | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in
+                    | Access_tuple _ -> simple_fail (thunk "no support for renaming into tuples yet") in
                   ok (I_record_patch (name', hds, [tl', annotated_expression]))
             )
         )

src/ligo/ast_typed.ml

@@ -133,7 +133,7 @@ let get_entry (p:program) (entry : string) : annotated_expression result =
     | Declaration_constant _ -> None
   in
   let%bind result =
-    trace_option (simple_error "no entry point with given name") @@
+    trace_option (fun () -> simple_error (thunk "no entry point with given name") ()) @@
     Tezos_utils.List.find_map aux p in
   ok result
 
@@ -141,7 +141,7 @@ let get_functional_entry (p:program) (entry : string) : (lambda * type_value) re
   let%bind entry = get_entry p entry in
   match entry.expression with
   | E_lambda l -> ok (l, entry.type_annotation)
-  | _ -> simple_fail "given entry point is not functional"
+  | _ -> simple_fail (thunk "given entry point is not functional")
 
 module PP = struct
   open Format
@@ -246,20 +246,20 @@ end
 
 
 module Errors = struct
-  let different_kinds a b =
-    let title = "different kinds" in
-    let full = Format.asprintf "(%a) VS (%a)" PP.type_value a PP.type_value b in
-    error title full
+  let different_kinds a b () =
+    let title = (thunk "different kinds") in
+    let full () = Format.asprintf "(%a) VS (%a)" PP.type_value a PP.type_value b in
+    error title full ()
 
-  let different_constants a b =
-    let title = "different constants" in
-    let full = Format.asprintf "%s VS %s" a b in
-    error title full
+  let different_constants a b () =
+    let title = (thunk "different constants") in
+    let full () = Format.asprintf "%s VS %s" a b in
+    error title full ()
 
-  let different_size_type name a b =
-    let title = name ^ " have different sizes" in
-    let full = Format.asprintf "%a VS %a" PP.type_value a PP.type_value b in
-    error title full
+  let different_size_type name a b () =
+    let title () = name ^ " have different sizes" in
+    let full () = Format.asprintf "%a VS %a" PP.type_value a PP.type_value b in
+    error title full ()
 
   let different_size_constants = different_size_type "constants"
 
@@ -275,7 +275,7 @@ open Errors
 let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = match (a.type_value', b.type_value') with
   | T_tuple ta, T_tuple tb -> (
       let%bind _ =
-        trace_strong (different_size_tuples a b)
+        trace_strong (fun () -> (different_size_tuples a b ()))
         @@ Assert.assert_true List.(length ta = length tb) in
       bind_list_iter assert_type_value_eq (List.combine ta tb)
     )
@@ -287,7 +287,7 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
       let%bind _ =
         trace_strong (different_constants ca cb)
         @@ Assert.assert_true (ca = cb) in
-      trace (simple_error "constant sub-expression")
+      trace (fun () -> simple_error (thunk "constant sub-expression") ())
       @@ bind_list_iter assert_type_value_eq (List.combine lsta lstb)
     )
   | T_constant _, _ -> fail @@ different_kinds a b
@@ -296,14 +296,14 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
       let sb' = SMap.to_kv_list sb in
       let aux ((ka, va), (kb, vb)) =
         let%bind _ =
-          Assert.assert_true ~msg:"different keys in sum types"
+          Assert.assert_true ~msg:(thunk "different keys in sum types")
           @@ (ka = kb) in
         assert_type_value_eq (va, vb)
       in
       let%bind _ =
         trace_strong (different_size_sums a b)
         @@ Assert.assert_list_same_size sa' sb' in
-      trace (simple_error "sum type") @@
+      trace (simple_error (thunk "sum type")) @@
       bind_list_iter aux (List.combine sa' sb')
 
     )
@@ -313,14 +313,14 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
       let rb' = SMap.to_kv_list rb in
       let aux ((ka, va), (kb, vb)) =
         let%bind _ =
-          Assert.assert_true ~msg:"different keys in record types"
+          Assert.assert_true ~msg:(thunk "different keys in record types")
           @@ (ka = kb) in
         assert_type_value_eq (va, vb)
       in
       let%bind _ =
         trace_strong (different_size_records a b)
         @@ Assert.assert_list_same_size ra' rb' in
-      trace (simple_error "record type")
+      trace (simple_error (thunk "record type"))
       @@ bind_list_iter aux (List.combine ra' rb')
 
     )
@@ -339,82 +339,82 @@ let type_value_eq ab = match assert_type_value_eq ab with
 let assert_literal_eq (a, b : literal * literal) : unit result =
   match (a, b) with
   | Literal_bool a, Literal_bool b when a = b -> ok ()
-  | Literal_bool _, Literal_bool _ -> simple_fail "different bools"
-  | Literal_bool _, _ -> simple_fail "bool vs non-bool"
+  | Literal_bool _, Literal_bool _ -> simple_fail (thunk "different bools")
+  | Literal_bool _, _ -> simple_fail (thunk "bool vs non-bool")
   | Literal_int a, Literal_int b when a = b -> ok ()
-  | Literal_int _, Literal_int _ -> simple_fail "different ints"
-  | Literal_int _, _ -> simple_fail "int vs non-int"
+  | Literal_int _, Literal_int _ -> simple_fail (thunk "different ints")
+  | Literal_int _, _ -> simple_fail (thunk "int vs non-int")
   | Literal_nat a, Literal_nat b when a = b -> ok ()
-  | Literal_nat _, Literal_nat _ -> simple_fail "different nats"
-  | Literal_nat _, _ -> simple_fail "nat vs non-nat"
+  | Literal_nat _, Literal_nat _ -> simple_fail (thunk "different nats")
+  | Literal_nat _, _ -> simple_fail (thunk "nat vs non-nat")
   | Literal_string a, Literal_string b when a = b -> ok ()
-  | Literal_string _, Literal_string _ -> simple_fail "different strings"
-  | Literal_string _, _ -> simple_fail "string vs non-string"
+  | Literal_string _, Literal_string _ -> simple_fail (thunk "different strings")
+  | Literal_string _, _ -> simple_fail (thunk "string vs non-string")
   | Literal_bytes a, Literal_bytes b when a = b -> ok ()
-  | Literal_bytes _, Literal_bytes _ -> simple_fail "different bytess"
-  | Literal_bytes _, _ -> simple_fail "bytes vs non-bytes"
+  | Literal_bytes _, Literal_bytes _ -> simple_fail (thunk "different bytess")
+  | Literal_bytes _, _ -> simple_fail (thunk "bytes vs non-bytes")
   | Literal_unit, Literal_unit -> ok ()
-  | Literal_unit, _ -> simple_fail "unit vs non-unit"
+  | Literal_unit, _ -> simple_fail (thunk "unit vs non-unit")
 
 
 let rec assert_value_eq (a, b: (value*value)) : unit result =
-  let error_content =
+  let error_content () =
     Format.asprintf "%a vs %a" PP.value a PP.value b
   in
-  trace (error "not equal" error_content) @@
+  trace (fun () -> error (thunk "not equal") error_content ()) @@
   match (a.expression, b.expression) with
   | E_literal a, E_literal b ->
       assert_literal_eq (a, b)
   | E_constant (ca, lsta), E_constant (cb, lstb) when ca = cb -> (
       let%bind lst =
-        generic_try (simple_error "constants with different number of elements")
+        generic_try (fun () -> simple_error (thunk "constants with different number of elements") ())
           (fun () -> List.combine lsta lstb) in
       let%bind _all = bind_list @@ List.map assert_value_eq lst in
       ok ()
     )
   | E_constant _, E_constant _ ->
-      simple_fail "different constants"
+      simple_fail (thunk "different constants")
   | E_constant _, _ ->
-      let error_content =
+      let error_content () =
         Format.asprintf "%a vs %a"
           PP.annotated_expression a
           PP.annotated_expression b
       in
-      fail @@ error "comparing constant with other stuff" error_content
+      fail @@ (fun () -> error (thunk "comparing constant with other stuff") error_content ())
 
   | E_constructor (ca, a), E_constructor (cb, b) when ca = cb -> (
       let%bind _eq = assert_value_eq (a, b) in
       ok ()
     )
   | E_constructor _, E_constructor _ ->
-      simple_fail "different constructors"
+      simple_fail (thunk "different constructors")
   | E_constructor _, _ ->
-      simple_fail "comparing constructor with other stuff"
+      simple_fail (thunk "comparing constructor with other stuff")
 
   | E_tuple lsta, E_tuple lstb -> (
       let%bind lst =
-        generic_try (simple_error "tuples with different number of elements")
+        generic_try (fun () -> simple_error (thunk "tuples with different number of elements") ())
           (fun () -> List.combine lsta lstb) in
       let%bind _all = bind_list @@ List.map assert_value_eq lst in
       ok ()
     )
   | E_tuple _, _ ->
-      simple_fail "comparing tuple with other stuff"
+      simple_fail (thunk "comparing tuple with other stuff")
 
   | E_record sma, E_record smb -> (
       let aux _ a b =
         match a, b with
         | Some a, Some b -> Some (assert_value_eq (a, b))
-        | _ -> Some (simple_fail "different record keys")
+        | _ -> Some (simple_fail (thunk "different record keys"))
       in
       let%bind _all = bind_smap @@ SMap.merge aux sma smb in
       ok ()
     )
   | E_record _, _ ->
-      simple_fail "comparing record with other stuff"
+      simple_fail (thunk "comparing record with other stuff")
 
   | E_map lsta, E_map lstb -> (
-      let%bind lst = generic_try (simple_error "maps of different lengths")
+      let%bind lst = generic_try (fun () -> simple_error (thunk "maps of different lengths") ())
           (fun () ->
              let lsta' = List.sort compare lsta in
              let lstb' = List.sort compare lstb in
@@ -427,13 +427,13 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
       ok ()
     )
   | E_map _, _ ->
-      simple_fail "comparing map with other stuff"
+      simple_fail (thunk "comparing map with other stuff")
 
-  | _, _ -> simple_fail "comparing not a value"
+  | _, _ -> simple_fail (thunk "comparing not a value")
 
 let merge_annotation (a:type_value option) (b:type_value option) : type_value result =
   match a, b with
-  | None, None -> simple_fail "no annotation"
+  | None, None -> simple_fail (thunk "no annotation")
   | Some a, None -> ok a
   | None, Some b -> ok b
   | Some a, Some b ->
@@ -476,44 +476,44 @@ module Combinators = struct
 
   let get_t_bool (t:type_value) : unit result = match t.type_value' with
     | T_constant ("bool", []) -> ok ()
-    | _ -> simple_fail "not a bool"
+    | _ -> simple_fail (thunk "not a bool")
 
   let get_t_option (t:type_value) : type_value result = match t.type_value' with
     | T_constant ("option", [o]) -> ok o
-    | _ -> simple_fail "not a option"
+    | _ -> simple_fail (thunk "not a option")
 
   let get_t_list (t:type_value) : type_value result = match t.type_value' with
     | T_constant ("list", [o]) -> ok o
-    | _ -> simple_fail "not a list"
+    | _ -> simple_fail (thunk "not a list")
 
   let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with
     | T_tuple lst -> ok lst
-    | _ -> simple_fail "not a tuple"
+    | _ -> simple_fail (thunk "not a tuple")
 
   let get_t_sum (t:type_value) : type_value SMap.t result = match t.type_value' with
     | T_sum m -> ok m
-    | _ -> simple_fail "not a sum"
+    | _ -> simple_fail (thunk "not a sum")
 
   let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value' with
     | T_record m -> ok m
-    | _ -> simple_fail "not a record"
+    | _ -> simple_fail (thunk "not a record")
 
   let get_t_map (t:type_value) : (type_value * type_value) result =
     match t.type_value' with
     | T_constant ("map", [k;v]) -> ok (k, v)
-    | _ -> simple_fail "not a map"
+    | _ -> simple_fail (thunk "not a map")
   let assert_t_map (t:type_value) : unit result =
     match t.type_value' with
     | T_constant ("map", [_ ; _]) -> ok ()
-    | _ -> simple_fail "not a map"
+    | _ -> simple_fail (thunk "not a map")
 
   let assert_t_int : type_value -> unit result = fun t -> match t.type_value' with
     | T_constant ("int", []) -> ok ()
-    | _ -> simple_fail "not an int"
+    | _ -> simple_fail (thunk "not an int")
 
   let assert_t_nat : type_value -> unit result = fun t -> match t.type_value' with
     | T_constant ("nat", []) -> ok ()
-    | _ -> simple_fail "not an nat"
+    | _ -> simple_fail (thunk "not an nat")
 
   let e_record map : expression = E_record map
   let ez_e_record (lst : (string * ae) list) : expression =
@@ -548,15 +548,15 @@ module Combinators = struct
   let get_a_int (t:annotated_expression) =
     match t.expression with
     | E_literal (Literal_int n) -> ok n
-    | _ -> simple_fail "not an int"
+    | _ -> simple_fail (thunk "not an int")
 
   let get_a_unit (t:annotated_expression) =
     match t.expression with
     | E_literal (Literal_unit) -> ok ()
-    | _ -> simple_fail "not a unit"
+    | _ -> simple_fail (thunk "not a unit")
 
   let get_a_bool (t:annotated_expression) =
     match t.expression with
     | E_literal (Literal_bool b) -> ok b
-    | _ -> simple_fail "not a bool"
+    | _ -> simple_fail (thunk "not a bool")
 end

src/ligo/ligo.ml

@@ -23,24 +23,24 @@ let parse_file (source: string) : AST_Raw.t result =
   let%bind () = sys_command cpp_cmd in
 
   let%bind channel =
-    generic_try (simple_error "error opening file") @@
+    generic_try (fun () -> simple_error (thunk "error opening file") ()) @@
     (fun () -> open_in pp_input) in
   let lexbuf = Lexing.from_channel channel in
   let module Lexer = Lexer.Make(LexToken) in
   let Lexer.{read ; close} =
     Lexer.open_token_stream None in
-  specific_try (function
+  specific_try (fun () -> function
       | Parser.Error -> (
           let start = Lexing.lexeme_start_p lexbuf in
           let end_ = Lexing.lexeme_end_p lexbuf in
-          let str = Format.sprintf
+          let str () = Format.sprintf
               "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
               (Lexing.lexeme lexbuf)
               start.pos_lnum (start.pos_cnum - start.pos_bol)
               end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
           simple_error str
         )
-      | _ -> simple_error "unrecognized parse_ error"
+      | _ -> simple_error (thunk "unrecognized parse_ error")
     ) @@ (fun () ->
       let raw = Parser.contract read lexbuf in
       close () ;
@@ -53,18 +53,18 @@ let parse (s:string) : AST_Raw.t result =
   let module Lexer = Lexer.Make(LexToken) in
   let Lexer.{read ; close} =
     Lexer.open_token_stream None in
-  specific_try (function
+  specific_try (fun () -> function
       | Parser.Error -> (
           let start = Lexing.lexeme_start_p lexbuf in
           let end_ = Lexing.lexeme_end_p lexbuf in
-          let str = Format.sprintf
+          let str () = Format.sprintf
               "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
               (Lexing.lexeme lexbuf)
               start.pos_lnum (start.pos_cnum - start.pos_bol)
               end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
           simple_error str
         )
-      | _ -> simple_error "unrecognized parse_ error"
+      | _ -> simple_error (thunk "unrecognized parse_ error")
     ) @@ (fun () ->
       let raw = Parser.contract read lexbuf in
       close () ;
@@ -77,18 +77,18 @@ let parse_expression (s:string) : AST_Raw.expr result =
   let module Lexer = Lexer.Make(LexToken) in
   let Lexer.{read ; close} =
     Lexer.open_token_stream None in
-  specific_try (function
+  specific_try (fun () -> function
       | Parser.Error -> (
           let start = Lexing.lexeme_start_p lexbuf in
           let end_ = Lexing.lexeme_end_p lexbuf in
-          let str = Format.sprintf
+          let str () = Format.sprintf
               "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
               (Lexing.lexeme lexbuf)
               start.pos_lnum (start.pos_cnum - start.pos_bol)
               end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
           simple_error str
         )
-      | _ -> simple_error "unrecognized parse_ error"
+      | _ -> simple_error (thunk "unrecognized parse_ error")
     ) @@ (fun () ->
       let raw = Parser.interactive_expr read lexbuf in
       close () ;
@@ -131,13 +131,13 @@ let type_file ?(debug_simplify = false) ?(debug_typed = false)
     (path:string) : AST_Typed.program result =
   let%bind raw = parse_file path in
   let%bind simpl =
-    trace (simple_error "simplifying") @@
+    trace (fun () -> simple_error (thunk "simplifying") ()) @@
     simplify raw in
   (if debug_simplify then
      Format.(printf "Simplified : %a\n%!" AST_Simplified.PP.program simpl)
   ) ;
   let%bind typed =
-    trace (simple_error "typing") @@
+    trace (fun () -> simple_error (thunk "typing") ()) @@
     type_ simpl in
   (if debug_typed then (
       Format.(printf "Typed : %a\n%!" AST_Typed.PP.program typed)
@@ -155,13 +155,13 @@ let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.a
     untranspile_value result typed_main.type_annotation in
   ok typed_result
 
-let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed "easy evaluate typed"
+let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed")
 
 let easy_run_typed
     ?(debug_mini_c = false) (entry:string)
     (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result =
   let%bind mini_c_main =
-    trace (simple_error "transpile mini_c entry") @@
+    trace (fun () -> simple_error (thunk "transpile mini_c entry") ()) @@
     transpile_entry program entry in
   (if debug_mini_c then
      Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content)
@@ -170,14 +170,14 @@ let easy_run_typed
   let%bind mini_c_value = transpile_value input in
 
   let%bind mini_c_result =
-    trace (simple_error "run mini_c") @@
+    trace (fun () -> simple_error (thunk "run mini_c") ()) @@
     Mini_c.Run.run_entry mini_c_main mini_c_value in
   let%bind typed_result =
     let%bind main_result_type =
       let%bind typed_main = Ast_typed.get_functional_entry program entry in
       match (snd typed_main).type_value' with
       | T_function (_, result) -> ok result
-      | _ -> simple_fail "main doesn't have fun type" in
+      | _ -> simple_fail (thunk "main doesn't have fun type") in
     untranspile_value mini_c_result main_result_type in
   ok typed_result
 

src/ligo/mini_c/combinators.ml

@@ -3,69 +3,69 @@ open Types
 
 let get_bool (v:value) = match v with
   | D_bool b -> ok b
-  | _ -> simple_fail "not a bool"
+  | _ -> simple_fail (thunk "not a bool")
 
 let get_int (v:value) = match v with
   | D_int n -> ok n
-  | _ -> simple_fail "not an int"
+  | _ -> simple_fail (thunk "not an int")
 
 let get_nat (v:value) = match v with
   | D_nat n -> ok n
-  | _ -> simple_fail "not a nat"
+  | _ -> simple_fail (thunk "not a nat")
 
 let get_string (v:value) = match v with
   | D_string s -> ok s
-  | _ -> simple_fail "not a string"
+  | _ -> simple_fail (thunk "not a string")
 
 let get_bytes (v:value) = match v with
   | D_bytes b -> ok b
-  | _ -> simple_fail "not a bytes"
+  | _ -> simple_fail (thunk "not a bytes")
 
 let get_unit (v:value) = match v with
   | D_unit -> ok ()
-  | _ -> simple_fail "not a unit"
+  | _ -> simple_fail (thunk "not a unit")
 
 let get_option (v:value) = match v with
   | D_none -> ok None
   | D_some s -> ok (Some s)
-  | _ -> simple_fail "not an option"
+  | _ -> simple_fail (thunk "not an option")
 
 let get_map (v:value) = match v with
   | D_map lst -> ok lst
-  | _ -> simple_fail "not a map"
+  | _ -> simple_fail (thunk "not a map")
 
 let get_t_option (v:type_value) = match v with
   | T_option t -> ok t
-  | _ -> simple_fail "not an option"
+  | _ -> simple_fail (thunk "not an option")
 
 let get_pair (v:value) = match v with
   | D_pair (a, b) -> ok (a, b)
-  | _ -> simple_fail "not a pair"
+  | _ -> simple_fail (thunk "not a pair")
 
 let get_t_pair (t:type_value) = match t with
   | T_pair (a, b) -> ok (a, b)
-  | _ -> simple_fail "not a type pair"
+  | _ -> simple_fail (thunk "not a type pair")
 
 let get_t_map (t:type_value) = match t with
   | T_map kv -> ok kv
-  | _ -> simple_fail "not a type map"
+  | _ -> simple_fail (thunk "not a type map")
 
 let get_left (v:value) = match v with
   | D_left b -> ok b
-  | _ -> simple_fail "not a left"
+  | _ -> simple_fail (thunk "not a left")
 
 let get_right (v:value) = match v with
   | D_right b -> ok b
-  | _ -> simple_fail "not a right"
+  | _ -> simple_fail (thunk "not a right")
 
 let get_or (v:value) = match v with
   | D_left b -> ok (false, b)
   | D_right b -> ok (true, b)
-  | _ -> simple_fail "not a left/right"
+  | _ -> simple_fail (thunk "not a left/right")
 
 let get_last_statement ((b', _):block) : statement result =
   let aux lst = match lst with
-    | [] -> simple_fail "get_last: empty list"
+    | [] -> simple_fail (thunk "get_last: empty list")
     | lst -> ok List.(nth lst (length lst - 1)) in
   aux b'
 
@@ -109,7 +109,7 @@ let statement s' e : statement =
 
 let block (statements:statement list) : block result =
   match statements with
-  | [] -> simple_fail "no statements in block"
+  | [] -> simple_fail (thunk "no statements in block")
   | lst ->
       let first = List.hd lst in
       let last = List.(nth lst (length lst - 1)) in

src/ligo/mini_c/compiler.ml

@@ -56,12 +56,12 @@ let rec get_predicate : string -> expression list -> predicate result = fun s ls
         | [ _ ; (_, m, _) ] ->
             let%bind (_, v) = Combinators.get_t_map m in
             ok v
-        | _ -> simple_fail "mini_c . MAP_REMOVE" in
+        | _ -> simple_fail (thunk "mini_c . MAP_REMOVE") in
       let%bind v_ty = Compiler_type.type_ v in
       ok @@ simple_binary @@ seq [dip (i_none v_ty) ; prim I_UPDATE ]
   | "MAP_UPDATE" ->
       ok @@ simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]
-  | x -> simple_fail @@ "predicate \"" ^ x ^ "\" doesn't exist"
+  | x -> simple_fail @@ (fun () -> "predicate \"" ^ x ^ "\" doesn't exist")
 
 and translate_value (v:value) : michelson result = match v with
   | D_bool b -> ok @@ prim (if b then D_True else D_False)
@@ -102,11 +102,13 @@ and translate_function ({capture;content}:anon_function) : michelson result =
       let%bind body = translate_function_body content in
       let%bind capture_m = translate_value value in
       ok @@ d_pair capture_m body
-  | _ -> simple_fail "translating closure without capture"
+  | _ -> simple_fail (thunk "translating closure without capture")
 
 and translate_expression ((expr', ty, env) as expr:expression) : michelson result =
-  let error_message = Format.asprintf  "%a" PP.expression expr in
-  let%bind (code : michelson) = trace (error "translating expression" error_message) @@ match expr' with
+  let error_message () = Format.asprintf  "%a" PP.expression expr in
+  let%bind (code : michelson) =
+    trace (fun () -> error (thunk "translating expression") error_message ()) @@
+    match expr' with
     | E_literal v ->
         let%bind v = translate_value v in
         let%bind t = Compiler_type.type_ ty in
@@ -153,7 +155,7 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul
               i_pair ; (* expr :: env *)
             ]
           )
-        | _ -> simple_fail "E_applicationing something not appliable"
+        | _ -> simple_fail (thunk "E_applicationing something not appliable")
       )
     | E_variable x ->
         let%bind (get, _) = Environment.to_michelson_get env x in
@@ -169,7 +171,7 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul
           | Unary f, 1 -> ok (seq @@ lst' @ [f])
           | Binary f, 2 -> ok (seq @@ lst' @ [f])
           | Ternary f, 3 -> ok (seq @@ lst' @ [f])
-          | _ -> simple_fail "bad arity"
+          | _ -> simple_fail (thunk "bad arity")
         in
         ok code
     | E_empty_map sd ->
@@ -224,7 +226,7 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul
                 i_pair ;
               ] in
             ok code
-        | _ -> simple_fail "expected function code"
+        | _ -> simple_fail (thunk "expected function code")
       )
     | E_Cond (c, a, b) -> (
         let%bind c' = translate_expression c in
@@ -242,12 +244,12 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul
     let%bind (Ex_ty schema_ty) = Environment.to_ty env in
     let%bind output_type = Compiler_type.type_ ty in
     let%bind (Ex_ty output_ty) =
-      let error_message = Format.asprintf "%a" Michelson.pp output_type in
-      Trace.trace_tzresult_lwt (error "error parsing output ty" error_message) @@
+      let error_message () = Format.asprintf "%a" Michelson.pp output_type in
+      Trace.trace_tzresult_lwt (fun () -> error (thunk "error parsing output ty") error_message ()) @@
       Tezos_utils.Memory_proto_alpha.parse_michelson_ty output_type in
     let input_stack_ty = Stack.(Contract_types.unit @: schema_ty @: nil) in
     let output_stack_ty = Stack.(Contract_types.(pair output_ty unit) @: schema_ty @: nil) in
-    let%bind error_message =
+    let error_message () =
       let%bind schema_michelson = Environment.to_michelson_type env in
       ok @@ Format.asprintf
         "expression : %a\ncode : %a\nschema type : %a\noutput type : %a"
@@ -257,7 +259,12 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul
         Michelson.pp output_type
     in
     let%bind _ =
-      Trace.trace_tzresult_lwt (error "error parsing expression code" error_message) @@
+      Trace.trace_tzresult_lwt_r
+        (fun () ->
+           let%bind error_message = error_message () in
+           ok @@ (fun () -> error (thunk "error parsing expression code")
+                                  (fun () -> error_message)
+                                  ())) @@
       Tezos_utils.Memory_proto_alpha.parse_michelson code
         input_stack_ty output_stack_ty
     in
@@ -267,9 +274,9 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul
   ok code
 
 and translate_statement ((s', w_env) as s:statement) : michelson result =
-  let error_message = Format.asprintf "%a" PP.statement s in
+  let error_message () = Format.asprintf "%a" PP.statement s in
   let%bind (code : michelson) =
-    trace (error "translating statement" error_message) @@ match s' with
+    trace (fun () -> error (thunk "translating statement") error_message ()) @@ match s' with
     | Assignment (s, ((_, tv, _) as expr)) ->
         let%bind expr = translate_expression expr in
         let%bind add =
@@ -341,7 +348,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
     let input_stack_ty = Stack.(pre_ty @: nil) in
     let%bind (Ex_ty post_ty) = Environment.to_ty w_env.post_environment in
     let output_stack_ty = Stack.(post_ty @: nil) in
-    let%bind error_message =
+    let error_message () =
       let%bind pre_env_michelson = Environment.to_michelson_type w_env.pre_environment in
       let%bind post_env_michelson = Environment.to_michelson_type w_env.post_environment in
       ok @@ Format.asprintf
@@ -352,7 +359,10 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
         Michelson.pp post_env_michelson
     in
     let%bind _ =
-      Trace.trace_tzresult_lwt (error "error parsing statement code" error_message) @@
+      Trace.trace_tzresult_lwt_r (fun () -> let%bind error_message = error_message () in
+                                   ok (fun () -> error (thunk "error parsing statement code")
+                                                 (fun () -> error_message)
+                                                 ())) @@
       Tezos_utils.Memory_proto_alpha.parse_michelson code
         input_stack_ty output_stack_ty
     in
@@ -368,14 +378,18 @@ and translate_regular_block ((b, env):block) : michelson result =
     let%bind instruction = translate_statement statement in
     ok (instruction :: lst)
   in
-  let%bind error_message =
+  let error_message () =
     let%bind schema_michelson = Environment.to_michelson_type env.pre_environment in
     ok @@ Format.asprintf "\nblock : %a\nschema : %a\n"
       PP.block (b, env)
       Tezos_utils.Micheline.Michelson.pp schema_michelson
   in
   let%bind codes =
-    trace (error "error translating block" error_message) @@
+    trace_r (fun () ->
+        let%bind error_message = error_message () in
+        ok (fun () -> error (thunk "error translating block")
+                      (fun () -> error_message)
+                      ())) @@
     List.fold_left aux (ok []) b in
   let code = seq (List.rev codes) in
   ok code
@@ -394,13 +408,15 @@ and translate_function_body ({body;result} as f:anon_function_content) : michels
     let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ f.output in
     let input_stack_ty = Stack.(input_ty @: nil) in
     let output_stack_ty = Stack.(output_ty @: nil) in
-    let%bind error_message =
-      ok @@ Format.asprintf
+    let error_message () =
+      Format.asprintf
         "\ncode : %a\n"
         Tezos_utils.Micheline.Michelson.pp code
     in
     let%bind _ =
-      Trace.trace_tzresult_lwt (error "error parsing function code" error_message) @@
+      Trace.trace_tzresult_lwt (fun () -> error (thunk "error parsing function code")
+                                                error_message
+                                                ()) @@
       Tezos_utils.Memory_proto_alpha.parse_michelson code
         input_stack_ty output_stack_ty
     in
@@ -420,7 +436,7 @@ let translate_program (p:program) (entry:string) : compiled_program result =
     | name , (E_function f, T_function (_, _), _) when f.capture_type = No_capture && name = entry -> Some f
     | _ -> None in
   let%bind main =
-    trace_option (simple_error "no functional entry") @@
+    trace_option (fun () -> simple_error (thunk "no functional entry") ()) @@
     Tezos_utils.List.find_map is_main p in
   let {input;output} : anon_function_content = main in
   let%bind body = translate_function_body main in

src/ligo/mini_c/compiler_environment.ml

@@ -49,7 +49,7 @@ module Small = struct
   let rec get_path' = fun s env' ->
     match env' with
     | Leaf (n, v) when n = s -> ok ([], v)
-    | Leaf _ -> simple_fail "Not in env"
+    | Leaf _ -> simple_fail (thunk "Not in env")
     | Node {a;b} ->
         match%bind bind_lr @@ Tezos_utils.Tuple.map2 (get_path' s) (a,b) with
         | `Left (lst, v) -> ok ((`Left :: lst), v)
@@ -57,31 +57,31 @@ module Small = struct
 
   let get_path = fun s env ->
     match env with
-    | Empty -> simple_fail "Set : No env"
+    | Empty -> simple_fail (thunk "Set : No env")
     | Full x -> get_path' s x
 
   let rec to_michelson_get' s = function
     | Leaf (n, tv) when n = s -> ok @@ (seq [], tv)
-    | Leaf _ -> simple_fail "Schema.Small.get : not in env"
+    | Leaf _ -> simple_fail (thunk "Schema.Small.get : not in env")
     | Node {a;b} -> (
         match%bind bind_lr @@ Tezos_utils.Tuple.map2 (to_michelson_get' s) (a, b) with
         | `Left (x, tv) -> ok @@ (seq [i_car ; x], tv)
         | `Right (x, tv) -> ok @@ (seq [i_cdr ; x], tv)
       )
   let to_michelson_get s = function
-    | Empty -> simple_fail "Schema.Small.get : not in env"
+    | Empty -> simple_fail (thunk "Schema.Small.get : not in env")
     | Full x -> to_michelson_get' s x
 
   let rec to_michelson_set' s = function
     | Leaf (n, tv) when n = s -> ok (dip i_drop, tv)
-    | Leaf _ -> simple_fail "Schema.Small.set : not in env"
+    | Leaf _ -> simple_fail (thunk "Schema.Small.set : not in env")
     | Node {a;b} -> (
         match%bind bind_lr @@ Tezos_utils.Tuple.map2 (to_michelson_set' s) (a, b) with
         | `Left (x, tv) -> ok (seq [dip i_unpair ; x ; i_pair], tv)
         | `Right (x, tv) -> ok (seq [dip i_unpiar ; x ; i_piar], tv)
       )
   let to_michelson_set s = function
-    | Empty -> simple_fail "Schema.Small.set : not in env"
+    | Empty -> simple_fail (thunk "Schema.Small.set : not in env")
     | Full x -> to_michelson_set' s x
 
   let rec to_michelson_append' = function
@@ -104,7 +104,7 @@ module Small = struct
         ok (E_constant ("PAIR", [a;b]), (T_pair(ty_a, ty_b) : type_value), env)
 
   let to_mini_c_capture env = function
-    | Empty -> simple_fail "to_mini_c_capture"
+    | Empty -> simple_fail (thunk "to_mini_c_capture")
     | Full x -> to_mini_c_capture' env x
 
   let rec to_mini_c_type' : _ -> type_value = function
@@ -159,7 +159,7 @@ let to_mini_c_capture = function
 
 let rec get_path : string -> environment -> ([`Left | `Right] list * type_value) result = fun s t ->
   match t with
-  | [] -> simple_fail "Get path : empty big schema"
+  | [] -> simple_fail (thunk "Get path : empty big schema")
   | [ x ] -> Small.get_path s x
   | hd :: tl -> (
       match%bind bind_lr_lazy (Small.get_path s hd, (fun () -> get_path s tl)) with
@@ -185,7 +185,7 @@ let path_to_michelson_set = fun path ->
 
 let to_michelson_anonymous_add (t:t) =
   let%bind code = match t with
-    | [] -> simple_fail "Schema.Big.Add.to_michelson_add"
+    | [] -> simple_fail (thunk "Schema.Big.Add.to_michelson_add")
     | [hd] -> Small.to_michelson_append hd
     | hd :: _ -> (
         let%bind code = Small.to_michelson_append hd in
@@ -196,7 +196,7 @@ let to_michelson_anonymous_add (t:t) =
 
 let to_michelson_add x (t:t) =
   let%bind code = match t with
-    | [] -> simple_fail "Schema.Big.Add.to_michelson_add"
+    | [] -> simple_fail (thunk "Schema.Big.Add.to_michelson_add")
     | [hd] -> Small.to_michelson_append hd
     | hd :: _ -> (
         let%bind code = Small.to_michelson_append hd in
@@ -211,13 +211,13 @@ let to_michelson_add x (t:t) =
     let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ (snd x) in
     let input_stack_ty = Stack.(input_ty @: schema_ty @: nil) in
     let output_stack_ty = Stack.(new_schema_ty @: nil) in
-    let error_message = Format.asprintf
+    let error_message () = Format.asprintf
         "\nold : %a\nnew : %a\ncode : %a\n"
         PP.environment t
         PP.environment new_schema
         Tezos_utils.Micheline.Michelson.pp code in
     let%bind _ =
-      trace_tzresult_lwt (error "error parsing Schema.Big.to_michelson_add code" error_message) @@
+      trace_tzresult_lwt (fun () -> error (thunk "error parsing Schema.Big.to_michelson_add code") error_message ()) @@
       Tezos_utils.Memory_proto_alpha.parse_michelson code
         input_stack_ty output_stack_ty in
     ok ()
@@ -228,7 +228,7 @@ let to_michelson_add x (t:t) =
 let to_michelson_get (s:t) str : (Michelson.t * type_value) result =
   let open Michelson in
   let rec aux s str : (Michelson.t * type_value) result  = match s with
-    | [] -> simple_fail "Schema.Big.get"
+    | [] -> simple_fail (thunk "Schema.Big.get")
     | [a] -> Small.to_michelson_get str a
     | a :: b -> (
         match Small.to_michelson_get str a with
@@ -246,14 +246,14 @@ let to_michelson_get (s:t) str : (Michelson.t * type_value) result =
     let%bind (Ex_ty ty) = Compiler_type.Ty.type_ tv in
     let input_stack_ty = Stack.(schema_ty @: nil) in
     let output_stack_ty = Stack.(ty @: nil) in
-    let%bind error_message =
-      ok @@ Format.asprintf
+    let error_message () =
+      Format.asprintf
         "\ncode : %a\nschema type : %a"
         Tezos_utils.Micheline.Michelson.pp code
         Tezos_utils.Micheline.Michelson.pp schema_michelson
     in
     let%bind _ =
-      trace_tzresult_lwt (error "error parsing big.get code" error_message) @@
+      trace_tzresult_lwt (fun () -> error (thunk "error parsing big.get code") error_message ()) @@
       Tezos_utils.Memory_proto_alpha.parse_michelson code
         input_stack_ty output_stack_ty
     in
@@ -266,7 +266,7 @@ let to_michelson_set str (s:t) : Michelson.t result =
   let open Michelson in
   let rec aux s str : (Michelson.t * type_value) result =
     match s with
-    | [] -> simple_fail "Schema.Big.get"
+    | [] -> simple_fail (thunk "Schema.Big.get")
     | [a] -> Small.to_michelson_set str a
     | a :: b -> (
         match Small.to_michelson_set str a with
@@ -284,15 +284,15 @@ let to_michelson_set str (s:t) : Michelson.t result =
     let%bind (Ex_ty ty) = Compiler_type.Ty.type_ tv in
     let input_stack_ty = Stack.(ty @: schema_ty @: nil) in
     let output_stack_ty = Stack.(schema_ty @: nil) in
-    let%bind error_message =
-      ok @@ Format.asprintf
+    let error_message () =
+      Format.asprintf
         "\ncode : %a\nschema : %a\nschema type : %a"
         Tezos_utils.Micheline.Michelson.pp code
         PP.environment s
         Tezos_utils.Micheline.Michelson.pp schema_michelson
     in
     let%bind _ =
-      Trace.trace_tzresult_lwt (error "error parsing big.set code" error_message) @@
+      Trace.trace_tzresult_lwt (fun () -> error (thunk "error parsing big.set code") error_message ()) @@
       Tezos_utils.Memory_proto_alpha.parse_michelson code
         input_stack_ty output_stack_ty
     in

src/ligo/mini_c/compiler_type.ml

@@ -9,7 +9,7 @@ module Contract_types = Meta_michelson.Types
 
 module Ty = struct
 
-  let not_comparable name = error "not a comparable type" name
+  let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
 
   let comparable_type_base : type_base -> ex_comparable_ty result = fun tb ->
     let open Contract_types in
@@ -93,7 +93,7 @@ module Ty = struct
     | Full x -> environment_small' x
 
   and environment = function
-    | [] -> simple_fail "Schema.Big.to_ty"
+    | [] -> simple_fail (thunk "Schema.Big.to_ty")
     | [a] -> environment_small a
     | a::b ->
         let%bind (Ex_ty a) = environment_small a in
@@ -162,7 +162,7 @@ and environment_small = function
 
 and environment =
   function
-  | [] -> simple_fail "Schema.Big.to_michelson_type"
+  | [] -> simple_fail (thunk "Schema.Big.to_michelson_type")
   | [a] -> environment_small a
   | a :: b ->
       let%bind a = environment_small a in

src/ligo/mini_c/run.ml

@@ -8,16 +8,16 @@ let run_aux (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_
   let (Ex_ty input_ty) = input in
   let (Ex_ty output_ty) = output in
   let%bind input =
-    Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
+    Trace.trace_tzresult_lwt (fun () -> simple_error (thunk "error parsing input") ()) @@
     Tezos_utils.Memory_proto_alpha.parse_michelson_data input_michelson input_ty in
   let body = Michelson.strip_annots body in
   let%bind descr =
-    Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
+    Trace.trace_tzresult_lwt (fun () -> simple_error (thunk "error parsing program code") ()) @@
     Tezos_utils.Memory_proto_alpha.parse_michelson body
       (Stack.(input_ty @: nil)) (Stack.(output_ty @: nil)) in
   let open! Memory_proto_alpha.Script_interpreter in
   let%bind (Item(output, Empty)) =
-    Trace.trace_tzresult_lwt (simple_error "error of execution") @@
+    Trace.trace_tzresult_lwt (fun () -> simple_error (thunk "error of execution") ()) @@
     Tezos_utils.Memory_proto_alpha.interpret descr (Item(input, Empty)) in
   ok (Ex_typed_value (output_ty, output))
 
@@ -25,7 +25,7 @@ let run_node (program:program) (input:Michelson.t) : Michelson.t result =
   let%bind compiled = translate_program program "main" in
   let%bind (Ex_typed_value (output_ty, output)) = run_aux compiled input in
   let%bind output =
-    Trace.trace_tzresult_lwt (simple_error "error unparsing output") @@
+    Trace.trace_tzresult_lwt (fun () -> simple_error (thunk "error unparsing output") ()) @@
     Tezos_utils.Memory_proto_alpha.unparse_michelson_data output_ty output in
   ok output
 
@@ -47,5 +47,5 @@ let expression_to_value ((e', _, _) as e:expression) : value result =
   match e' with
   | E_literal v -> ok v
   | _ -> fail
-      @@ error "not a value"
-      @@ Format.asprintf "%a" PP.expression e
+      @@ error (thunk "not a value")
+      @@ (fun () -> Format.asprintf "%a" PP.expression e)

src/ligo/mini_c/uncompiler.ml

@@ -21,12 +21,12 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result =
     )
   | (Int_t _), n ->
       let%bind n =
-        trace_option (simple_error "too big to fit an int") @@
+        trace_option (fun () -> simple_error (thunk "too big to fit an int") ()) @@
         Alpha_context.Script_int.to_int n in
       ok @@ D_int n
   | (Nat_t _), n ->
       let%bind n =
-        trace_option (simple_error "too big to fit an int") @@
+        trace_option (fun () -> simple_error (thunk "too big to fit an int") ()) @@
         Alpha_context.Script_int.to_int n in
       ok @@ D_nat n
   | (Bool_t _), b ->
@@ -58,15 +58,15 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result =
   | ty, v ->
       let%bind error =
         let%bind m_data =
-          trace_tzresult_lwt (simple_error "unparsing unrecognized data") @@
+          trace_tzresult_lwt (fun () -> simple_error (thunk "unparsing unrecognized data") ()) @@
           Tezos_utils.Memory_proto_alpha.unparse_michelson_data ty v in
         let%bind m_ty =
-          trace_tzresult_lwt (simple_error "unparsing unrecognized data") @@
+          trace_tzresult_lwt (fun () -> simple_error (thunk "unparsing unrecognized data") ()) @@
           Tezos_utils.Memory_proto_alpha.unparse_michelson_ty ty in
-        let error_content  =
+        let error_content () =
           Format.asprintf "%a : %a"
             Michelson.pp m_data
             Michelson.pp m_ty in
-        ok @@ error "this value can't be transpiled back yet" error_content
+        ok @@ (fun () -> error (thunk "this value can't be transpiled back yet") error_content ())
       in
       fail error

src/ligo/multifix/user.ml

@@ -14,26 +14,26 @@ let parse_file (source: string) : Ast.entry_point result =
    *   generic_try (simple_error "error opening file") @@
    *   (fun () -> open_in pp_input) in *)
   let%bind channel =
-    generic_try (simple_error "error opening file") @@
+    generic_try (fun () -> simple_error (thunk "error opening file") ()) @@
     (fun () -> open_in source) in
   let lexbuf = Lexing.from_channel channel in
   let module Lexer = Lex.Lexer in
-  specific_try (fun e ->
-      let error = fun s ->
+  (specific_try (fun () -> fun e ->
+      let error s () =
         let start = Lexing.lexeme_start_p lexbuf in
         let end_ = Lexing.lexeme_end_p lexbuf in
-        let str = Format.sprintf
+        let str () = Format.sprintf
           "at \"%s\" from (%d, %d) to (%d, %d)\n"
           (Lexing.lexeme lexbuf)
           start.pos_lnum (start.pos_cnum - start.pos_bol)
           end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
-        error s str in
+        error s str () in
       match e with
-      | Parser.Error -> error "Parse"
-      | Lexer.Error s -> error ("Lexer " ^ s)
-      | Lexer.Unexpected_character s -> error ("Unexpected char" ^ s)
-      | _ -> error "unrecognized parse_ error"
-    ) @@ (fun () ->
+      | Parser.Error -> (fun () -> error (thunk "Parse") ())
+      | Lexer.Error s -> (fun () -> error (fun () -> "Lexer " ^ s) ())
+      | Lexer.Unexpected_character s -> error (fun () -> "Unexpected char" ^ s)
+      | _ -> simple_error (thunk "unrecognized parse_ error")
+     )) @@ (fun () ->
       let raw = Parser.entry_point Lexer.token lexbuf in
       raw
     ) >>? fun raw ->

src/ligo/simplify.ml

@@ -30,7 +30,7 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
       | Some 0 ->
           ok @@ T_constant (v.value, [])
       | Some _ ->
-          simple_fail "type constructor with wrong number of args"
+          simple_fail (thunk "type constructor with wrong number of args")
       | None ->
           ok @@ T_variable v.value
     )
@@ -39,8 +39,8 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
       let lst = npseq_to_list tuple.value.inside in
       let%bind _ = match List.assoc_opt name.value type_constants with
         | Some n when n = List.length lst -> ok ()
-        | Some _ -> simple_fail "type constructor with wrong number of args"
-        | None -> simple_fail "unrecognized type constants" in
+        | Some _ -> simple_fail (thunk "type constructor with wrong number of args")
+        | None -> simple_fail (thunk "unrecognized type constants") in
       let%bind lst' = bind_list @@ List.map simpl_type_expression lst in
       ok @@ T_constant (name.value, lst')
   | TProd p ->
@@ -112,7 +112,7 @@ let rec simpl_expression (t:Raw.expr) : ae result =
           ok @@ ae @@ E_application (ae @@ E_variable f, arg)
       | Some arity ->
           let%bind _arity =
-            trace (simple_error "wrong arity for constants") @@
+            trace (fun () -> simple_error (thunk "wrong arity for constants") ()) @@
             Assert.assert_equal_int arity (List.length args') in
           let%bind lst = bind_map_list simpl_expression args' in
           ok @@ ae @@ E_constant (f, lst)
@@ -161,13 +161,13 @@ let rec simpl_expression (t:Raw.expr) : ae result =
   | EArith (Nat n) ->
       let n = Z.to_int @@ snd @@ n.value in
       ok @@ ae @@ E_literal (Literal_nat n)
-  | EArith _ -> simple_fail "arith: not supported yet"
+  | EArith _ -> simple_fail (thunk "arith: not supported yet")
   | EString (String s) ->
       ok @@ ae @@ E_literal (Literal_string s.value)
-  | EString _ -> simple_fail "string: not supported yet"
+  | EString _ -> simple_fail (thunk "string: not supported yet")
   | ELogic l -> simpl_logic_expression l
-  | EList _ -> simple_fail "list: not supported yet"
-  | ESet _ -> simple_fail "set: not supported yet"
+  | EList _ -> simple_fail (thunk "list: not supported yet")
+  | ESet _ -> simple_fail (thunk "set: not supported yet")
   | ECase c ->
       let%bind e = simpl_expression c.value.expr in
       let%bind lst =
@@ -242,7 +242,7 @@ and simpl_list_expression (lst:Raw.expr list) : ae result =
 and simpl_local_declaration (t:Raw.local_decl) : (instruction * named_expression) result =
   match t with
   | LocalData d -> simpl_data_declaration d
-  | LocalLam _ -> simple_fail "no local lambdas yet"
+  | LocalLam _ -> simple_fail (thunk "no local lambdas yet")
 
 and simpl_data_declaration (t:Raw.data_decl) : (instruction * named_expression) result =
   let return x = ok (I_assignment x, x) in
@@ -292,7 +292,7 @@ and simpl_declaration : Raw.declaration -> declaration result = fun t ->
   | LambdaDecl (FunDecl x) ->
       let {name;param;ret_type;local_decls;block;return} : fun_decl = x.value in
       (match npseq_to_list param.value.inside with
-       | [] -> simple_fail "function without parameters are not allowed"
+       | [] -> simple_fail (thunk "function without parameters are not allowed")
        | [a] -> (
            let%bind input = simpl_param a in
            let name = name.value in
@@ -358,8 +358,8 @@ and simpl_declaration : Raw.declaration -> declaration result = fun t ->
            ok decl
          )
       )
-  | LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet"
-  | LambdaDecl (EntryDecl _)-> simple_fail "no entry point yet"
+  | LambdaDecl (ProcDecl _) -> simple_fail (thunk "no proc declaration yet")
+  | LambdaDecl (EntryDecl _)-> simple_fail (thunk "no entry point yet")
 
 and simpl_statement : Raw.statement -> instruction result = fun s ->
   match s with
@@ -368,7 +368,7 @@ and simpl_statement : Raw.statement -> instruction result = fun s ->
 
 and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
   match t with
-  | ProcCall _ -> simple_fail "no proc call"
+  | ProcCall _ -> simple_fail (thunk "no proc call")
   | Fail e ->
       let%bind expr = simpl_expression e.value.fail_expr in
       ok @@ I_fail expr
@@ -379,7 +379,7 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
       let%bind body = simpl_block l.block.value in
       ok @@ I_loop (cond, body)
   | Loop (For _) ->
-      simple_fail "no for yet"
+      simple_fail (thunk "no for yet")
   | Cond c ->
       let c = c.value in
       let%bind expr = simpl_expression c.test in
@@ -394,21 +394,21 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
       let a = a.value in
       let%bind value_expr = match a.rhs with
         | Expr e -> simpl_expression e
-        | NoneExpr _ -> simple_fail "no none assignments yet"
+        | NoneExpr _ -> simple_fail (thunk "no none assignments yet")
       in
       match a.lhs with
         | Path (Name name) -> (
             ok @@ I_assignment {name = name.value ; annotated_expression = value_expr}
           )
         | Path path -> (
-            let err_content = Format.asprintf "%a" (PP_helpers.printer Raw.print_path) path in
-            fail @@ error "no path assignments" err_content
+            let err_content () = Format.asprintf "%a" (PP_helpers.printer Raw.print_path) path in
+            fail @@ (fun () -> error (thunk "no path assignments") err_content ())
           )
         | MapPath v -> (
             let v' = v.value in
             let%bind name = match v'.path with
               | Name name -> ok name
-              | _ -> simple_fail "no complex map assignments yet" in
+              | _ -> simple_fail (thunk "no complex map assignments yet") in
             let%bind key_expr = simpl_expression v'.index.value.inside in
             let old_expr = ae @@ E_variable name.value in
             let expr' = ae @@ E_constant ("MAP_UPDATE", [key_expr ; value_expr ; old_expr]) in
@@ -432,8 +432,8 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
       let%bind record = match r.path with
         | Name v -> ok v.value
         | path -> (
-            let err_content = Format.asprintf "%a" (PP_helpers.printer Raw.print_path) path in
-            fail @@ error "no complex record patch yet" err_content
+            let err_content () = Format.asprintf "%a" (PP_helpers.printer Raw.print_path) path in
+            fail @@ (fun () -> error (thunk "no complex record patch yet") err_content ())
           )
       in
       let%bind inj = bind_list
@@ -442,32 +442,32 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
         @@ npseq_to_list r.record_inj.value.fields in
       ok @@ I_record_patch (record, [], inj)
     )
-  | MapPatch _ -> simple_fail "no map patch yet"
-  | SetPatch _ -> simple_fail "no set patch yet"
+  | MapPatch _ -> simple_fail (thunk "no map patch yet")
+  | SetPatch _ -> simple_fail (thunk "no set patch yet")
   | MapRemove r ->
       let v = r.value in
       let key = v.key in
       let%bind map = match v.map with
         | Name v -> ok v.value
-        | _ -> simple_fail "no complex map remove yet" in
+        | _ -> simple_fail (thunk "no complex map remove yet") in
       let%bind key' = simpl_expression key in
       let expr = E_constant ("MAP_REMOVE", [key' ; ae (E_variable map)]) in
       ok @@ I_assignment {name = map ; annotated_expression = ae expr}
-  | SetRemove _ -> simple_fail "no set remove yet"
+  | SetRemove _ -> simple_fail (thunk "no set remove yet")
 
 and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t ->
   let open Raw in
   let get_var (t:Raw.pattern) = match t with
     | PVar v -> ok v.value
-    | _ -> simple_fail "not a var"
+    | _ -> simple_fail (thunk "not a var")
   in
   let%bind _assert =
-    trace_strong (simple_error "only pattern with two cases supported now") @@
+    trace_strong (fun () -> simple_error (thunk "only pattern with two cases supported now") ()) @@
     Assert.assert_equal_int 2 (List.length t) in
   let ((pa, ba), (pb, bb)) = List.(hd t, hd @@ tl t) in
   let uncons p = match p with
     | PCons {value = (hd, _)} -> ok hd
-    | _ -> simple_fail "uncons fail" in
+    | _ -> simple_fail (thunk "uncons fail") in
   let%bind (pa, pb) = bind_map_pair uncons (pa, pb) in
   match (pa, ba), (pb, bb) with
   | (PFalse _, f), (PTrue _, t)
@@ -477,7 +477,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
       let (_, v) = v.value in
       let%bind v = match v.value.inside with
         | PVar v -> ok v.value
-        | _ -> simple_fail "complex none patterns not supported yet" in
+        | _ -> simple_fail (thunk "complex none patterns not supported yet") in
       ok @@ Match_option {match_none = none ; match_some = (v, some) }
     )
   | (PCons c, cons), (PList (PNil _), nil)
@@ -488,11 +488,11 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
             let%bind a = get_var a in
             let%bind b = get_var b in
             ok (a, b)
-        | _ -> simple_fail "complex list patterns not supported yet"
+        | _ -> simple_fail (thunk "complex list patterns not supported yet")
       in
       ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil}
   | _ ->
-      let error = simple_error "multi-level patterns not supported yet" in
+      let error () = simple_error (thunk "multi-level patterns not supported yet") () in
       fail error
 
 and simpl_instruction_block : Raw.instruction -> block result = fun t ->
@@ -503,7 +503,7 @@ and simpl_instruction_block : Raw.instruction -> block result = fun t ->
 and simpl_instruction : Raw.instruction -> instruction result = fun t ->
   match t with
   | Single s -> simpl_single_instruction s
-  | Block _ -> simple_fail "no block instruction yet"
+  | Block _ -> simple_fail (thunk "no block instruction yet")
 
 and simpl_statements : Raw.statements -> block result = fun ss ->
   let lst = npseq_to_list ss in

src/ligo/test/compiler_tests.ml

@@ -8,7 +8,7 @@ let run_entry_int (e:anon_function) (n:int) : int result =
   let%bind result = Run.run_entry e param in
   match result with
   | D_int n -> ok n
-  | _ -> simple_fail "result is not an int"
+  | _ -> simple_fail (thunk "result is not an int")
 
 let identity () : unit result =
   let e = basic_int_quote_env in

src/ligo/test/heap_tests.ml

@@ -64,7 +64,7 @@ let get_top () : unit result =
     let open AST_Typed.Combinators in
     let input = dummy n in
     match n, easy_run_typed "get_top" program input with
-    | 0, Trace.Ok _ -> simple_fail "unexpected success"
+    | 0, Trace.Ok _ -> simple_fail (thunk "unexpected success")
     | 0, _ -> ok ()
     | _, result ->
         let%bind result' = result in
@@ -81,7 +81,7 @@ let pop_switch () : unit result =
   let aux n =
     let input = dummy n in
     match n, easy_run_typed "pop_switch" program input with
-    | 0, Trace.Ok _ -> simple_fail "unexpected success"
+    | 0, Trace.Ok _ -> simple_fail (thunk "unexpected success")
     | 0, _ -> ok ()
     | _, result ->
         let%bind result' = result in

src/ligo/test/integration_tests.ml

@@ -4,16 +4,16 @@ open Test_helpers
 
 let pass (source:string) : unit result =
   let%bind raw =
-    trace (simple_error "parsing") @@
+    trace (fun () -> simple_error (thunk "parsing") ()) @@
     parse_file source in
   let%bind simplified =
-    trace (simple_error "simplifying") @@
+    trace (fun () -> simple_error (thunk "simplifying") ()) @@
     simplify raw in
   let%bind typed =
-    trace (simple_error "typing") @@
+    trace (fun () -> simple_error (thunk "typing") ()) @@
     type_ simplified in
   let%bind _mini_c =
-    trace (simple_error "transpiling") @@
+    trace (fun () -> simple_error (thunk "transpiling") ()) @@
     transpile typed in
   ok ()
 
@@ -32,7 +32,7 @@ let complex_function () : unit result =
     let input = e_a_int n in
     let%bind result = easy_run_main_typed program input in
     let%bind result' =
-      trace (simple_error "bad result") @@
+      trace (fun () -> simple_error (thunk "bad result") ()) @@
       get_a_int result in
     Assert.assert_equal_int (3 * n + 2) result'
   in
@@ -49,7 +49,7 @@ let bool_expression () : unit result =
       let input = e_a_bool b in
       let%bind result = easy_run_typed name program input in
       let%bind result' =
-        trace (simple_error "bad result") @@
+        trace (fun () -> simple_error (thunk "bad result") ()) @@
         get_a_bool result in
       Assert.assert_equal_bool (f b) result'
     in
@@ -96,7 +96,7 @@ let unit_expression () : unit result =
   let open AST_Typed.Combinators in
   let%bind result = easy_evaluate_typed "u" program in
   let%bind () =
-    trace (simple_error "result isn't unit") @@
+    trace (fun () -> simple_error (thunk "result isn't unit") ()) @@
     get_a_unit result in
   ok ()
 
@@ -104,7 +104,7 @@ let include_ () : unit result =
   let%bind program = type_file "./contracts/includer.ligo" in
   let%bind result = easy_evaluate_typed "bar" program in
   let%bind n =
-    trace (simple_error "Include failed") @@
+    trace (fun () -> simple_error (thunk "Include failed") ()) @@
     AST_Typed.Combinators.get_a_int result in
   Assert.assert_equal_int 144 n
 
@@ -163,13 +163,13 @@ let tuple () : unit result  =
     let open AST_Typed.Combinators in
     e_a_tuple (List.map e_a_int n) in
   let%bind _foobar =
-    trace (simple_error "foobar") (
+    trace (fun () -> simple_error (thunk "foobar") ()) (
       let%bind result = easy_evaluate_typed "fb" program in
       let expect = ez [0 ; 0] in
       AST_Typed.assert_value_eq (expect, result)
     )
   in
-  let%bind _projection = trace (simple_error "projection") (
+  let%bind _projection = trace (fun () -> simple_error (thunk "projection") ()) (
       let aux n =
         let input = ez [n ; n] in
         let%bind result = easy_run_typed "projection" program input in
@@ -189,12 +189,12 @@ let tuple () : unit result  =
 let option () : unit result =
   let%bind program = type_file "./contracts/option.ligo" in
   let open AST_Typed.Combinators in
-  let%bind _some = trace (simple_error "some") @@
+  let%bind _some = trace (fun () -> simple_error (thunk "some") ()) @@
     let%bind result = easy_evaluate_typed "s" program in
     let expect = e_a_some (e_a_int 42) in
     AST_Typed.assert_value_eq (expect, result)
   in
-  let%bind _none = trace (simple_error "none") @@
+  let%bind _none = trace (fun () -> simple_error (thunk "none") ()) @@
     let%bind result = easy_evaluate_typed "n" program in
     let expect = e_a_none (t_int ()) in
     AST_Typed.assert_value_eq (expect, result)
@@ -208,7 +208,7 @@ let map () : unit result =
     let lst' = List.map (fun (x, y) -> e_a_int x, e_a_int y) lst in
     e_a_map lst' (t_int ()) (t_int ())
   in
-  let%bind _get_force = trace (simple_error "get_force") @@
+  let%bind _get_force = trace (fun () -> simple_error (thunk "get_force") ()) @@
     let aux n =
       let input = ez [(23, n) ; (42, 4)] in
       let%bind result = easy_run_typed "gf" program input in
@@ -217,7 +217,7 @@ let map () : unit result =
     in
     bind_map_list aux [0 ; 42 ; 51 ; 421 ; -3]
   in
-  let%bind _size = trace (simple_error "size") @@
+  let%bind _size = trace (fun () -> simple_error (thunk "size") ()) @@
     let aux n =
       let input = ez List.(map (fun x -> (x, x)) @@ range n) in
       let%bind result = easy_run_typed "size_" program input in
@@ -226,12 +226,12 @@ let map () : unit result =
     in
     bind_map_list aux [1 ; 10 ; 3]
   in
-  let%bind _foobar = trace (simple_error "foobar") @@
+  let%bind _foobar = trace (fun () -> simple_error (thunk "foobar") ()) @@
     let%bind result = easy_evaluate_typed "fb" program in
     let expect = ez [(23, 0) ; (42, 0)] in
     AST_Typed.assert_value_eq (expect, result)
   in
-  let%bind _set = trace (simple_error "set") @@
+  let%bind _set = trace (fun () -> simple_error (thunk "set") ()) @@
     let aux n =
       let input =
         let m = ez [(23, 0) ; (42, 0)] in
@@ -243,7 +243,7 @@ let map () : unit result =
     in
     bind_map_list aux [1 ; 10 ; 3]
   in
-  let%bind _get = trace (simple_error "get") @@
+  let%bind _get = trace (fun () -> simple_error (thunk "get") ()) @@
     let aux n =
       let input = ez [(23, n) ; (42, 4)] in
       let%bind result = easy_run_typed "get" program input in
@@ -252,12 +252,12 @@ let map () : unit result =
     in
     bind_map_list aux [0 ; 42 ; 51 ; 421 ; -3]
   in
-  let%bind _bigmap = trace (simple_error "bigmap") @@
+  let%bind _bigmap = trace (fun () -> simple_error (thunk "bigmap") ()) @@
     let%bind result = easy_evaluate_typed "bm" program in
     let expect = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in
     AST_Typed.assert_value_eq (expect, result)
   in
-  let%bind _remove = trace (simple_error "rm") @@
+  let%bind _remove = trace (fun () -> simple_error (thunk "rm") ()) @@
     let input = ez [(23, 23) ; (42, 42)] in
     let%bind result = easy_run_typed "rm" program input in
     let expect = ez [23, 23] in
@@ -272,7 +272,7 @@ let condition () : unit result =
     let input = e_a_int n in
     let%bind result = easy_run_main_typed program input in
     let%bind result' =
-      trace (simple_error "bad result") @@
+      trace (fun () -> simple_error (thunk "bad result") ()) @@
       get_a_int result in
     Assert.assert_equal_int (if n = 2 then 42 else 0) result'
   in
@@ -283,7 +283,7 @@ let condition () : unit result =
 
 let loop () : unit result =
   let%bind program = type_file "./contracts/loop.ligo" in
-  let%bind _dummy = trace (simple_error "dummy") @@
+  let%bind _dummy = trace (fun () -> simple_error (thunk "dummy") ()) @@
     let aux n =
       let open AST_Typed.Combinators in
       let input = e_a_nat n in
@@ -296,7 +296,7 @@ let loop () : unit result =
       @@ [0 ; 2 ; 42 ; 163] in
     ok ()
   in
-  let%bind _counter = trace (simple_error "counter") @@
+  let%bind _counter = trace (fun () -> simple_error (thunk "counter") ()) @@
     let aux n =
       let open AST_Typed.Combinators in
       let input = e_a_nat n in
@@ -309,7 +309,7 @@ let loop () : unit result =
       @@ [0 ; 2 ; 42 ; 12] in
     ok ()
   in
-  let%bind _sum = trace (simple_error "sum") @@
+  let%bind _sum = trace (fun () -> simple_error (thunk "sum") ()) @@
     let aux n =
       let open AST_Typed.Combinators in
       let input = e_a_nat n in
@@ -333,7 +333,7 @@ let matching () : unit result =
       let input = e_a_int n in
       let%bind result = easy_run_typed "match_bool" program input in
       let%bind result' =
-        trace (simple_error "bad result") @@
+        trace (fun () -> simple_error (thunk "bad result") ()) @@
         get_a_int result in
       Assert.assert_equal_int (if n = 2 then 42 else 0) result'
     in
@@ -348,7 +348,7 @@ let matching () : unit result =
       let input = e_a_int n in
       let%bind result = easy_run_typed "match_expr_bool" program input in
       let%bind result' =
-        trace (simple_error "bad result") @@
+        trace (fun () -> simple_error (thunk "bad result") ()) @@
         get_a_int result in
       Assert.assert_equal_int (if n = 2 then 42 else 0) result'
     in
@@ -365,7 +365,7 @@ let matching () : unit result =
         | None -> e_a_none (t_int ()) in
       let%bind result = easy_run_typed "match_option" program input in
       let%bind result' =
-        trace (simple_error "bad result") @@
+        trace (fun () -> simple_error (thunk "bad result") ()) @@
         get_a_int result in
       Assert.assert_equal_int (match n with None -> 23 | Some s -> s) result'
     in
@@ -383,7 +383,7 @@ let declarations () : unit result =
     let input = e_a_int n in
     let%bind result = easy_run_main_typed program input in
     let%bind result' =
-      trace (simple_error "bad result") @@
+      trace (fun () -> simple_error (thunk "bad result") ()) @@
       get_a_int result in
     Assert.assert_equal_int (42 + n) result'
   in
@@ -399,7 +399,7 @@ let quote_declaration () : unit result =
     let input = e_a_int n in
     let%bind result = easy_run_main_typed program input in
     let%bind result' =
-      trace (simple_error "bad result") @@
+      trace (fun () -> simple_error (thunk "bad result") ()) @@
       get_a_int result in
     Assert.assert_equal_int result' (42 + 2 * n)
   in
@@ -415,7 +415,7 @@ let quote_declarations () : unit result =
     let input = e_a_int n in
     let%bind result = easy_run_main_typed program input in
     let%bind result' =
-      trace (simple_error "bad result") @@
+      trace (fun () -> simple_error (thunk "bad result") ()) @@
       get_a_int result in
     Assert.assert_equal_int result' (74 + 2 * n)
   in

src/ligo/test/test_helpers.ml

@@ -3,10 +3,10 @@ open! Trace
 let test name f =
   Alcotest.test_case name `Quick @@ fun () ->
   let result =
-    trace (error "running test" name) @@
+    trace (fun () -> error (thunk "running test") (fun () -> name) ()) @@
     f () in
   match result with
   | Ok () -> ()
   | Errors errs ->
-      Format.printf "Errors : {\n%a}\n%!" errors_pp errs ;
+      Format.printf "Errors : {\n%a}\n%!" errors_pp (List.rev (List.rev_map (fun f -> f ()) errs)) ;
       raise Alcotest.Test_error

src/ligo/transpiler.ml

@@ -24,7 +24,7 @@ let rec translate_type (t:AST.type_value) : type_value result =
   | T_constant ("option", [o]) ->
       let%bind o' = translate_type o in
       ok (T_option o')
-  | T_constant (name, _) -> fail (error "unrecognized constant" name)
+  | T_constant (name, _) -> fail (fun () -> error (thunk "unrecognized constant") (fun () -> name) ())
   | T_sum m ->
       let node = Append_tree.of_list @@ list_of_map m in
       let aux a b : type_value result =
@@ -60,7 +60,7 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * (
     if i = ind then (
       ok (ty, [])
     ) else (
-      simple_fail "bad leaf"
+      simple_fail (thunk "bad leaf")
     ) in
   let node a b : (type_value * (type_value * [`Left | `Right]) list) result =
     match%bind bind_lr (a, b) with
@@ -71,8 +71,8 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * (
         let%bind (_, b) = get_t_pair t in
         ok @@ (t, (b, `Right) :: acc)
       ) in
-  let error_content = Format.asprintf "(%a).%d" (PP.list_sep_d PP.type_) tys ind in
-  trace_strong (error "bad index in tuple (shouldn't happen here)" error_content) @@
+  let error_content () = Format.asprintf "(%a).%d" (PP.list_sep_d PP.type_) tys ind in
+  trace_strong (fun () -> error (thunk "bad index in tuple (shouldn't happen here)") error_content ()) @@
   Append_tree.fold_ne leaf node node_tv
 
 let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -> (type_value * (type_value * [`Left | `Right]) list) result = fun ty tym ind ->
@@ -82,7 +82,7 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -
     if i = ind then (
       ok (ty, [])
     ) else (
-      simple_fail "bad leaf"
+      simple_fail (thunk "bad leaf")
     ) in
   let node a b : (type_value * (type_value * [`Left | `Right]) list) result =
     match%bind bind_lr (a, b) with
@@ -93,10 +93,10 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -
         let%bind (_, b) = get_t_pair t in
         ok @@ (t, (b, `Right) :: acc)
       ) in
-  let error_content =
+  let error_content () =
     let aux ppf (name, ty) = Format.fprintf ppf "%s -> %a" name PP.type_ ty in
     Format.asprintf "(%a).%s" (PP.list_sep_d aux) tys ind in
-  trace_strong (error "bad index in record (shouldn't happen here)" error_content) @@
+  trace_strong (fun () -> error (thunk "bad index in record (shouldn't happen here)") error_content ()) @@
   Append_tree.fold_ne leaf node node_tv
 
 let rec translate_block env (b:AST.block) : block result =
@@ -163,7 +163,7 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement op
             translate_block env' sm in
           return (If_None (expr', none_branch, (name, some_branch)))
         )
-      | _ -> simple_fail "todo : match"
+      | _ -> simple_fail (thunk "todo : match")
     )
   | I_loop (expr, body) ->
       let%bind expr' = translate_annotated_expression env expr in
@@ -171,7 +171,7 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement op
       let%bind body' = translate_block env' body in
       return (While (expr', body'))
   | I_skip -> ok None
-  | I_fail _ -> simple_fail "todo : fail"
+  | I_fail _ -> simple_fail (thunk "todo : fail")
 
 and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_expression) : expression result =
   let%bind tv = translate_type ae.type_annotation in
@@ -197,7 +197,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
         let leaf (k, tv) : (expression' option * type_value) result =
           if k = m then (
             let%bind _ =
-              trace (simple_error "constructor parameter doesn't have expected type (shouldn't happen here)")
+              trace (fun () -> simple_error (thunk "constructor parameter doesn't have expected type (shouldn't happen here)") ())
               @@ AST.assert_type_value_eq (tv, param.type_annotation) in
             ok (Some (param'_expr), param'_tv)
           ) else (
@@ -209,13 +209,13 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
           let%bind b = b in
           match (a, b) with
           | (None, a), (None, b) -> ok (None, T_or (a, b))
-          | (Some _, _), (Some _, _) -> simple_fail "several identical constructors in the same variant (shouldn't happen here)"
+          | (Some _, _), (Some _, _) -> simple_fail (thunk "several identical constructors in the same variant (shouldn't happen here)")
           | (Some v, a), (None, b) -> ok (Some (E_constant ("LEFT", [v, a, env])), T_or (a, b))
           | (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [v, b, env])), T_or (a, b))
         in
         let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in
         let%bind ae =
-          trace_option (simple_error "constructor doesn't exist in claimed type (shouldn't happen here)")
+          trace_option (fun () -> simple_error (thunk "constructor doesn't exist in claimed type (shouldn't happen here)") ())
             ae_opt in
         ok (ae, tv, env) in
       ok ae'
@@ -274,14 +274,14 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
   | E_record_accessor (record, property) ->
       let%bind translation = translate_annotated_expression env record in
       let%bind record_type_map =
-        trace (simple_error (Format.asprintf "Accessing field of %a, that has type %a, which isn't a record" AST.PP.annotated_expression record AST.PP.type_value record.type_annotation)) @@
+        trace (fun () -> simple_error (fun () -> Format.asprintf "Accessing field of %a, that has type %a, which isn't a record" AST.PP.annotated_expression record AST.PP.type_value record.type_annotation) ()) @@
         get_t_record record.type_annotation in
       let node_tv = Append_tree.of_list @@ kv_list_of_map record_type_map in
       let leaf (key, _) : expression result =
         if property = key then (
           ok translation
         ) else (
-          simple_fail "bad leaf"
+          simple_fail (thunk "bad leaf")
         ) in
       let node (a:expression result) b : expression result =
         match%bind bind_lr (a, b) with
@@ -294,7 +294,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
             ok (E_constant ("CDR", [ex]), b, env)
           ) in
       let%bind expr =
-        trace_strong (simple_error "bad key in record (shouldn't happen here)") @@
+        trace_strong (fun () -> simple_error (thunk "bad key in record (shouldn't happen here)") ()) @@
         Append_tree.fold_ne leaf node node_tv in
       ok expr
   | E_constant (name, lst) ->
@@ -327,7 +327,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
           let%bind (t, f) = bind_map_pair (translate_annotated_expression env) (match_true, match_false) in
           return (E_Cond (expr', t, f), tv)
       | AST.Match_list _ | AST.Match_option _ | AST.Match_tuple (_, _) ->
-          simple_fail "only match bool exprs are translated yet"
+          simple_fail (thunk "only match bool exprs are translated yet")
     )
 
 and translate_lambda_shallow env l tv =
@@ -385,7 +385,7 @@ let translate_main (l:AST.lambda) (t:AST.type_value) : anon_function result =
   let%bind (expr, _, _) = translate_lambda Environment.empty l t' in
   match expr with
   | E_literal (D_function f) -> ok f
-  | _ -> simple_fail "main is not a function"
+  | _ -> simple_fail (thunk "main is not a function")
 
 (* From a non-functional expression [expr], build the functional expression [fun () -> expr] *)
 let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value =
@@ -419,11 +419,11 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
   in
   let%bind (lst', l, tv) =
     let%bind (lst', l, tv) =
-      trace_option (simple_error "no entry-point with given name")
+      trace_option (fun () -> simple_error (thunk "no entry-point with given name") ())
       @@ aux [] lst in
     ok (List.rev lst', l, tv) in
   let l' = {l with body = lst' @ l.body} in
-  trace (simple_error "translate entry")
+  trace (fun () -> simple_error (thunk "translate entry") ())
   @@ translate_main l' tv
 
 open Combinators
@@ -445,7 +445,7 @@ let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value
     | Leaf (k, t), v -> ok (k, v, t)
     | Node {a}, D_left v -> aux (a, v)
     | Node {b}, D_right v -> aux (b, v)
-    | _ -> simple_fail "bad constructor path"
+    | _ -> simple_fail (thunk "bad constructor path")
   in
   let%bind (s, v, t) = aux (tree, v) in
   ok (s, v, t)
@@ -459,7 +459,7 @@ let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value *
         let%bind a' = aux (a, va) in
         let%bind b' = aux (b, vb) in
         ok (a' @ b')
-    | _ -> simple_fail "bad tuple path"
+    | _ -> simple_fail (thunk "bad tuple path")
   in
   aux (tree, v)
 
@@ -472,7 +472,7 @@ let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
         let%bind a' = aux (a, va) in
         let%bind b' = aux (b, vb) in
         ok (a' @ b')
-    | _ -> simple_fail "bad record path"
+    | _ -> simple_fail (thunk "bad record path")
   in
   aux (tree, v)
 
@@ -514,11 +514,11 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
       return (E_map lst')
     )
   | T_constant _ ->
-      simple_fail "unknown type_constant"
+      simple_fail (thunk "unknown type_constant")
   | T_sum m ->
       let lst = kv_list_of_map m in
       let%bind node = match Append_tree.of_list lst with
-        | Empty -> simple_fail "empty sum type"
+        | Empty -> simple_fail (thunk "empty sum type")
         | Full t -> ok t
       in
       let%bind (name, v, tv) = extract_constructor v node in
@@ -526,7 +526,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
       return (E_constructor (name, sub))
   | T_tuple lst ->
       let%bind node = match Append_tree.of_list lst with
-        | Empty -> simple_fail "empty tuple"
+        | Empty -> simple_fail (thunk "empty tuple")
         | Full t -> ok t in
       let%bind tpl = extract_tuple v node in
       let%bind tpl' = bind_list
@@ -535,11 +535,11 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
   | T_record m ->
       let lst = kv_list_of_map m in
       let%bind node = match Append_tree.of_list lst with
-        | Empty -> simple_fail "empty record"
+        | Empty -> simple_fail (thunk "empty record")
         | Full t -> ok t in
       let%bind lst = extract_record v node in
       let%bind lst = bind_list
         @@ List.map (fun (x, (y, z)) -> let%bind yz = untranspile y z in ok (x, yz)) lst in
       let m' = map_of_kv_list lst in
       return (E_record m')
-  | T_function _ -> simple_fail "no untranspilation for functions yet"
+  | T_function _ -> simple_fail (thunk "no untranspilation for functions yet")

src/ligo/typer.ml

@@ -65,33 +65,33 @@ end
 type environment = Environment.t
 
 module Errors = struct
-  let unbound_type_variable (e:environment) (n:string) =
-    let title = "unbound type variable" in
-    let full = Format.asprintf "%s in %a" n Environment.PP.type_ e in
-    error title full
+  let unbound_type_variable (e:environment) (n:string) () =
+    let title = (thunk "unbound type variable") in
+    let full () = Format.asprintf "%s in %a" n Environment.PP.type_ e in
+    error title full ()
 
-  let unbound_variable (e:environment) (n:string) =
-    let title = "unbound variable" in
-    let full = Format.asprintf "%s in %a" n Environment.PP.value e in
-    error title full
+  let unbound_variable (e:environment) (n:string) () =
+    let title = (thunk "unbound variable") in
+    let full () = Format.asprintf "%s in %a" n Environment.PP.value e in
+    error title full ()
 
-  let unrecognized_constant (n:string) =
-    let title = "unrecognized constant" in
-    let full = n in
-    error title full
+  let unrecognized_constant (n:string) () =
+    let title = (thunk "unrecognized constant") in
+    let full () = n in
+    error title full ()
 
-  let program_error (p:I.program) =
-    let title = "typing program" in
-    let full = Format.asprintf "%a" I.PP.program p in
-    error title full
+  let program_error (p:I.program) () =
+    let title = (thunk "typing program") in
+    let full () = Format.asprintf "%a" I.PP.program p in
+    error title full ()
 
-  let constant_declaration_error (name:string) (ae:I.ae) =
-    let title = "typing constant declaration" in
-    let full =
+  let constant_declaration_error (name:string) (ae:I.ae) () =
+    let title = (thunk "typing constant declaration") in
+    let full () =
       Format.asprintf "%s = %a" name
         I.PP.annotated_expression ae
     in
-    error title full
+    error title full ()
 
 end
 open Errors
@@ -105,7 +105,7 @@ let rec type_program (p:I.program) : O.program result =
     | Some d' -> ok (e', d' :: acc)
   in
   let%bind (_, lst) =
-    trace (program_error p) @@
+    trace (fun () -> program_error p ()) @@
     bind_fold_list aux (Environment.empty, []) p in
   ok @@ List.rev lst
 
@@ -148,7 +148,7 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
       return @@ O.I_loop (cond, body)
   | I_assignment {name;annotated_expression} -> (
       match annotated_expression.type_annotation, Environment.get e name with
-      | None, None -> simple_fail "Initial assignments need type"
+      | None, None -> simple_fail (thunk "Initial assignments need type")
       | Some _, None ->
           let%bind annotated_expression = type_annotated_expression e annotated_expression in
           let e' = Environment.add e name annotated_expression.type_annotation in
@@ -161,7 +161,7 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
           ok (e', [O.I_assignment {name;annotated_expression}])
       | Some _, Some prev ->
           let%bind annotated_expression = type_annotated_expression e annotated_expression in
-          let%bind _assert = trace (simple_error "Annotation doesn't match environment")
+          let%bind _assert = trace (fun () -> simple_error (thunk "Annotation doesn't match environment") ())
             @@ O.assert_type_value_eq (annotated_expression.type_annotation, prev) in
           let e' = Environment.add e name annotated_expression.type_annotation in
           ok (e', [O.I_assignment {name;annotated_expression}])
@@ -174,18 +174,18 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
       let aux (s, ae) =
         let%bind ae' = type_annotated_expression e ae in
         let%bind ty =
-          trace_option (simple_error "unbound variable in record_patch") @@
+          trace_option (fun () -> simple_error (thunk "unbound variable in record_patch") ()) @@
           Environment.get e r in
         let tv = O.{type_name = r ; type_value = ty} in
         let aux ty access =
           match access with
           | I.Access_record s ->
               let%bind m = O.Combinators.get_t_record ty in
-              trace_option (simple_error "unbound record access in record_patch") @@
+              trace_option (fun () -> simple_error (thunk "unbound record access in record_patch") ()) @@
               Map.String.find_opt s m
           | Access_tuple i ->
               let%bind t = O.Combinators.get_t_tuple ty in
-              generic_try (simple_error "unbound tuple access in record_patch") @@
+              generic_try (fun () -> simple_error (thunk "unbound tuple access in record_patch") ()) @@
               (fun () -> List.nth t i)
         in
         let%bind _assert = bind_fold_list aux ty (path @ [Access_record s]) in
@@ -199,14 +199,14 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
   fun f e t i -> match i with
   | Match_bool {match_true ; match_false} ->
       let%bind _ =
-        trace_strong (simple_error "Matching bool on not-a-bool")
+        trace_strong (fun () -> simple_error (thunk "Matching bool on not-a-bool") ())
         @@ get_t_bool t in
       let%bind match_true = f e match_true in
       let%bind match_false = f e match_false in
       ok (O.Match_bool {match_true ; match_false})
   | Match_option {match_none ; match_some} ->
       let%bind t_opt =
-        trace_strong (simple_error "Matching option on not-an-option")
+        trace_strong (fun () -> simple_error (thunk "Matching option on not-an-option") ())
         @@ get_t_option t in
       let%bind match_none = f e match_none in
       let (n, b) = match_some in
@@ -216,7 +216,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
       ok (O.Match_option {match_none ; match_some = (n', b')})
   | Match_list {match_nil ; match_cons} ->
       let%bind t_list =
-        trace_strong (simple_error "Matching list on not-an-list")
+        trace_strong (fun () -> simple_error (thunk "Matching list on not-an-list") ())
         @@ get_t_list t in
       let%bind match_nil = f e match_nil in
       let (hd, tl, b) = match_cons in
@@ -226,10 +226,10 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
       ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')})
   | Match_tuple (lst, b) ->
       let%bind t_tuple =
-        trace_strong (simple_error "Matching tuple on not-a-tuple")
+        trace_strong (fun () -> simple_error (thunk "Matching tuple on not-a-tuple") ())
         @@ get_t_tuple t in
       let%bind lst' =
-        generic_try (simple_error "Matching tuple of different size")
+        generic_try (fun () -> simple_error (thunk "Matching tuple of different size") ())
         @@ (fun () -> List.combine lst t_tuple) in
       let aux prev (name, tv) = Environment.add prev name tv in
       let e' = List.fold_left aux e lst' in
@@ -315,7 +315,7 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
         | Access_tuple index -> (
             let%bind tpl_tv = get_t_tuple prev.type_annotation in
             let%bind tv =
-              generic_try (simple_error "bad tuple index")
+              generic_try (fun () -> simple_error (thunk "bad tuple index") ())
               @@ (fun () -> List.nth tpl_tv index) in
             let%bind type_annotation = check tv in
             ok O.{expression = O.E_tuple_accessor (prev, index) ; type_annotation}
@@ -323,19 +323,19 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
         | Access_record property -> (
             let%bind r_tv = get_t_record prev.type_annotation in
             let%bind tv =
-              generic_try (simple_error "bad record index")
+              generic_try (fun () -> simple_error (thunk "bad record index") ())
               @@ (fun () -> SMap.find property r_tv) in
             let%bind type_annotation = check tv in
             ok O.{expression = O.E_record_accessor (prev, property) ; type_annotation }
           )
       in
-      trace (simple_error "accessing") @@
+      trace (fun () -> simple_error (thunk "accessing") ()) @@
       bind_fold_list aux e' path
 
   (* Sum *)
   | E_constructor (c, expr) ->
       let%bind (c_tv, sum_tv) =
-        trace_option (simple_error "no such constructor")
+        trace_option (fun () -> simple_error (thunk "no such constructor") ())
         @@ Environment.get_constructor e c in
       let%bind expr' = type_annotated_expression e expr in
       let%bind _assert = O.assert_type_value_eq (expr'.type_annotation, c_tv) in
@@ -365,14 +365,14 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
             bind_fold_list aux None
             @@ List.map Ast_typed.get_type_annotation
             @@ List.map fst lst' in
-          trace_option (simple_error "empty map expression") opt
+          trace_option (fun () -> simple_error (thunk "empty map expression") ()) opt
         in
         let%bind value_type =
           let%bind opt =
             bind_fold_list aux None
             @@ List.map Ast_typed.get_type_annotation
             @@ List.map snd lst' in
-          trace_option (simple_error "empty map expression") opt
+          trace_option (fun () -> simple_error (thunk "empty map expression") ()) opt
         in
         check (t_map key_type value_type ())
       in
@@ -404,7 +404,7 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
         | T_function (param, result) ->
             let%bind _ = O.assert_type_value_eq (param, arg.type_annotation) in
             ok result
-        | _ -> simple_fail "applying to not-a-function"
+        | _ -> simple_fail (thunk "applying to not-a-function")
       in
       ok O.{expression = E_application (f, arg) ; type_annotation}
   | E_look_up dsi ->
@@ -422,7 +422,7 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
         | Match_bool {match_true ; match_false} ->
             let%bind _ = O.assert_type_value_eq (match_true.type_annotation, match_false.type_annotation) in
             ok match_true.type_annotation
-        | _ -> simple_fail "can only type match_bool expressions yet" in
+        | _ -> simple_fail (thunk "can only type match_bool expressions yet") in
       ok O.{expression = E_matching (ex', m') ; type_annotation}
     )
 
@@ -433,60 +433,60 @@ and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value opt
   | "ADD", [a ; b] when type_value_eq (a, t_int ()) && type_value_eq (b, t_int ()) -> ok ("ADD_INT", t_int ())
   | "ADD", [a ; b] when type_value_eq (a, t_nat ()) && type_value_eq (b, t_nat ()) -> ok ("ADD_NAT", t_nat ())
   | "ADD", [a ; b] when type_value_eq (a, t_string ()) && type_value_eq (b, t_string ()) -> ok ("CONCAT", t_string ())
-  | "ADD", [_ ; _] -> simple_fail "bad types to add"
-  | "ADD", _ -> simple_fail "bad number of params to add"
+  | "ADD", [_ ; _] -> simple_fail (thunk "bad types to add")
+  | "ADD", _ -> simple_fail (thunk "bad number of params to add")
   | "TIMES", [a ; b] when type_value_eq (a, t_int ()) && type_value_eq (b, t_int ()) -> ok ("TIMES_INT", t_int ())
   | "TIMES", [a ; b] when type_value_eq (a, t_nat ()) && type_value_eq (b, t_nat ()) -> ok ("TIMES_NAT", t_nat ())
-  | "TIMES", [_ ; _] -> simple_fail "bad types to TIMES"
-  | "TIMES", _ -> simple_fail "bad number of params to TIMES"
+  | "TIMES", [_ ; _] -> simple_fail (thunk "bad types to TIMES")
+  | "TIMES", _ -> simple_fail (thunk "bad number of params to TIMES")
   | "EQ", [a ; b] when type_value_eq (a, t_int ()) && type_value_eq (b, t_int ()) -> ok ("EQ", t_bool ())
   | "EQ", [a ; b] when type_value_eq (a, t_nat ()) && type_value_eq (b, t_nat ()) -> ok ("EQ", t_bool ())
-  | "EQ", _ -> simple_fail "EQ only defined over int and nat"
+  | "EQ", _ -> simple_fail (thunk "EQ only defined over int and nat")
   | "LT", [a ; b] when type_value_eq (a, t_int ()) && type_value_eq (b, t_int ()) -> ok ("LT", t_bool ())
   | "LT", [a ; b] when type_value_eq (a, t_nat ()) && type_value_eq (b, t_nat ()) -> ok ("LT", t_bool ())
-  | "LT", _ -> simple_fail "LT only defined over int and nat"
+  | "LT", _ -> simple_fail (thunk "LT only defined over int and nat")
   | "OR", [a ; b] when type_value_eq (a, t_bool ()) && type_value_eq (b, t_bool ()) -> ok ("OR", t_bool ())
-  | "OR", _ -> simple_fail "OR only defined over bool"
+  | "OR", _ -> simple_fail (thunk "OR only defined over bool")
   | "AND", [a ; b] when type_value_eq (a, t_bool ()) && type_value_eq (b, t_bool ()) -> ok ("AND", t_bool ())
-  | "AND", _ -> simple_fail "AND only defined over bool"
+  | "AND", _ -> simple_fail (thunk "AND only defined over bool")
   | "NONE", [] -> (
       match tv_opt with
       | Some t -> ok ("NONE", t)
-      | None -> simple_fail "untyped NONE"
+      | None -> simple_fail (thunk "untyped NONE")
     )
-  | "NONE", _ -> simple_fail "bad number of params to NONE"
+  | "NONE", _ -> simple_fail (thunk "bad number of params to NONE")
   | "SOME", [s] -> ok ("SOME", t_option s ())
-  | "SOME", _ -> simple_fail "bad number of params to SOME"
+  | "SOME", _ -> simple_fail (thunk "bad number of params to SOME")
   | "MAP_REMOVE", [k ; m] ->
       let%bind (src, _) = get_t_map m in
       let%bind () = O.assert_type_value_eq (src, k) in
       ok ("MAP_REMOVE", m)
-  | "MAP_REMOVE", _ -> simple_fail "bad number of params to MAP_REMOVE"
+  | "MAP_REMOVE", _ -> simple_fail (thunk "bad number of params to MAP_REMOVE")
   | "MAP_UPDATE", [k ; v ; m] ->
       let%bind (src, dst) = get_t_map m in
       let%bind () = O.assert_type_value_eq (src, k) in
       let%bind () = O.assert_type_value_eq (dst, v) in
       ok ("MAP_UPDATE", m)
-  | "MAP_UPDATE", _ -> simple_fail "bad number of params to MAP_UPDATE"
+  | "MAP_UPDATE", _ -> simple_fail (thunk "bad number of params to MAP_UPDATE")
   | "get_force", [i_ty;m_ty] ->
       let%bind (src, dst) = get_t_map m_ty in
       let%bind _ = O.assert_type_value_eq (src, i_ty) in
       ok ("GET_FORCE", dst)
-  | "get_force", _ -> simple_fail "bad number of params to get_force"
+  | "get_force", _ -> simple_fail (thunk "bad number of params to get_force")
   | "size", [t] ->
       let%bind () = assert_t_map t in
       ok ("SIZE", t_nat ())
-  | "size", _ -> simple_fail "bad number of params to size"
+  | "size", _ -> simple_fail (thunk "bad number of params to size")
   | "int", [t] ->
       let%bind () = assert_t_nat t in
       ok ("INT", t_int ())
-  | "int", _ -> simple_fail "bad number of params to int"
+  | "int", _ -> simple_fail (thunk "bad number of params to int")
   | name, _ -> fail @@ unrecognized_constant name
 
 let untype_type_value (t:O.type_value) : (I.type_expression) result =
   match t.simplified with
   | Some s -> ok s
-  | _ -> simple_fail "trying to untype generated type"
+  | _ -> simple_fail (thunk "trying to untype generated type")
 
 let untype_literal (l:O.literal) : I.literal result =
   let open I in
@@ -574,11 +574,11 @@ and untype_instruction (i:O.instruction) : (I.instruction) result =
   | I_patch (s, p, e) ->
       let%bind e' = untype_annotated_expression e in
       let%bind (hds, tl) =
-        trace_option (simple_error "patch without path") @@
+        trace_option (fun () -> simple_error (thunk "patch without path") ()) @@
         List.rev_uncons_opt p in
       let%bind tl_name = match tl with
         | Access_record n -> ok n
-        | Access_tuple _ -> simple_fail "last element of patch is tuple" in
+        | Access_tuple _ -> simple_fail (thunk "last element of patch is tuple") in
       ok @@ I_record_patch (s.type_name, hds, [tl_name, e'])
 
 and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m ->