allow to catch failwith's in our tests

src/main/run/of_michelson.ml

@@ -35,6 +35,40 @@ let run ?options (* ?(is_input_value = false) *) (program:compiled_program) (inp
     Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in
   ok (Ex_typed_value (output_ty, output))
 
+type failwith_res =
+  | Failwith_int of int
+  | Failwith_string of string
+  | Failwith_bytes of bytes
+
+let get_exec_error_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : Memory_proto_alpha.Protocol.Script_repr.expr result =
+  let Compiler.Program.{input;output;body} : compiled_program = program in
+  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") @@
+    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") @@
+    Memory_proto_alpha.parse_michelson body
+      (Item_t (input_ty, Empty_t, None)) (Item_t (output_ty, Empty_t, None)) in
+  let%bind err =
+    Trace.trace_tzresult_lwt (simple_error "unexpected error of execution") @@
+    Memory_proto_alpha.failure_interpret ?options descr (Item(input, Empty)) in
+  match err with
+  | Memory_proto_alpha.Succeed _ -> simple_fail "an error of execution was expected" 
+  | Memory_proto_alpha.Fail expr ->
+    ok expr
+
+let get_exec_error ?options (program:compiled_program) (input_michelson:Michelson.t) : failwith_res result =
+  let%bind expr = get_exec_error_aux ?options program input_michelson in
+  match Tezos_micheline.Micheline.root @@ Memory_proto_alpha.strings_of_prims expr with
+  | Int (_ , i)    -> ok (Failwith_int (Z.to_int i))
+  | String (_ , s) -> ok (Failwith_string s)
+  | Bytes (_,b)    -> ok (Failwith_bytes b)
+  | _  -> simple_fail "Unknown failwith"
+
 let evaluate ?options program = run ?options program Michelson.d_unit
 
 let ex_value_ty_to_michelson (v : ex_typed_value) : Michelson.t result =

src/main/run/of_simplified.ml

@@ -23,6 +23,17 @@ let run_typed_program           (* TODO: this runs an *untyped* program, not a t
   let%bind ex_ty_value = Of_michelson.run ?options code input in
   Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value
 
+let run_failwith_program
+    ?options ?input_to_value
+    (program : Ast_typed.program) (state : Typer.Solver.state) (entry : string)
+    (input : expression) : Of_michelson.failwith_res result =
+  let%bind code = Compile.Of_typed.compile_function_entry program entry in
+  let%bind input =
+    let env = Ast_typed.program_environment program in
+    compile_expression ?value:input_to_value ~env ~state input
+  in
+  Of_michelson.get_exec_error ?options code input
+
 let evaluate_typed_program_entry
     ?options
     (program : Ast_typed.program) (entry : string)

src/test/test_helpers.ml

@@ -51,6 +51,12 @@ let expect_fail ?options program entry_point input =
   Assert.assert_fail
   @@ Ligo.Run.Of_simplified.run_typed_program ?options program Typer.Solver.initial_state entry_point input
 
+let expect_string_failwith ?options program entry_point input expected_failwith =
+  let%bind err = Ligo.Run.Of_simplified.run_failwith_program
+      ?options program Typer.Solver.initial_state entry_point input in
+  match err with
+    | Ligo.Run.Of_michelson.Failwith_string s -> Assert.assert_equal_string expected_failwith s
+    | _ -> simple_fail "Expected to fail with a string"
 
 let expect_eq ?input_to_value ?options program entry_point input expected =
   let expecter = fun result ->

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

@@ -5,6 +5,7 @@ open Memory_proto_alpha
 let (>>??) = Alpha_environment.Error_monad.(>>?)
 
 let alpha_wrap a = Alpha_environment.wrap_error a
+let alpha_error_wrap x = Memory_proto_alpha.Alpha_environment.Ecoproto_error x
 
 let force_ok_alpha ~msg a = force_ok ~msg @@ alpha_wrap a
 

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

@@ -1095,3 +1095,29 @@ let interpret ?(options = default_options) (instr:('a, 'b) descr) (bef:'a stack)
   let step_constants = { source ; self ; payer ; amount ; chain_id } in
   Script_interpreter.step tezos_context step_constants instr bef >>=??
   fun (stack, _) -> return stack
+
+type 'a interpret_res =
+  | Succeed of 'a stack
+  | Fail of Script_repr.expr
+
+let failure_interpret
+    ?(options = default_options) 
+    (instr:('a, 'b) descr)
+    (bef:'a stack) : 'b interpret_res tzresult Lwt.t =
+  let {
+    tezos_context ;
+    source ;
+    self ;
+    payer ;
+    amount ;
+    chain_id ;
+  } = options in
+  let step_constants = { source ; self ; payer ; amount ; chain_id } in
+  Script_interpreter.step tezos_context step_constants instr bef >>= fun x ->
+  match x with
+  | Ok (s , _ctxt) -> return @@ Succeed s
+  | Error ((Reject (_, expr, _))::_t) -> return @@ Fail expr (* This catches failwith errors *)
+  | Error errs -> Lwt.return @@ Error (List.map (alpha_error_wrap) errs)
+
+
+let strings_of_prims = Michelson_v1_primitives.strings_of_prims

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

@@ -764,6 +764,12 @@ module Assert = struct
   let assert_equal ?msg expected actual =
     assert_true ?msg (expected = actual)
 
+  let assert_equal_string ?msg expected actual =
+    let msg =
+      let default = Format.asprintf "Not equal string : expected \"%s\", got \"%s\"" expected actual in
+      X_option.unopt ~default msg in
+    assert_equal ~msg expected actual
+
   let assert_equal_int ?msg expected actual =
     let msg =
       let default = Format.asprintf "Not equal int : expected %d, got %d" expected actual in