From dffdc766fca3baebd658b883e52e513ceb357f42 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 11 Apr 2019 18:56:36 +0200 Subject: [PATCH] Lazy construction of error and trace messages so that the happy path is faster --- src/lib_utils/dictionary.ml | 2 +- src/lib_utils/trace.ml | 80 ++++++++++++---- src/ligo/ast_simplified.ml | 2 +- src/ligo/ast_typed.ml | 120 ++++++++++++------------ src/ligo/ligo.ml | 32 +++---- src/ligo/mini_c/combinators.ml | 34 +++---- src/ligo/mini_c/compiler.ml | 60 +++++++----- src/ligo/mini_c/compiler_environment.ml | 40 ++++---- src/ligo/mini_c/compiler_type.ml | 6 +- src/ligo/mini_c/run.ml | 12 +-- src/ligo/mini_c/uncompiler.ml | 12 +-- src/ligo/multifix/user.ml | 20 ++-- src/ligo/simplify.ml | 62 ++++++------ src/ligo/test/compiler_tests.ml | 2 +- src/ligo/test/heap_tests.ml | 4 +- src/ligo/test/integration_tests.ml | 58 ++++++------ src/ligo/test/test_helpers.ml | 4 +- src/ligo/transpiler.ml | 54 +++++------ src/ligo/typer.ml | 116 +++++++++++------------ 19 files changed, 388 insertions(+), 332 deletions(-) diff --git a/src/lib_utils/dictionary.ml b/src/lib_utils/dictionary.ml index 76fc8cb14..971423488 100644 --- a/src/lib_utils/dictionary.ml +++ b/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 = diff --git a/src/lib_utils/trace.ml b/src/lib_utils/trace.ml index 2c3001d24..3cf4c80ec 100644 --- a/src/lib_utils/trace.ml +++ b/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 diff --git a/src/ligo/ast_simplified.ml b/src/ligo/ast_simplified.ml index 81cb73401..727aec57a 100644 --- a/src/ligo/ast_simplified.ml +++ b/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])) ) ) diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index c0c3e4347..e4c86307c 100644 --- a/src/ligo/ast_typed.ml +++ b/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 diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index d0c805765..7b7d949e6 100644 --- a/src/ligo/ligo.ml +++ b/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 diff --git a/src/ligo/mini_c/combinators.ml b/src/ligo/mini_c/combinators.ml index cb7b33bf0..b9f0928be 100644 --- a/src/ligo/mini_c/combinators.ml +++ b/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 diff --git a/src/ligo/mini_c/compiler.ml b/src/ligo/mini_c/compiler.ml index 0ef9db8df..143263582 100644 --- a/src/ligo/mini_c/compiler.ml +++ b/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 diff --git a/src/ligo/mini_c/compiler_environment.ml b/src/ligo/mini_c/compiler_environment.ml index df6650f4f..efdd32e3b 100644 --- a/src/ligo/mini_c/compiler_environment.ml +++ b/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 diff --git a/src/ligo/mini_c/compiler_type.ml b/src/ligo/mini_c/compiler_type.ml index be0852e5e..57a16c35a 100644 --- a/src/ligo/mini_c/compiler_type.ml +++ b/src/ligo/mini_c/compiler_type.ml @@ -9,7 +9,7 @@ module Contract_types = Meta_michelson.Contract.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 diff --git a/src/ligo/mini_c/run.ml b/src/ligo/mini_c/run.ml index 9f2a3b5da..dbc8530eb 100644 --- a/src/ligo/mini_c/run.ml +++ b/src/ligo/mini_c/run.ml @@ -9,16 +9,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)) @@ -26,7 +26,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 @@ -48,5 +48,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) diff --git a/src/ligo/mini_c/uncompiler.ml b/src/ligo/mini_c/uncompiler.ml index 2914dad6d..1fcb8dfac 100644 --- a/src/ligo/mini_c/uncompiler.ml +++ b/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 diff --git a/src/ligo/multifix/user.ml b/src/ligo/multifix/user.ml index 6738970c1..56578baae 100644 --- a/src/ligo/multifix/user.ml +++ b/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 _ -> error "Unexpected char" - | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> + | Parser.Error -> (fun () -> error (thunk "Parse") ()) + | Lexer.Error s -> (fun () -> error (fun () -> "Lexer " ^ s) ()) + | Lexer.Unexpected_character _ -> error (thunk "Unexpected char") + | _ -> simple_error (thunk "unrecognized parse_ error") + )) @@ (fun () -> let raw = Parser.entry_point Lexer.token lexbuf in raw ) >>? fun raw -> diff --git a/src/ligo/simplify.ml b/src/ligo/simplify.ml index 3b5c7dbd4..5f2e1038d 100644 --- a/src/ligo/simplify.ml +++ b/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 diff --git a/src/ligo/test/compiler_tests.ml b/src/ligo/test/compiler_tests.ml index 93b8c17f0..55ebde7c5 100644 --- a/src/ligo/test/compiler_tests.ml +++ b/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 diff --git a/src/ligo/test/heap_tests.ml b/src/ligo/test/heap_tests.ml index 9a8612bbe..4f608379e 100644 --- a/src/ligo/test/heap_tests.ml +++ b/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 diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index dd84c32d7..15a97fe22 100644 --- a/src/ligo/test/integration_tests.ml +++ b/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 diff --git a/src/ligo/test/test_helpers.ml b/src/ligo/test/test_helpers.ml index d5e31b563..f0769829a 100644 --- a/src/ligo/test/test_helpers.ml +++ b/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 diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index 398fba47b..f542e8e8e 100644 --- a/src/ligo/transpiler.ml +++ b/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") diff --git a/src/ligo/typer.ml b/src/ligo/typer.ml index 3a97a26af..999ffede5 100644 --- a/src/ligo/typer.ml +++ b/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 ->