hide compiler errors; fix ligodity's over-eager tuplification

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

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 =

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 ;

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 () ->