more stuff

src/main/compile/of_simplified.ml

@@ -1,6 +1,15 @@
 open Ast_simplified
 open Trace
+open Tezos_utils
 
-let compile_entry (program : program) entry_point =
+let compile_function_entry (program : program) entry_point : Compiler.Program.compiled_program result =
   let%bind typed_program = Typer.type_program program in
-  Of_typed.compile_entry typed_program entry_point
+  Of_typed.compile_function_entry typed_program entry_point
+
+let compile_expression_entry (program : program) entry_point : Compiler.Program.compiled_program result =
+  let%bind typed_program = Typer.type_program program in
+  Of_typed.compile_expression_entry typed_program entry_point
+
+let compile_expression ae : Michelson.t result =
+  let%bind typed = Typer.type_expression Ast_typed.Environment.full_empty ae in
+  Of_typed.compile_expression typed

src/main/compile/of_source.ml

@@ -1 +1,19 @@
 open Trace
+open Helpers
+open Tezos_utils
+
+let parse_file_program source_filename syntax =
+  let%bind syntax = syntax_to_variant syntax (Some source_filename) in
+  let%bind simplified = parsify syntax source_filename in
+  ok simplified
+
+let compile_file_entry : string -> string -> s_syntax -> Compiler.Program.compiled_program result =
+  fun source_filename entry_point syntax ->
+  let%bind simplified = parse_file_program source_filename syntax in
+  Of_simplified.compile_function_entry simplified entry_point
+
+let compile_file_parameter : string -> string -> string -> s_syntax -> Michelson.t result =
+  fun source_filename _entry_point expression syntax ->
+  let%bind syntax = syntax_to_variant syntax (Some source_filename) in
+  let%bind simplified = parsify_expression syntax expression in
+  Of_simplified.compile_expression simplified

src/main/compile/of_typed.ml

@@ -2,10 +2,116 @@ open Trace
 open Ast_typed
 open Tezos_utils
 
+module Errors = struct
+
+  let missing_entry_point name =
+    let title () = "missing entry point" in
+    let content () = "no entry point with the given name" in
+    let data = [
+      ("name" , fun () -> name) ;
+    ] in
+    error ~data title content
+
+  let not_functional_main location =
+    let title () = "not functional main" in
+    let content () = "main should be a function" in
+    let data = [
+      ("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
+    ] in
+    error ~data title content
+
+end
+
+(*
+   This converts `expr` in `fun () -> expr`.
+*)
+let functionalize (body : annotated_expression) : annotated_expression =
+  let expression = E_lambda { binder = "_" ; body } in
+  let type_annotation = t_function (t_unit ()) body.type_annotation () in
+  { body with expression ; type_annotation }
+
 let compile_expression : annotated_expression -> Michelson.t result = fun e ->
-  let%bind mini_c_expression = Transpiler.translate_annotated_expression e in
+  let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in
   Of_mini_c.compile_expression mini_c_expression
 
-let compile_entry : program -> string -> _ = fun p entry ->
+(*
-  let%bind (f , (in_ty , out_ty)) = Transpiler.translate_entry p entry in
+   val compile_value : annotated_expression -> Michelson.t result
+   This requires writing a function
+   `transpile_expression_as_value : annotated_expression -> Mini_c.value result`
+ *)
+
+let compile_function expr =
+  let%bind l = get_lambda expr.expression in
+  let%bind io = get_t_function expr.type_annotation in
+  let%bind mini_c = Transpiler.transpile_lambda Mini_c.Environment.empty l io in
+  let%bind (f , (in_ty , out_ty)) =
+    match (mini_c.content , mini_c.type_value) with
+    | E_literal (D_function f) , T_function ty -> ok (f , ty)
+    | _ -> fail @@ Errors.not_functional_main expr.location
+  in
   Of_mini_c.compile_function f in_ty out_ty
+
+(*
+   Assume the following code:
+   ```
+     const x = 42
+     const y = 120
+     const z = 423
+     const f = () -> x + y
+   ```
+   It is transformed in:
+   ```
+     const f = () ->
+       let x = 42 in
+       let y = 120 in
+       let z = 423 in
+       x + y
+   ```
+
+   To do so, each declaration `const variable = expr` is translated in
+   a function `body -> let variable = expr in body`. Those functions are
+   then applied in order, which yields `let x = 42 in let y = 120 in ...`.
+
+   The entry-point can be an expression, which is then functionalized if
+   `to_functionalize` is set to true.
+*)
+let aggregate_declarations_for_entry (lst : program) (name : string) (to_functionalize : bool) : annotated_expression result =
+  let rec aux acc (lst : program) =
+    let%bind acc = acc in
+    match lst with
+    | [] -> fail @@ Errors.missing_entry_point name
+    | hd :: tl -> (
+        let (Declaration_constant (an , (pre_env , _))) = Location.unwrap hd in
+        if (an.name <> name) then (
+          let next = fun expr ->
+            let cur = e_a_let_in an.name an.annotated_expression expr pre_env in
+            acc cur in
+          aux (ok next) tl
+        ) else (
+          match (an.annotated_expression.expression , to_functionalize) with
+          | (E_lambda l , false) -> (
+            let l' = { l with body = acc l.body } in
+            let e' = { an.annotated_expression with expression = E_lambda l' } in
+            ok e'
+          )
+          | (_ , true) -> (
+              ok @@ functionalize @@ acc an.annotated_expression
+            )
+          | _ -> fail @@ Errors.not_functional_main an.annotated_expression.location
+        )
+      )
+  in
+  let%bind l = aux (ok (fun x -> x)) lst in
+  ok l
+
+let compile_function_entry : program -> string -> _ = fun p entry ->
+  let%bind expr = aggregate_declarations_for_entry p entry false in
+  compile_function expr
+
+let compile_expression_entry : program -> string -> _ = fun p entry ->
+  let%bind expr = aggregate_declarations_for_entry p entry true in
+  compile_function expr
+
+let compile_expression_as_function : annotated_expression -> Compiler.Program.compiled_program result = fun e ->
+  let expr = functionalize e in
+  compile_function expr

src/main/dune

