From 346a6fdbc4d258ee7bf86e44f4c157444bf0201c Mon Sep 17 00:00:00 2001 From: Galfour Date: Thu, 6 Jun 2019 21:06:33 +0000 Subject: [PATCH] hide compiler errors; fix ligodity's over-eager tuplification --- src/compiler/compiler_program.ml | 18 ++++++++++++- src/simplify/ligodity.ml | 45 ++++++++++++++++++++------------ src/test/integration_tests.ml | 2 +- src/test/test_helpers.ml | 29 ++++++++++++++++++++ 4 files changed, 76 insertions(+), 18 deletions(-) diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index e5b5b6632..db8e7936e 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -464,8 +464,24 @@ let translate_entry (p:anon_function) : compiled_program result = let%bind output = Compiler_type.Ty.type_ output in ok ({input;output;body}:compiled_program) +module Errors = struct + let corner_case ~loc message = + let title () = "corner case" in + let content () = "we don't have a good error message for this case. we are +striving find ways to better report them and find the use-cases that generate +them. please report this to the developers." in + let data = [ + ("location" , fun () -> loc) ; + ("message" , fun () -> message) ; + ] in + error ~data title content +end +open Errors + let translate_contract : anon_function -> michelson result = fun f -> - let%bind compiled_program = translate_entry f in + let%bind compiled_program = + trace_strong (corner_case ~loc:__LOC__ "compiling") @@ + translate_entry f in let%bind (param_ty , storage_ty) = Combinators.get_t_pair f.input in let%bind param_michelson = Compiler_type.type_ param_ty in let%bind storage_michelson = Compiler_type.type_ storage_ty in diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml index e938ad285..cd3a4472d 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -479,22 +479,35 @@ and simpl_fun lamb' : expr result = in bind_map_list aux p_args in - let arguments_name = "arguments" in - let (binder , input_type) = - let type_expression = T_tuple (List.map snd args') in - (arguments_name , type_expression) in - let%bind (body , body_type) = expr_to_typed_expr lamb.body in - let%bind output_type = - bind_map_option simpl_type_expression body_type in - let%bind result = simpl_expression body in - let wrapped_result = - let aux = fun i ((name : Raw.variable) , ty) wrapped -> - let accessor = e_accessor (e_variable arguments_name) [ Access_tuple i ] in - e_let_in (name.value , Some ty) accessor wrapped - in - let wraps = List.mapi aux args' in - List.fold_right' (fun x f -> f x) result wraps in - return @@ e_lambda ~loc binder (Some input_type) output_type wrapped_result + match args' with + | [ single ] -> ( + let (binder , input_type) = + ((fst single).value , snd single) in + let%bind (body , body_type) = expr_to_typed_expr lamb.body in + let%bind output_type = + bind_map_option simpl_type_expression body_type in + let%bind result = simpl_expression body in + return @@ e_lambda ~loc binder (Some input_type) output_type result + + ) + | _ -> ( + let arguments_name = "arguments" in + let (binder , input_type) = + let type_expression = T_tuple (List.map snd args') in + (arguments_name , type_expression) in + let%bind (body , body_type) = expr_to_typed_expr lamb.body in + let%bind output_type = + bind_map_option simpl_type_expression body_type in + let%bind result = simpl_expression body in + let wrapped_result = + let aux = fun i ((name : Raw.variable) , ty) wrapped -> + let accessor = e_accessor (e_variable arguments_name) [ Access_tuple i ] in + e_let_in (name.value , Some ty) accessor wrapped + in + let wraps = List.mapi aux args' in + List.fold_right' (fun x f -> f x) result wraps in + return @@ e_lambda ~loc binder (Some input_type) output_type wrapped_result + ) and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index ad7066bb7..ba9db500c 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -564,7 +564,7 @@ let main = test_suite "Integration (End to End)" [ (* test "guess the hash mligo" guess_the_hash_mligo ; WIP? *) (* test "failwith mligo" failwith_mligo ; *) (* test "guess string mligo" guess_string_mligo ; WIP? *) - (* test "lambda mligo" lambda_mligo ; *) + test "lambda mligo" lambda_mligo ; (* test "lambda2 mligo" lambda2_mligo ; *) test "website1 ligo" website1_ligo ; test "website2 ligo" website2_ligo ; diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 57b8246f8..5817845aa 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -5,6 +5,35 @@ type test = | Test_suite of (string * test list) | Test of test_case +let error_pp out (e : error) = + let open JSON_string_utils in + let message = + let opt = e |> member "message" |> string in + let msg = Option.unopt ~default:"" opt in + if msg = "" + then "" + else ": " ^ msg in + let error_code = + let error_code = e |> member "error_code" in + match error_code with + | `Null -> "" + | _ -> " (" ^ (J.to_string error_code) ^ ")" in + let title = + let opt = e |> member "title" |> string in + Option.unopt ~default:"" opt in + let data = + let data = e |> member "data" in + match data with + | `Null -> "" + | _ -> " " ^ (J.to_string data) ^ "\n" in + let infos = + let infos = e |> member "infos" in + match infos with + | `Null -> "" + | _ -> " " ^ (J.to_string infos) ^ "\n" in + Format.fprintf out "%s%s%s.\n%s%s" title error_code message data infos + + let test name f = Test ( Alcotest.test_case name `Quick @@ fun () ->