@@ -0,0 +1,12 @@
+(library
+  (name main)
+  (public_name ligo.main)
+  (libraries
+    run
+    compile
+  )
+  (preprocess
+    (pps ppx_let)
+  )
+  (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
+)

src/main/main.ml

@@ -0,0 +1,2 @@
+module Run = Run
+module Compile = Compile

src/main/run/run_mini_c.ml

@@ -4,6 +4,13 @@ open Trace
 open Mini_c
 open Compiler.Program
 
+module Errors = struct
+
+  let entry_error =
+    simple_error "error translating entry point"
+
+end
+
 type options = {
   entry_point : anon_function ;
   input_type : type_value ;
@@ -14,7 +21,7 @@ type options = {
 
 let run_entry ?(debug_michelson = false) ?options (entry : anon_function) ty (input:value) : value result =
   let%bind compiled =
-    trace error @@
+    trace Errors.entry_error @@
     translate_entry entry ty in
   let%bind input_michelson = translate_value input (fst ty) in
   if debug_michelson then (

src/main/run/run_typed.ml

@@ -1,7 +1,7 @@
 open Trace
+open Ast_typed
 
-let transpile_value
+let evaluate (e : annotated_expression) : annotated_expression result =
-    (e:Ast_typed.annotated_expression) : Mini_c.value result =
   let%bind (f , ty) =
     let open Transpiler in
     let (f , _) = functionalize e in
@@ -33,6 +33,7 @@ let evaluate_typed
 let run_typed
     ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string)
     (program : Ast_typed.program) (input : Ast_typed.annotated_expression) : Ast_typed.annotated_expression result =
+  let%bind 
   let%bind () =
     let open Ast_typed in
     let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in

src/passes/4-typer/typer.ml

@@ -582,9 +582,9 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
         bind_map_option (evaluate_type e) output_type
       in
       let e' = Environment.add_ez_binder (fst binder) input_type e in
-      let%bind result = type_expression ?tv_opt:output_type e' result in
+      let%bind body = type_expression ?tv_opt:output_type e' result in
-      let output_type = result.type_annotation in
+      let output_type = body.type_annotation in
-      return (E_lambda {binder = fst binder;input_type;output_type;result}) (t_function input_type output_type ())
+      return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ())
     )
   | E_constant (name, lst) ->
       let%bind lst' = bind_list @@ List.map (type_expression e) lst in
@@ -796,11 +796,12 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
       let%bind f' = untype_expression f in
       let%bind arg' = untype_expression arg in
       return (e_application f' arg')
-  | E_lambda {binder;input_type;output_type;result} ->
+  | E_lambda {binder ; body} -> (
-      let%bind input_type = untype_type_value input_type in
+      let%bind io = get_t_function e.type_annotation in
-      let%bind output_type = untype_type_value output_type in
+      let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
-      let%bind result = untype_expression result in
+      let%bind result = untype_expression body in
       return (e_lambda binder (Some input_type) (Some output_type) result)
+    )
   | E_tuple lst ->
       let%bind lst' = bind_list
         @@ List.map untype_expression lst in

src/passes/6-transpiler/helpers.ml

@@ -0,0 +1,49 @@
+module AST = Ast_typed
+module Append_tree = Tree.Append
+
+open Trace
+open Mini_c
+
+let list_of_map m = List.rev @@ Map.String.fold (fun _ v prev -> v :: prev) m []
+let kv_list_of_map m = List.rev @@ Map.String.fold (fun k v prev -> (k, v) :: prev) m []
+let map_of_kv_list lst =
+  let open AST.SMap in
+  List.fold_left (fun prev (k, v) -> add k v prev) empty lst
+
+let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
+  let open Append_tree in
+  let rec aux tv : (string * value * AST.type_value) result=
+    match tv with
+    | Leaf (k, t), v -> ok (k, v, t)
+    | Node {a}, D_left v -> aux (a, v)
+    | Node {b}, D_right v -> aux (b, v)
+    | _ -> fail @@ internal_assertion_failure "bad constructor path"
+  in
+  let%bind (s, v, t) = aux (tree, v) in
+  ok (s, v, t)
+
+let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result =
+  let open Append_tree in
+  let rec aux tv : ((value * AST.type_value) list) result =
+    match tv with
+    | Leaf t, v -> ok @@ [v, t]
+    | Node {a;b}, D_pair (va, vb) ->
+        let%bind a' = aux (a, va) in
+        let%bind b' = aux (b, vb) in
+        ok (a' @ b')
+    | _ -> fail @@ internal_assertion_failure "bad tuple path"
+  in
+  aux (tree, v)
+
+let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
+  let open Append_tree in
+  let rec aux tv : ((string * (value * AST.type_value)) list) result =
+    match tv with
+    | Leaf (s, t), v -> ok @@ [s, (v, t)]
+    | Node {a;b}, D_pair (va, vb) ->
+        let%bind a' = aux (a, va) in
+        let%bind b' = aux (b, vb) in
+        ok (a' @ b')
+    | _ -> fail @@ internal_assertion_failure "bad record path"
+  in
+  aux (tree, v)

src/passes/6-transpiler/transpiler.ml

@@ -1,4 +1,5 @@
 open! Trace
+open Helpers
 
 module AST = Ast_typed
 module Append_tree = Tree.Append
@@ -6,15 +7,11 @@ open AST.Combinators
 open Mini_c
 open Combinators
 
+let untranspile = Untranspiler.untranspile
+
 let temp_unwrap_loc = Location.unwrap
 let temp_unwrap_loc_list = List.map Location.unwrap
 
-let list_of_map m = List.rev @@ Map.String.fold (fun _ v prev -> v :: prev) m []
-let kv_list_of_map m = List.rev @@ Map.String.fold (fun k v prev -> (k, v) :: prev) m []
-let map_of_kv_list lst =
-  let open AST.SMap in
-  List.fold_left (fun prev (k, v) -> add k v prev) empty lst
-
 module Errors = struct
   let corner_case ~loc message =
     let title () = "corner case" in
@@ -49,53 +46,10 @@ them. please report this to the developers." in
         row_loc location ;
       ] in
     error ~data title content
-
-  let not_functional_main location =
-    let title () = "not functional main" in
-    let content () = "main should be a function" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
-    ] in
-    error ~data title content
-
-  let missing_entry_point name =
-    let title () = "missing entry point" in
-    let content () = "no entry point with the given name" in
-    let data = [
-      ("name" , fun () -> name) ;
-    ] in
-    error ~data title content
-
-  let wrong_mini_c_value expected_type actual =
-    let title () = "illed typed intermediary value" in
-    let content () = "type of intermediary value doesn't match what was expected" in
-    let data = [
-      ("expected_type" , fun () -> expected_type) ;
-      ("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ;
-    ] in
-    error ~data title content
-
-  let bad_untranspile bad_type value =
-    let title () = "untranspiling bad value" in
-    let content () = Format.asprintf "can not untranspile %s" bad_type in
-    let data = [
-      ("bad_type" , fun () -> bad_type) ;
-      ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
-    ] in
-    error ~data title content
-
-  let unknown_untranspile unknown_type value =
-    let title () = "untranspiling unknown value" in
-    let content () = Format.asprintf "can not untranspile %s" unknown_type in
-    let data = [
-      ("unknown_type" , fun () -> unknown_type) ;
-      ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
-    ] in
-    error ~data title content
 end
 open Errors
 
-let rec translate_type (t:AST.type_value) : type_value result =
+let rec transpile_type (t:AST.type_value) : type_value result =
   match t.type_value' with
   | T_constant ("bool", []) -> ok (T_base Base_bool)
   | T_constant ("int", []) -> ok (T_base Base_int)
@@ -108,19 +62,19 @@ let rec translate_type (t:AST.type_value) : type_value result =
   | T_constant ("unit", []) -> ok (T_base Base_unit)
   | T_constant ("operation", []) -> ok (T_base Base_operation)
   | T_constant ("contract", [x]) ->
-      let%bind x' = translate_type x in
+      let%bind x' = transpile_type x in
       ok (T_contract x')
   | T_constant ("map", [key;value]) ->
-      let%bind kv' = bind_map_pair translate_type (key, value) in
+      let%bind kv' = bind_map_pair transpile_type (key, value) in
       ok (T_map kv')
   | T_constant ("list", [t]) ->
-      let%bind t' = translate_type t in
+      let%bind t' = transpile_type t in
       ok (T_list t')
   | T_constant ("set", [t]) ->
-      let%bind t' = translate_type t in
+      let%bind t' = transpile_type t in
       ok (T_set t')
   | T_constant ("option", [o]) ->
-      let%bind o' = translate_type o in
+      let%bind o' = transpile_type o in
       ok (T_option o')
   | T_constant (name , _lst) -> fail @@ unrecognized_type_constant name
   | T_sum m ->
@@ -130,7 +84,7 @@ let rec translate_type (t:AST.type_value) : type_value result =
         let%bind b = b in
         ok (T_or (a, b))
       in
-      Append_tree.fold_ne translate_type aux node
+      Append_tree.fold_ne transpile_type aux node
   | T_record m ->
       let node = Append_tree.of_list @@ list_of_map m in
       let aux a b : type_value result =
@@ -138,7 +92,7 @@ let rec translate_type (t:AST.type_value) : type_value result =
         let%bind b = b in
         ok (T_pair (a, b))
       in
-      Append_tree.fold_ne translate_type aux node
+      Append_tree.fold_ne transpile_type aux node
   | T_tuple lst ->
       let node = Append_tree.of_list lst in
       let aux a b : type_value result =
@@ -146,10 +100,10 @@ let rec translate_type (t:AST.type_value) : type_value result =
         let%bind b = b in
         ok (T_pair (a, b))
       in
-      Append_tree.fold_ne translate_type aux node
+      Append_tree.fold_ne transpile_type aux node
   | T_function (param, result) -> (
-      let%bind param' = translate_type param in
+      let%bind param' = transpile_type param in
-      let%bind result' = translate_type result in
+      let%bind result' = transpile_type result in
       ok (T_function (param', result'))
     )
 
@@ -191,7 +145,7 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -
     bind_fold_list aux (ty , []) lr_path in
   ok lst
 
-let rec translate_literal : AST.literal -> value = fun l -> match l with
+let rec transpile_literal : AST.literal -> value = fun l -> match l with
   | Literal_bool b -> D_bool b
   | Literal_int n -> D_int n
   | Literal_nat n -> D_nat n
@@ -206,12 +160,12 @@ let rec translate_literal : AST.literal -> value = fun l -> match l with
 and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele ->
   match (AST.get_type' ele.type_value , ele.definition) with
   | (AST.T_function (f , arg) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) ->
-    let%bind f' = translate_type f in
+    let%bind f' = transpile_type f in
-    let%bind arg' = translate_type arg in
+    let%bind arg' = transpile_type arg in
     let%bind env' = transpile_environment ae.environment in
     let sub_env = Mini_c.Environment.select captured_variables env' in
     ok @@ Combinators.t_deep_closure sub_env f' arg'
-  | _ -> translate_type ele.type_value
+  | _ -> transpile_type ele.type_value
 
 and transpile_small_environment : AST.small_environment -> Environment.t result = fun x ->
   let x' = AST.Environment.Small.get_environment x in
@@ -231,10 +185,10 @@ and tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t r
   let%bind map_tv = get_t_sum t in
   ok @@ Append_tree.of_list @@ kv_list_of_map map_tv
 
-and translate_annotated_expression (ae:AST.annotated_expression) : expression result =
+and transpile_annotated_expression (ae:AST.annotated_expression) : expression result =
-  let%bind tv = translate_type ae.type_annotation in
+  let%bind tv = transpile_type ae.type_annotation in
   let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in
-  let f = translate_annotated_expression in
+  let f = transpile_annotated_expression in
   let info =
     let title () = "translating expression" in
     let content () = Format.asprintf "%a" Location.pp ae.location in
@@ -242,14 +196,14 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
   trace info @@
   match ae.expression with
   | E_let_in {binder; rhs; result} ->
-    let%bind rhs' = translate_annotated_expression rhs in
+    let%bind rhs' = transpile_annotated_expression rhs in
-    let%bind result' = translate_annotated_expression result in
+    let%bind result' = transpile_annotated_expression result in
     return (E_let_in ((binder, rhs'.type_value), rhs', result'))
   | E_failwith ae -> (
-      let%bind ae' = translate_annotated_expression ae in
+      let%bind ae' = transpile_annotated_expression ae in
       return @@ E_constant ("FAILWITH" , [ae'])
     )
-  | E_literal l -> return @@ E_literal (translate_literal l)
+  | E_literal l -> return @@ E_literal (transpile_literal l)
   | E_variable name -> (
       let%bind ele =
         trace_option (corner_case ~loc:__LOC__ "name not in environment") @@
@@ -258,11 +212,11 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       return ~tv @@ E_variable name
     )
   | E_application (a, b) ->
-      let%bind a = translate_annotated_expression a in
+      let%bind a = transpile_annotated_expression a in
-      let%bind b = translate_annotated_expression b in
+      let%bind b = transpile_annotated_expression b in
       return @@ E_application (a, b)
   | E_constructor (m, param) -> (
-      let%bind param' = translate_annotated_expression param in
+      let%bind param' = transpile_annotated_expression param in
       let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in
       let%bind node_tv =
         trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
@@ -274,7 +228,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
             @@ AST.assert_type_value_eq (tv, param.type_annotation) in
           ok (Some (param'_expr), param'_tv)
         ) else (
-          let%bind tv = translate_type tv in
+          let%bind tv = transpile_type tv in
           ok (None, tv)
         ) in
       let node a b : (expression' option * type_value) result =
@@ -302,14 +256,14 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
         let tv = T_pair (a_ty , b_ty) in
         return ~tv @@ E_constant ("PAIR", [a; b])
       in
-      Append_tree.fold_ne (translate_annotated_expression) aux node
+      Append_tree.fold_ne (transpile_annotated_expression) aux node
     )
   | E_tuple_accessor (tpl, ind) -> (
-      let%bind ty' = translate_type tpl.type_annotation in
+      let%bind ty' = transpile_type tpl.type_annotation in
       let%bind ty_lst =
         trace_strong (corner_case ~loc:__LOC__ "not a tuple") @@
         get_t_tuple tpl.type_annotation in
-      let%bind ty'_lst = bind_map_list translate_type ty_lst in
+      let%bind ty'_lst = bind_map_list transpile_type ty_lst in
       let%bind path =
         trace_strong (corner_case ~loc:__LOC__ "tuple access") @@
         tuple_access_to_lr ty' ty'_lst ind in
@@ -318,7 +272,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
           | `Left -> "CAR"
           | `Right -> "CDR" in
         Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
-      let%bind tpl' = translate_annotated_expression tpl in
+      let%bind tpl' = transpile_annotated_expression tpl in
       let expr = List.fold_left aux tpl' path in
       ok expr
     )
@@ -333,14 +287,14 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
         return ~tv @@ E_constant ("PAIR", [a; b])
       in
       trace_strong (corner_case ~loc:__LOC__ "record build") @@
-      Append_tree.fold_ne (translate_annotated_expression) aux node
+      Append_tree.fold_ne (transpile_annotated_expression) aux node
     )
   | E_record_accessor (record, property) ->
-      let%bind ty' = translate_type (get_type_annotation record) in
+      let%bind ty' = transpile_type (get_type_annotation record) in
       let%bind ty_smap =
         trace_strong (corner_case ~loc:__LOC__ "not a record") @@
         get_t_record (get_type_annotation record) in
-      let%bind ty'_smap = bind_map_smap translate_type ty_smap in
+      let%bind ty'_smap = bind_map_smap transpile_type ty_smap in
       let%bind path =
         trace_strong (corner_case ~loc:__LOC__ "record access") @@
         record_access_to_lr ty' ty'_smap property in
@@ -349,7 +303,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
           | `Left -> "CAR"
           | `Right -> "CDR" in
         Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
-      let%bind record' = translate_annotated_expression record in
+      let%bind record' = transpile_annotated_expression record in
       let expr = List.fold_left aux record' path in
       ok expr
   | E_constant (name , lst) -> (
@@ -358,8 +312,9 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
           | [i ; f] -> (
               let%bind f' = match f.expression with
                 | E_lambda l -> (
-                    let%bind body' = translate_annotated_expression l.result in
+                    let%bind body' = transpile_annotated_expression l.body in
-                    let%bind input' = translate_type l.input_type in
+                    let%bind (input , _) = get_t_function f.type_annotation in
+                    let%bind input' = transpile_type input in
                     ok ((l.binder , input') , body')
                   )
                 | E_variable v -> (
@@ -370,8 +325,9 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
                     | ED_declaration (f , _) -> (
                         match f.expression with
                         | E_lambda l -> (
-                            let%bind body' = translate_annotated_expression l.result in
+                            let%bind body' = transpile_annotated_expression l.body in
-                            let%bind input' = translate_type l.input_type in
+                            let%bind (input , _) = get_t_function f.type_annotation in
+                            let%bind input' = transpile_type input in
                             ok ((l.binder , input') , body')
                           )
                         | _ -> fail @@ unsupported_iterator f.location
@@ -380,7 +336,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
                   )
                 | _ -> fail @@ unsupported_iterator f.location
               in
-              let%bind i' = translate_annotated_expression i in
+              let%bind i' = transpile_annotated_expression i in
               return @@ E_iterator (name , f' , i')
             )
           | _ -> fail @@ corner_case ~loc:__LOC__ "bad iterator arity"
@@ -393,7 +349,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       | ("LIST_MAP" , lst) -> map lst
       | ("MAP_MAP" , lst) -> map lst
       | _ -> (
-          let%bind lst' = bind_map_list (translate_annotated_expression) lst in
+          let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
           return @@ E_constant (name , lst')
         )
     )
@@ -401,12 +357,13 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
     let%bind env =
       trace_strong (corner_case ~loc:__LOC__ "environment") @@
       transpile_environment ae.environment in
-    translate_lambda env l
+    let%bind io = get_t_function ae.type_annotation in
+    transpile_lambda env l io
   | E_list lst -> (
       let%bind t =
         trace_strong (corner_case ~loc:__LOC__ "not a list") @@
         Mini_c.Combinators.get_t_list tv in
-      let%bind lst' = bind_map_list (translate_annotated_expression) lst in
+      let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
       let aux : expression -> expression -> expression result = fun prev cur ->
         return @@ E_constant ("CONS", [cur ; prev]) in
       let%bind (init : expression) = return @@ E_make_empty_list t in
@@ -416,7 +373,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind t =
         trace_strong (corner_case ~loc:__LOC__ "not a set") @@
         Mini_c.Combinators.get_t_set tv in
-      let%bind lst' = bind_map_list (translate_annotated_expression) lst in
+      let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
       let aux : expression -> expression -> expression result = fun prev cur ->
         return @@ E_constant ("SET_ADD", [cur ; prev]) in
       let%bind (init : expression) = return @@ E_make_empty_set t in
@@ -430,7 +387,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
         let%bind prev' = prev in
         let%bind (k', v') =
           let v' = e_a_some v ae.environment in
-          bind_map_pair (translate_annotated_expression) (k , v') in
+          bind_map_pair (transpile_annotated_expression) (k , v') in
         return @@ E_constant ("UPDATE", [k' ; v' ; prev'])
       in
       let init = return @@ E_make_empty_map (src, dst) in
@@ -441,26 +398,26 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       return @@ E_constant ("MAP_GET", [i' ; ds'])
     )
   | E_sequence (a , b) -> (
-      let%bind a' = translate_annotated_expression a in
+      let%bind a' = transpile_annotated_expression a in
-      let%bind b' = translate_annotated_expression b in
+      let%bind b' = transpile_annotated_expression b in
       return @@ E_sequence (a' , b')
     )
   | E_loop (expr , body) -> (
-      let%bind expr' = translate_annotated_expression expr in
+      let%bind expr' = transpile_annotated_expression expr in
-      let%bind body' = translate_annotated_expression body in
+      let%bind body' = transpile_annotated_expression body in
       return @@ E_while (expr' , body')
     )
   | E_assign (typed_name , path , expr) -> (
       let ty = typed_name.type_value in
       let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result =
         fun (prev, acc) cur ->
-          let%bind ty' = translate_type prev in
+          let%bind ty' = transpile_type prev in
           match cur with
           | Access_tuple ind -> (
               let%bind ty_lst =
                 trace_strong (corner_case ~loc:__LOC__ "not a tuple") @@
                 AST.Combinators.get_t_tuple prev in
-              let%bind ty'_lst = bind_map_list translate_type ty_lst in
+              let%bind ty'_lst = bind_map_list transpile_type ty_lst in
               let%bind path = tuple_access_to_lr ty' ty'_lst ind in
               let path' = List.map snd path in
               ok (List.nth ty_lst ind, acc @ path')
@@ -469,7 +426,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
             let%bind ty_map =
                 trace_strong (corner_case ~loc:__LOC__ "not a record") @@
                 AST.Combinators.get_t_record prev in
-              let%bind ty'_map = bind_map_smap translate_type ty_map in
+              let%bind ty'_map = bind_map_smap transpile_type ty_map in
               let%bind path = record_access_to_lr ty' ty'_map prop in
               let path' = List.map snd path in
             ok (Map.String.find prop ty_map, acc @ path')
@@ -477,20 +434,20 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
           | Access_map _k -> fail (corner_case ~loc:__LOC__ "no patch for map yet")
       in
       let%bind (_, path) = bind_fold_right_list aux (ty, []) path in
-      let%bind expr' = translate_annotated_expression expr in
+      let%bind expr' = transpile_annotated_expression expr in
       return (E_assignment (typed_name.type_name, path, expr'))
     )
   | E_matching (expr, m) -> (
-      let%bind expr' = translate_annotated_expression expr in
+      let%bind expr' = transpile_annotated_expression expr in
       match m with
       | Match_bool {match_true ; match_false} ->
-          let%bind (t , f) = bind_map_pair (translate_annotated_expression) (match_true, match_false) in
+          let%bind (t , f) = bind_map_pair (transpile_annotated_expression) (match_true, match_false) in
           return @@ E_if_bool (expr', t, f)
       | Match_option { match_none; match_some = ((name, tv), s) } ->
-          let%bind n = translate_annotated_expression match_none in
+          let%bind n = transpile_annotated_expression match_none in
           let%bind (tv' , s') =
-            let%bind tv' = translate_type tv in
+            let%bind tv' = transpile_type tv in
-            let%bind s' = translate_annotated_expression s in
+            let%bind s' = transpile_annotated_expression s in
             ok (tv' , s') in
           return @@ E_if_none (expr' , n , ((name , tv') , s'))
       | Match_variant (lst , variant) -> (
@@ -504,7 +461,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
             let rec aux t =
               match (t : _ Append_tree.t') with
               | Leaf (name , tv) ->
-                  let%bind tv' = translate_type tv in
+                  let%bind tv' = transpile_type tv in
                   ok (`Leaf name , tv')
               | Node {a ; b} ->
                   let%bind a' = aux a in
@@ -520,7 +477,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
                 let%bind ((_ , name) , body) =
                   trace_option (corner_case ~loc:__LOC__ "missing match clause") @@
                   List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
-                let%bind body' = translate_annotated_expression body in
+                let%bind body' = transpile_annotated_expression body in
                 return @@ E_let_in ((name , tv) , top , body')
               )
             | ((`Node (a , b)) , tv) ->
@@ -545,284 +502,54 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       | AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location
     )
 
-and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l ->
+and transpile_lambda_deep : Mini_c.Environment.t -> AST.lambda -> _ -> Mini_c.expression result =
-  let { binder ; input_type ; output_type ; result } : AST.lambda = l in
+  fun env l (input_type , output_type)->
+  let { binder ; body } : AST.lambda = l in
   (* Deep capture. Capture the relevant part of the environment. *)
   let%bind c_env =
     let free_variables = Ast_typed.Free_variables.lambda [] l in
     let sub_env = Mini_c.Environment.select free_variables env in
     ok sub_env in
   let%bind (f_expr' , input_tv , output_tv) =
-    let%bind raw_input = translate_type input_type in
+    let%bind raw_input = transpile_type input_type in
-    let%bind output = translate_type output_type in
+    let%bind output = transpile_type output_type in
-    let%bind result = translate_annotated_expression result in
+    let%bind result = transpile_annotated_expression body in
     let expr' = E_closure { binder ; result } in
     ok (expr' , raw_input , output) in
   let tv = Mini_c.t_deep_closure c_env input_tv output_tv in
   ok @@ Expression.make_tpl (f_expr' , tv)
 
-and translate_lambda env l =
+and transpile_lambda env l (input_type , output_type) =
-  let { binder ; input_type ; output_type ; result } : AST.lambda = l in
+  let { binder ; body } : AST.lambda = l in
-  (* Try to translate it in an empty env, if it succeeds, transpiles it as a quote value, else, as a closure expression. *)
+  let fvs = AST.Free_variables.(annotated_expression (singleton binder) body) in
-  let fvs = AST.Free_variables.(annotated_expression (singleton binder) result) in
   let%bind result =
     match fvs with
     | [] -> (
-        let%bind result' = translate_annotated_expression result in
+        let%bind result' = transpile_annotated_expression body in
-        let result' = ez_e_return result' in
+        let%bind input = transpile_type input_type in
-        let%bind input = translate_type input_type in
+        let%bind output = transpile_type output_type in
-        let%bind output = translate_type output_type in
         let tv = Combinators.t_function input output in
         let content = D_function { binder ; result = result'} in
         ok @@ Combinators.Expression.make_tpl (E_literal content , tv)
       )
     | _ -> (
-        translate_lambda_deep env l
+        transpile_lambda_deep env l (input_type , output_type)
       ) in
   ok result
 
-let translate_declaration env (d:AST.declaration) : toplevel_statement result =
+let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
   match d with
   | Declaration_constant ({name;annotated_expression} , _) ->
-      let%bind expression = translate_annotated_expression annotated_expression in
+      let%bind expression = transpile_annotated_expression annotated_expression in
       let tv = Combinators.Expression.get_type expression in
       let env' = Environment.add (name, tv) env in
       ok @@ ((name, expression), environment_wrap env env')
 
-let translate_program (lst:AST.program) : program result =
+let transpile_program (lst:AST.program) : program result =
   let aux (prev:(toplevel_statement list * Environment.t) result) cur =
     let%bind (tl, env) = prev in
-    let%bind ((_, env') as cur') = translate_declaration env cur in
+    let%bind ((_, env') as cur') = transpile_declaration env cur in
     ok (cur' :: tl, env'.post_environment)
   in
   let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in
   ok statements
-
-let translate_main (l:AST.lambda) loc : (anon_function * _) result =
-  let%bind expr = translate_lambda Environment.empty l in
-  match expr.content , expr.type_value with
-  | E_literal (D_function f) , T_function ty -> ok (f , ty)
-  | _ -> fail @@ not_functional_main loc
-
-(* From an expression [expr], build the expression [fun () -> expr] *)
-let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value =
-  let t = e.type_annotation in
-  let open! AST in
-  {
-    binder = "_" ;
-    input_type = Combinators.t_unit () ;
-    output_type = t ;
-    result = e ;
-  }, Combinators.(t_function (t_unit ()) t ())
-
-let translate_entry (lst:AST.program) (name:string) : (anon_function * _) result =
-  let rec aux acc (lst:AST.program) =
-    let%bind acc = acc in
-    match lst with
-    | [] -> fail @@ missing_entry_point name
-    | hd :: tl -> (
-        let (AST.Declaration_constant (an , (pre_env , _))) = temp_unwrap_loc hd in
-        match an.name = name with
-        | false -> (
-            let next = fun expr ->
-              let cur = e_a_let_in an.name an.annotated_expression expr pre_env in
-              acc cur in
-            aux (ok next) tl
-          )
-        | true -> (
-            match an.annotated_expression.expression with
-            | E_lambda l ->
-              let l' = { l with result = acc l.result } in
-              translate_main l' an.annotated_expression.location
-            | _ ->
-              let (l , _) = functionalize an.annotated_expression in
-              let l' = { l with result = acc l.result } in
-              translate_main l' an.annotated_expression.location
-          )
-      )
-  in
-  let%bind l = aux (ok (fun x -> x)) lst in
-  ok l
-
-open Combinators
-
-let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
-  let open Append_tree in
-  let rec aux tv : (string * value * AST.type_value) result=
-    match tv with
-    | Leaf (k, t), v -> ok (k, v, t)
-    | Node {a}, D_left v -> aux (a, v)
-    | Node {b}, D_right v -> aux (b, v)
-    | _ -> fail @@ internal_assertion_failure "bad constructor path"
-  in
-  let%bind (s, v, t) = aux (tree, v) in
-  ok (s, v, t)
-
-let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result =
-  let open Append_tree in
-  let rec aux tv : ((value * AST.type_value) list) result =
-    match tv with
-    | Leaf t, v -> ok @@ [v, t]
-    | Node {a;b}, D_pair (va, vb) ->
-        let%bind a' = aux (a, va) in
-        let%bind b' = aux (b, vb) in
-        ok (a' @ b')
-    | _ -> fail @@ internal_assertion_failure "bad tuple path"
-  in
-  aux (tree, v)
-
-let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
-  let open Append_tree in
-  let rec aux tv : ((string * (value * AST.type_value)) list) result =
-    match tv with
-    | Leaf (s, t), v -> ok @@ [s, (v, t)]
-    | Node {a;b}, D_pair (va, vb) ->
-        let%bind a' = aux (a, va) in
-        let%bind b' = aux (b, vb) in
-        ok (a' @ b')
-    | _ -> fail @@ internal_assertion_failure "bad record path"
-  in
-  aux (tree, v)
-
-let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result =
-  let open! AST in
-  let return e = ok (make_a_e_empty e t) in
-  match t.type_value' with
-  | T_constant ("unit", []) -> (
-      let%bind () =
-        trace_strong (wrong_mini_c_value "unit" v) @@
-        get_unit v in
-      return (E_literal Literal_unit)
-    )
-  | T_constant ("bool", []) -> (
-      let%bind b =
-        trace_strong (wrong_mini_c_value "bool" v) @@
-        get_bool v in
-      return (E_literal (Literal_bool b))
-    )
-  | T_constant ("int", []) -> (
-      let%bind n =
-        trace_strong (wrong_mini_c_value "int" v) @@
-        get_int v in
-      return (E_literal (Literal_int n))
-    )
-  | T_constant ("nat", []) -> (
-      let%bind n =
-        trace_strong (wrong_mini_c_value "nat" v) @@
-        get_nat v in
-      return (E_literal (Literal_nat n))
-    )
-  | T_constant ("timestamp", []) -> (
-      let%bind n =
-        trace_strong (wrong_mini_c_value "timestamp" v) @@
-        get_timestamp v in
-      return (E_literal (Literal_timestamp n))
-    )
-  | T_constant ("tez", []) -> (
-      let%bind n =
-        trace_strong (wrong_mini_c_value "tez" v) @@
-        get_nat v in
-      return (E_literal (Literal_tez n))
-    )
-  | T_constant ("string", []) -> (
-      let%bind n =
-        trace_strong (wrong_mini_c_value "string" v) @@
-        get_string v in
-      return (E_literal (Literal_string n))
-    )
-  | T_constant ("bytes", []) -> (
-      let%bind n =
-        trace_strong (wrong_mini_c_value "bytes" v) @@
-        get_bytes v in
-      return (E_literal (Literal_bytes n))
-    )
-  | T_constant ("address", []) -> (
-      let%bind n =
-        trace_strong (wrong_mini_c_value "address" v) @@
-        get_string v in
-      return (E_literal (Literal_address n))
-    )
-  | T_constant ("option", [o]) -> (
-      let%bind opt =
-        trace_strong (wrong_mini_c_value "option" v) @@
-        get_option v in
-      match opt with
-      | None -> ok (e_a_empty_none o)
-      | Some s ->
-          let%bind s' = untranspile s o in
-          ok (e_a_empty_some s')
-    )
-  | T_constant ("map", [k_ty;v_ty]) -> (
-      let%bind lst =
-        trace_strong (wrong_mini_c_value "map" v) @@
-        get_map v in
-      let%bind lst' =
-        let aux = fun (k, v) ->
-          let%bind k' = untranspile k k_ty in
-          let%bind v' = untranspile v v_ty in
-          ok (k', v') in
-        bind_map_list aux lst in
-      return (E_map lst')
-    )
-  | T_constant ("list", [ty]) -> (
-      let%bind lst =
-        trace_strong (wrong_mini_c_value "list" v) @@
-        get_list v in
-      let%bind lst' =
-        let aux = fun e -> untranspile e ty in
-        bind_map_list aux lst in
-      return (E_list lst')
-    )
-  | T_constant ("set", [ty]) -> (
-      let%bind lst =
-        trace_strong (wrong_mini_c_value "set" v) @@
-        get_set v in
-      let%bind lst' =
-        let aux = fun e -> untranspile e ty in
-        bind_map_list aux lst in
-      return (E_set lst')
-    )
-  | T_constant ("contract" , [_ty]) ->
-    fail @@ bad_untranspile "contract" v
-  | T_constant ("operation" , []) -> (
-      let%bind op =
-        trace_strong (wrong_mini_c_value "operation" v) @@
-        get_operation v in
-      return (E_literal (Literal_operation op))
-    )
-  | T_constant (name , _lst) ->
-    fail @@ unknown_untranspile name v
-  | T_sum m ->
-      let lst = kv_list_of_map m in
-      let%bind node = match Append_tree.of_list lst with
-        | Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type"
-        | Full t -> ok t
-      in
-      let%bind (name, v, tv) =
-        trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@
-        extract_constructor v node in
-      let%bind sub = untranspile v tv in
-      return (E_constructor (name, sub))
-  | T_tuple lst ->
-      let%bind node = match Append_tree.of_list lst with
-        | Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple"
-        | Full t -> ok t in
-      let%bind tpl =
-        trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@
-        extract_tuple v node in
-      let%bind tpl' = bind_list
-        @@ List.map (fun (x, y) -> untranspile x y) tpl in
-      return (E_tuple tpl')
-  | T_record m ->
-      let lst = kv_list_of_map m in
-      let%bind node = match Append_tree.of_list lst with
-        | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
-        | Full t -> ok t in
-      let%bind lst =
-        trace_strong (corner_case ~loc:__LOC__ "record extract") @@
-        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 _ -> fail @@ bad_untranspile "function" v

src/passes/6-transpiler/untranspiler.ml

@@ -0,0 +1,193 @@
+open Helpers
+
+module AST = Ast_typed
+module Append_tree = Tree.Append
+open Mini_c
+open Trace
+
+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
+
+  let wrong_mini_c_value expected_type actual =
+    let title () = "illed typed intermediary value" in
+    let content () = "type of intermediary value doesn't match what was expected" in
+    let data = [
+      ("expected_type" , fun () -> expected_type) ;
+      ("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ;
+    ] in
+    error ~data title content
+
+  let bad_untranspile bad_type value =
+    let title () = "untranspiling bad value" in
+    let content () = Format.asprintf "can not untranspile %s" bad_type in
+    let data = [
+      ("bad_type" , fun () -> bad_type) ;
+      ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
+    ] in
+    error ~data title content
+
+  let unknown_untranspile unknown_type value =
+    let title () = "untranspiling unknown value" in
+    let content () = Format.asprintf "can not untranspile %s" unknown_type in
+    let data = [
+      ("unknown_type" , fun () -> unknown_type) ;
+      ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
+    ] in
+    error ~data title content
+
+end
+
+open Errors
+
+let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result =
+  let open! AST in
+  let return e = ok (make_a_e_empty e t) in
+  match t.type_value' with
+  | T_constant ("unit", []) -> (
+      let%bind () =
+        trace_strong (wrong_mini_c_value "unit" v) @@
+        get_unit v in
+      return (E_literal Literal_unit)
+    )
+  | T_constant ("bool", []) -> (
+      let%bind b =
+        trace_strong (wrong_mini_c_value "bool" v) @@
+        get_bool v in
+      return (E_literal (Literal_bool b))
+    )
+  | T_constant ("int", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "int" v) @@
+        get_int v in
+      return (E_literal (Literal_int n))
+    )
+  | T_constant ("nat", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "nat" v) @@
+        get_nat v in
+      return (E_literal (Literal_nat n))
+    )
+  | T_constant ("timestamp", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "timestamp" v) @@
+        get_timestamp v in
+      return (E_literal (Literal_timestamp n))
+    )
+  | T_constant ("tez", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "tez" v) @@
+        get_nat v in
+      return (E_literal (Literal_tez n))
+    )
+  | T_constant ("string", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "string" v) @@
+        get_string v in
+      return (E_literal (Literal_string n))
+    )
+  | T_constant ("bytes", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "bytes" v) @@
+        get_bytes v in
+      return (E_literal (Literal_bytes n))
+    )
+  | T_constant ("address", []) -> (
+      let%bind n =
+        trace_strong (wrong_mini_c_value "address" v) @@
+        get_string v in
+      return (E_literal (Literal_address n))
+    )
+  | T_constant ("option", [o]) -> (
+      let%bind opt =
+        trace_strong (wrong_mini_c_value "option" v) @@
+        get_option v in
+      match opt with
+      | None -> ok (e_a_empty_none o)
+      | Some s ->
+          let%bind s' = untranspile s o in
+          ok (e_a_empty_some s')
+    )
+  | T_constant ("map", [k_ty;v_ty]) -> (
+      let%bind lst =
+        trace_strong (wrong_mini_c_value "map" v) @@
+        get_map v in
+      let%bind lst' =
+        let aux = fun (k, v) ->
+          let%bind k' = untranspile k k_ty in
+          let%bind v' = untranspile v v_ty in
+          ok (k', v') in
+        bind_map_list aux lst in
+      return (E_map lst')
+    )
+  | T_constant ("list", [ty]) -> (
+      let%bind lst =
+        trace_strong (wrong_mini_c_value "list" v) @@
+        get_list v in
+      let%bind lst' =
+        let aux = fun e -> untranspile e ty in
+        bind_map_list aux lst in
+      return (E_list lst')
+    )
+  | T_constant ("set", [ty]) -> (
+      let%bind lst =
+        trace_strong (wrong_mini_c_value "set" v) @@
+        get_set v in
+      let%bind lst' =
+        let aux = fun e -> untranspile e ty in
+        bind_map_list aux lst in
+      return (E_set lst')
+    )
+  | T_constant ("contract" , [_ty]) ->
+    fail @@ bad_untranspile "contract" v
+  | T_constant ("operation" , []) -> (
+      let%bind op =
+        trace_strong (wrong_mini_c_value "operation" v) @@
+        get_operation v in
+      return (E_literal (Literal_operation op))
+    )
+  | T_constant (name , _lst) ->
+    fail @@ unknown_untranspile name v
+  | T_sum m ->
+      let lst = kv_list_of_map m in
+      let%bind node = match Append_tree.of_list lst with
+        | Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type"
+        | Full t -> ok t
+      in
+      let%bind (name, v, tv) =
+        trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@
+        extract_constructor v node in
+      let%bind sub = untranspile v tv in
+      return (E_constructor (name, sub))
+  | T_tuple lst ->
+      let%bind node = match Append_tree.of_list lst with
+        | Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple"
+        | Full t -> ok t in
+      let%bind tpl =
+        trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@
+        extract_tuple v node in
+      let%bind tpl' = bind_list
+        @@ List.map (fun (x, y) -> untranspile x y) tpl in
+      return (E_tuple tpl')
+  | T_record m ->
+      let lst = kv_list_of_map m in
+      let%bind node = match Append_tree.of_list lst with
+        | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
+        | Full t -> ok t in
+      let%bind lst =
+        trace_strong (corner_case ~loc:__LOC__ "record extract") @@
+        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 _ -> fail @@ bad_untranspile "function" v

src/passes/8-compiler/compiler_program.ml

@@ -1,14 +1,11 @@
 open Trace
 open Mini_c
-
 open Michelson
-
 open Memory_proto_alpha.Protocol.Script_ir_translator
-
 open Operators.Compiler
 
-let get_predicate : string -> type_value -> expression list -> predicate result = fun s ty lst ->
+let get_operator : string -> type_value -> expression list -> predicate result = fun s ty lst ->
-  match Map.String.find_opt s Operators.Compiler.predicates with
+  match Map.String.find_opt s Operators.Compiler.operators with
   | Some x -> ok x
   | None -> (
       match s with
@@ -196,7 +193,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
             PP.environment env ;
           ok (seq [ expr_code ; dip code ]) in
         bind_fold_right_list aux (seq []) lst in
-      let%bind predicate = get_predicate str ty lst in
+      let%bind predicate = get_operator str ty lst in
       let%bind code = match (predicate, List.length lst) with
         | Constant c, 0 -> ok @@ seq [
             pre_code ;

src/passes/operators/operators.ml

@@ -639,7 +639,7 @@ module Compiler = struct
   include Helpers.Compiler
   open Tezos_utils.Michelson
 
-  let predicates = Map.String.of_list [
+  let operators = Map.String.of_list [
     ("ADD" , simple_binary @@ prim I_ADD) ;
     ("SUB" , simple_binary @@ prim I_SUB) ;
     ("TIMES" , simple_binary @@ prim I_MUL) ;
@@ -693,6 +693,9 @@ module Compiler = struct
     ("CONCAT" , simple_binary @@ prim I_CONCAT) ;
   ]
 
-  (* Some complex predicates will need to be added in compiler/compiler_program *)
+  (*
+    Some complex operators will need to be added in compiler/compiler_program.
+    All operators whose compilations involve a type are found there.
+  *)
 
 end

src/stages/ast_typed/PP.ml

@@ -24,10 +24,9 @@ let rec annotated_expression ppf (ae:annotated_expression) : unit =
   | _ -> fprintf ppf "@[<v>%a@]" expression ae.expression
 
 and lambda ppf l =
-  let {binder;input_type;output_type;result} = l in
+  let ({ binder ; body } : lambda) = l in
-  fprintf ppf "lambda (%s:%a) : %a return %a"
+  fprintf ppf "lambda (%s) -> %a"
-    binder type_value input_type type_value output_type
+    binder annotated_expression body
-    annotated_expression result
 
 and expression ppf (e:expression) : unit =
   match e with

src/stages/ast_typed/combinators.ml

@@ -56,6 +56,10 @@ let get_type' (x:type_value) = x.type_value'
 let get_environment (x:annotated_expression) = x.environment
 let get_expression (x:annotated_expression) = x.expression
 
+let get_lambda e : _ result = match e with
+  | E_lambda l -> ok l
+  | _ -> simple_fail "not a lambda"
+
 let get_t_bool (t:type_value) : unit result = match t.type_value' with
   | T_constant ("bool", []) -> ok ()
   | _ -> simple_fail "not a bool"
@@ -235,7 +239,7 @@ let e_a_string s = make_a_e (e_string s) (t_string ())
 let e_a_address s = make_a_e (e_address s) (t_address ())
 let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_annotation b.type_annotation ())
 let e_a_some s = make_a_e (e_some s) (t_option s.type_annotation ())
-let e_a_lambda l = make_a_e (e_lambda l) (t_function l.input_type l.output_type ())
+let e_a_lambda l in_ty out_ty = make_a_e (e_lambda l) (t_function in_ty out_ty ())
 let e_a_none t = make_a_e e_none (t_option t ())
 let e_a_tuple lst = make_a_e (E_tuple lst) (t_tuple (List.map get_type_annotation lst) ())
 let e_a_record r = make_a_e (e_record r) (t_record (SMap.map get_type_annotation r) ())

src/stages/ast_typed/combinators_environment.ml

@@ -18,7 +18,7 @@ let e_a_empty_record r = e_a_record r Environment.full_empty
 let e_a_empty_map lst k v = e_a_map lst k v Environment.full_empty
 let e_a_empty_list lst t = e_a_list lst t Environment.full_empty
 let ez_e_a_empty_record r = ez_e_a_record r Environment.full_empty
-let e_a_empty_lambda l = e_a_lambda l Environment.full_empty
+let e_a_empty_lambda l i o = e_a_lambda l i o Environment.full_empty
 
 open Environment
 

src/stages/ast_typed/misc.ml

@@ -171,7 +171,7 @@ module Free_variables = struct
 
   and lambda : bindings -> lambda -> bindings = fun b l ->
     let b' = union (singleton l.binder) b in
-    annotated_expression b' l.result
+    annotated_expression b' l.body
 
   and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae ->
     expression b ae.expression

src/stages/ast_typed/misc_smart.ml

@@ -4,7 +4,7 @@ open Combinators
 open Misc
 
 let program_to_main : program -> string -> lambda result = fun p s ->
-  let%bind (main , input_type , output_type) =
+  let%bind (main , input_type , _) =
     let pred = fun d ->
       match d with
       | Declaration_constant (d , _) when d.name = s -> Some d.annotated_expression
@@ -25,15 +25,13 @@ let program_to_main : program -> string -> lambda result = fun p s ->
       | Declaration_constant (_ , (_ , post_env)) -> post_env in
     List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
   let binder = "@contract_input" in
-  let result =
+  let body =
     let input_expr = e_a_variable binder input_type env in
     let main_expr = e_a_variable s (get_type_annotation main) env in
     e_a_application main_expr input_expr env in
   ok {
     binder ;
-    input_type ;
+    body ;
-    output_type ;
-    result ;
   }
 
 module Captured_variables = struct

src/stages/ast_typed/types.ml

@@ -70,9 +70,9 @@ and named_type_value = {
 
 and lambda = {
   binder : name ;
-  input_type: tv ;
+  (* input_type: tv ;
-  output_type: tv ;
+   * output_type: tv ; *)
-  result: ae ;
+  body : ae ;
 }
 
 and let_in = {

src/stages/mini_c/combinators.ml

@@ -164,12 +164,10 @@ let e_let_int v tv expr body : expression = Expression.(make_tpl (
 
 let ez_e_sequence a b : expression = Expression.(make_tpl (E_sequence (make_tpl (a , t_unit) , b) , get_type b))
 
-let ez_e_return e : expression = e
-
 let d_unit : value = D_unit
 
 let basic_quote expr : anon_function result =
-  ok @@ quote "input" (ez_e_return expr)
+  ok @@ quote "input" expr
 
 let basic_int_quote expr : anon_function result =
   basic_quote expr