remove environment from transpilation of expressions

src/ast_typed/ast_typed.ml

@@ -5,7 +5,10 @@ module Combinators = struct
   include Combinators
   include Combinators_environment
 end
-module Misc = Misc
+module Misc = struct
+  include Misc
+  include Misc_smart
+end
 
 include Types
 include Misc

src/ast_typed/environment.ml

@@ -6,7 +6,9 @@ let make_element : type_value -> full_environment -> environment_element_definit
   fun type_value source_environment definition -> {type_value ; source_environment ; definition}
 
 let make_element_binder = fun t s -> make_element t s ED_binder
-let make_element_declaration = fun t s d -> make_element t s (ED_declaration d)
+let make_element_declaration = fun s (ae : annotated_expression) ->
+  let free_variables = Misc.Free_variables.(annotated_expression empty ae) in
+  make_element (get_type_annotation ae) s (ED_declaration (ae , free_variables))
 
 module Small = struct
   type t = small_environment
@@ -30,10 +32,9 @@ let full_empty : t = List.Ne.singleton Small.empty
 let add : string -> element -> t -> t = fun k v -> List.Ne.hd_map (Small.add k v)
 let add_ez_binder : string -> type_value -> t -> t = fun k v e ->
   List.Ne.hd_map (Small.add k (make_element_binder v e)) e
-let add_ez_declaration : string -> type_value -> expression -> t -> t = fun k v expr e ->
+let add_ez_declaration : string -> annotated_expression -> t -> t = fun k ae e ->
-  List.Ne.hd_map (Small.add k (make_element_declaration v e expr)) e
+  List.Ne.hd_map (Small.add k (make_element_declaration e ae)) e
-let add_ez_ae : string -> annotated_expression -> t -> t = fun k ae e ->
+let add_ez_ae = add_ez_declaration
-  add_ez_declaration k (get_type_annotation ae) (get_expression ae) e
 let add_type : string -> type_value -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v)
 let get_opt : string -> t -> element option = fun k x -> List.Ne.find_map (Small.get_opt k) x
 let get_type_opt : string -> t -> type_value option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x

src/ast_typed/misc.ml

@@ -105,6 +105,7 @@ module Free_variables = struct
 
 end
 
+
 (* module Dependencies = struct
  * 
  *   type bindings = string list
@@ -374,44 +375,3 @@ let merge_annotation (a:type_value option) (b:type_value option) : type_value re
       match a.simplified, b.simplified with
       | _, None -> ok a
       | _, Some _ -> ok b
-
-open Combinators
-
-let program_to_main : program -> string -> lambda result = fun p s ->
-  let%bind (main , input_type , output_type) =
-    let pred = fun d ->
-      match d with
-      | Declaration_constant (d , _) when d.name = s -> Some d.annotated_expression
-      | Declaration_constant _ -> None
-    in
-    let%bind main =
-      trace_option (simple_error "no main with given name") @@
-      List.find_map (Function.compose pred Location.unwrap) p in
-    let%bind (input_ty , output_ty) =
-      match (get_type' @@ get_type_annotation main) with
-      | T_function (i , o) -> ok (i , o)
-      | _ -> simple_fail "program main isn't a function" in
-    ok (main , input_ty , output_ty)
-  in
-  let body =
-    let aux : declaration -> instruction = fun d ->
-      match d with
-      | Declaration_constant (d , _) -> I_declaration d in
-    List.map (Function.compose aux Location.unwrap) p in
-  let env =
-    let aux = fun _ d ->
-      match d with
-      | Declaration_constant (_ , env) -> env in
-    List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
-  let binder = "@contract_input" in
-  let result =
-    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 ;
-    output_type ;
-    body ;
-    result ;
-  }

src/ast_typed/misc_smart.ml

@@ -0,0 +1,160 @@
+open Trace
+open Types
+open Combinators
+open Misc
+
+let program_to_main : program -> string -> lambda result = fun p s ->
+  let%bind (main , input_type , output_type) =
+    let pred = fun d ->
+      match d with
+      | Declaration_constant (d , _) when d.name = s -> Some d.annotated_expression
+      | Declaration_constant _ -> None
+    in
+    let%bind main =
+      trace_option (simple_error "no main with given name") @@
+      List.find_map (Function.compose pred Location.unwrap) p in
+    let%bind (input_ty , output_ty) =
+      match (get_type' @@ get_type_annotation main) with
+      | T_function (i , o) -> ok (i , o)
+      | _ -> simple_fail "program main isn't a function" in
+    ok (main , input_ty , output_ty)
+  in
+  let body =
+    let aux : declaration -> instruction = fun d ->
+      match d with
+      | Declaration_constant (d , _) -> I_declaration d in
+    List.map (Function.compose aux Location.unwrap) p in
+  let env =
+    let aux = fun _ d ->
+      match d with
+      | Declaration_constant (_ , env) -> env in
+    List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
+  let binder = "@contract_input" in
+  let result =
+    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 ;
+    output_type ;
+    body ;
+    result ;
+  }
+
+module Captured_variables = struct
+
+  type bindings = string list
+  let mem : string -> bindings -> bool = List.mem
+  let singleton : string -> bindings = fun s -> [ s ]
+  let union : bindings -> bindings -> bindings = (@)
+  let unions : bindings list -> bindings = List.concat
+  let empty : bindings = []
+  let of_list : string list -> bindings = fun x -> x
+
+  let rec annotated_expression : bindings -> annotated_expression -> bindings result = fun b ae ->
+    let self = annotated_expression b in
+    match ae.expression with
+    | E_lambda l -> ok @@ Free_variables.lambda empty l
+    | E_literal _ -> ok empty
+    | E_constant (_ , lst) ->
+      let%bind lst' = bind_map_list self lst in
+      ok @@ unions lst'
+    | E_variable name -> (
+        let%bind env_element =
+          trace_option (simple_error "missing var in env") @@
+          Environment.get_opt name ae.environment in
+        match env_element.definition with
+        | ED_binder -> ok empty
+        | ED_declaration (_ , _) -> simple_fail "todo"
+      )
+    | E_application (a, b) ->
+      let%bind lst' = bind_map_list self [ a ; b ] in
+      ok @@ unions lst'
+    | E_tuple lst ->
+      let%bind lst' = bind_map_list self lst in
+      ok @@ unions lst'
+    | E_constructor (_ , a) -> self a
+    | E_record m ->
+      let%bind lst' = bind_map_list self @@ Map.String.to_list m in
+      ok @@ unions lst'
+    | E_record_accessor (a, _) -> self a
+    | E_tuple_accessor (a, _) -> self a
+    | E_list lst ->
+      let%bind lst' = bind_map_list self lst in
+      ok @@ unions lst'
+    | E_map m ->
+      let%bind lst' = bind_map_list self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m in
+      ok @@ unions lst'
+    | E_look_up (a , b) ->
+      let%bind lst' = bind_map_list self [ a ; b ] in
+      ok @@ unions lst'
+    | E_matching (a , cs) ->
+      let%bind a' = self a in
+      let%bind cs' = matching_expression b cs in
+      ok @@ union a' cs'
+    | E_failwith a -> self a
+
+  and instruction' : bindings -> instruction -> (bindings * bindings) result = fun b i ->
+    match i with
+    | I_declaration n ->
+      let bounds = union (singleton n.name) b in
+      let%bind frees = annotated_expression b n.annotated_expression in
+      ok (bounds , frees)
+    | I_assignment n ->
+      let%bind frees = annotated_expression b n.annotated_expression in
+      ok (b , frees)
+    | I_skip -> ok (b , empty)
+    | I_do e ->
+      let%bind frees = annotated_expression b e in
+      ok (b , frees)
+    | I_loop (a , bl) ->
+      let%bind ae_frees = annotated_expression b a in
+      let%bind bl_frees = block b bl in
+      ok (b , union ae_frees bl_frees)
+    | I_patch (_ , _ , a) ->
+      let%bind a' = annotated_expression b a in
+      ok (b , a')
+    | I_matching (a , cs) ->
+      let%bind ae' = annotated_expression b a in
+      let%bind bl' = matching_block b cs in
+      ok (b , union ae' bl')
+
+  and block' : bindings -> block -> (bindings * bindings) result = fun b bl ->
+    let aux = fun (binds, frees) cur ->
+      let%bind (binds', frees') = instruction' binds cur in
+      ok (binds', union frees frees') in
+    bind_fold_list aux (b , []) bl
+
+  and block : bindings -> block -> bindings result = fun b bl ->
+    let%bind (_ , frees) = block' b bl in
+    ok frees
+
+  and matching_variant_case : type a . (bindings -> a -> bindings result) -> bindings -> ((constructor_name * name) * a) -> bindings result  = fun f b ((_,n),c) ->
+    f (union (singleton n) b) c
+
+  and matching : type a . (bindings -> a -> bindings result) -> bindings -> a matching -> bindings result = fun f b m ->
+    match m with
+    | Match_bool { match_true = t ; match_false = fa } ->
+      let%bind t' = f b t in
+      let%bind fa' = f b fa in
+      ok @@ union t' fa'
+    | Match_list { match_nil = n ; match_cons = (hd, tl, c) } ->
+      let%bind n' = f b n in
+      let%bind c' = f (union (of_list [hd ; tl]) b) c in
+      ok @@ union n' c'
+    | Match_option { match_none = n ; match_some = ((opt, _), s) } ->
+      let%bind n' = f b n in
+      let%bind s' = f (union (singleton opt) b) s in
+      ok @@ union n' s'
+    | Match_tuple (lst , a) ->
+      f (union (of_list lst) b) a
+    | Match_variant (lst , _) ->
+      let%bind lst' = bind_map_list (matching_variant_case f b) lst in
+      ok @@ unions lst'
+
+  and matching_expression = fun x -> matching annotated_expression x
+
+  and matching_block = fun x -> matching block x
+
+end

src/ast_typed/types.ml

@@ -19,7 +19,9 @@ and declaration =
 
 and environment_element_definition =
   | ED_binder
-  | ED_declaration of expression
+  | ED_declaration of (annotated_expression * free_variables)
+
+and free_variables = name list
 
 and environment_element = {
   type_value : type_value ;

src/compiler/compiler_program.ml

@@ -84,7 +84,9 @@ and translate_function (content:anon_function) : michelson result =
 
 and translate_expression ?(first=false) (expr:expression) (env:environment) : (michelson * environment) result =
   let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in
-  let error_message () = Format.asprintf  "%a" PP.expression expr in
+  let error_message () =
+    Format.asprintf  "\n- expr: %a\n- type: %a\n" PP.expression expr PP.type_ ty
+  in
 
   let return ?prepend_env ?end_env code =
     let%bind env' =

src/main/main.ml

@@ -25,8 +25,7 @@ let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.annota
 
 let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p
 let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name
-let transpile_expression ?(env:Mini_c.Environment.t = Mini_c.Environment.empty)
+let transpile_expression (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression e
-    (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression env e
 let transpile_value
     (e:AST_Typed.annotated_expression) : Mini_c.value result =
   let%bind f =

src/transpiler/transpiler.ml

@@ -67,10 +67,11 @@ let rec translate_type (t:AST.type_value) : type_value result =
         ok (T_pair (a, b))
       in
       Append_tree.fold_ne translate_type aux node
-  | T_function (param, result) ->
+  | T_function (param, result) -> (
       let%bind param' = translate_type param in
       let%bind result' = translate_type result in
       ok (T_function (param', result'))
+    )
 
 let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [`Left | `Right]) list result = fun ty tys ind ->
   let node_tv = Append_tree.of_list @@ List.mapi (fun i a -> (i, a)) tys in
@@ -130,11 +131,11 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
   let return ?(env' = env) x : statement list result = ok ([x, environment_wrap env env']) in
   match i with
   | I_declaration {name;annotated_expression} ->
-      let%bind expression = translate_annotated_expression env annotated_expression in
+      let%bind expression = translate_annotated_expression annotated_expression in
       let env' = Environment.add (name, (Combinators.Expression.get_type expression)) env in
       return ~env' (S_declaration (name, expression))
   | I_assignment {name;annotated_expression} ->
-      let%bind expression = translate_annotated_expression env annotated_expression in
+      let%bind expression = translate_annotated_expression annotated_expression in
       return (S_assignment (name, expression))
   | I_patch (r, s, v) -> (
       let ty = r.type_value in
@@ -165,11 +166,11 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
           | Access_map _k -> simple_fail "no patch for map yet"
       in
       let%bind (_, path) = bind_fold_right_list aux (ty, []) s in
-      let%bind v' = translate_annotated_expression env v in
+      let%bind v' = translate_annotated_expression v in
       return (S_patch (r.type_name, path, v'))
     )
   | I_matching (expr, m) -> (
-      let%bind expr' = translate_annotated_expression env expr in
+      let%bind expr' = translate_annotated_expression expr in
       let env' = env in
       let return s =
         ok [ (s, environment_wrap env env) ] in
@@ -191,12 +192,12 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
       | _ -> simple_fail "todo : match"
     )
   | I_loop (expr, body) ->
-      let%bind expr' = translate_annotated_expression env expr in
+      let%bind expr' = translate_annotated_expression expr in
       let%bind body' = translate_block env body in
       return (S_while (expr', body'))
   | I_skip -> ok []
   | I_do ae -> (
-      let%bind ae' = translate_annotated_expression env ae in
+      let%bind ae' = translate_annotated_expression ae in
       return @@ S_do ae'
     )
 
@@ -211,14 +212,26 @@ and translate_literal : AST.literal -> value = fun l -> match l with
   | Literal_operation op -> D_operation op
   | Literal_unit -> D_unit
 
+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 arg' = translate_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
+
 and transpile_small_environment : AST.small_environment -> Environment.t result = fun x ->
   let x' = AST.Environment.Small.get_environment x in
   let aux prec (name , (ele : AST.environment_element)) =
-    let%bind tv' = translate_type ele.type_value in
+    let%bind tv' = transpile_environment_element_type ele in
     ok @@ Environment.add (name , tv') prec
   in
-  trace (simple_error "transpiling small environment") @@
+  let%bind result =
-  bind_fold_right_list aux Environment.empty x'
+    trace (simple_error "transpiling small environment") @@
+    bind_fold_right_list aux Environment.empty x' in
+  ok result
 
 and transpile_environment : AST.full_environment -> Environment.t result = fun x ->
   let%bind nlst = bind_map_ne_list transpile_small_environment x in
@@ -228,29 +241,29 @@ 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 (env:Environment.t) (ae:AST.annotated_expression) : expression result =
+and translate_annotated_expression (ae:AST.annotated_expression) : expression result =
   let%bind tv = translate_type ae.type_annotation in
-  let return ?(tv = tv) expr =
+  let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in
-    (* let%bind env' = transpile_environment ae.environment in *)
+  let f = translate_annotated_expression in
-    ok @@ Combinators.Expression.make_tpl (expr, tv) in
-  let f = translate_annotated_expression env in
   match ae.expression with
   | E_failwith ae -> (
-      let%bind ae' = translate_annotated_expression env ae in
+      let%bind ae' = translate_annotated_expression ae in
       return @@ E_constant ("FAILWITH" , [ae'])
     )
   | E_literal l -> return @@ E_literal (translate_literal l)
-  | E_variable name ->
+  | E_variable name -> (
-      let%bind tv =
+      let%bind ele =
-        trace_option (simple_error "transpiler: variable not in env") @@
+        trace_option (simple_error "name not in environment") @@
-        Environment.get_opt name env in
+        AST.Environment.get_opt name ae.environment in
+      let%bind tv = transpile_environment_element_type ele in
       return ~tv @@ E_variable name
+    )
   | E_application (a, b) ->
-      let%bind a = translate_annotated_expression env a in
+      let%bind a = translate_annotated_expression a in
-      let%bind b = translate_annotated_expression env b in
+      let%bind b = translate_annotated_expression b in
       return @@ E_application (a, b)
   | E_constructor (m, param) ->
-      let%bind param' = translate_annotated_expression env param in
+      let%bind param' = translate_annotated_expression param in
       let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in
       let%bind node_tv = tree_of_sum ae.type_annotation in
       let leaf (k, tv) : (expression' option * type_value) result =
@@ -287,7 +300,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
         let tv = T_pair (a_ty , b_ty) in
         return ~tv @@ E_constant ("PAIR", [a; b])
       in
-      Append_tree.fold_ne (translate_annotated_expression env) aux node
+      Append_tree.fold_ne (translate_annotated_expression) aux node
   | E_tuple_accessor (tpl, ind) ->
       let%bind ty' = translate_type tpl.type_annotation in
       let%bind ty_lst = get_t_tuple tpl.type_annotation in
@@ -298,7 +311,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
           | `Left -> "CAR"
           | `Right -> "CDR" in
         Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
-      let%bind tpl' = translate_annotated_expression env tpl in
+      let%bind tpl' = translate_annotated_expression tpl in
       let expr = List.fold_left aux tpl' path in
       ok expr
   | E_record m ->
@@ -311,7 +324,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
         let tv = T_pair (a_ty , b_ty) in
         return ~tv @@ E_constant ("PAIR", [a; b])
       in
-      Append_tree.fold_ne (translate_annotated_expression env) aux node
+      Append_tree.fold_ne (translate_annotated_expression) aux node
   | E_record_accessor (record, property) ->
       let%bind ty' = translate_type (get_type_annotation record) in
       let%bind ty_smap = get_t_record (get_type_annotation record) in
@@ -322,21 +335,23 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
           | `Left -> "CAR"
           | `Right -> "CDR" in
         Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
-      let%bind record' = translate_annotated_expression env record in
+      let%bind record' = translate_annotated_expression record in
       let expr = List.fold_left aux record' path in
       ok expr
   | E_constant (name, lst) ->
-      let%bind lst' = bind_list @@ List.map (translate_annotated_expression env) lst in (
+      let%bind lst' = bind_list @@ List.map (translate_annotated_expression) lst in (
         match name, lst with
         | "NONE", [] ->
             let%bind o = Mini_c.Combinators.get_t_option tv in
             return @@ E_make_none o
         | _ -> return @@ E_constant (name, lst')
       )
-  | E_lambda l -> translate_lambda env l
+  | E_lambda l ->
+    let%bind env = transpile_environment ae.environment in
+    translate_lambda env l
   | E_list lst ->
       let%bind t = Mini_c.Combinators.get_t_list tv in
-      let%bind lst' = bind_map_list (translate_annotated_expression env) lst in
+      let%bind lst' = bind_map_list (translate_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
@@ -347,7 +362,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
         let%bind prev' = prev in
         let%bind (k', v') =
           let v' = e_a_some v ae.environment in
-          bind_map_pair (translate_annotated_expression env) (k, v') in
+          bind_map_pair (translate_annotated_expression) (k, v') in
         return @@ E_constant ("UPDATE", [k' ; v' ; prev'])
       in
       let init = return @@ E_make_empty_map (src, dst) in
@@ -356,17 +371,16 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
       let%bind (ds', i') = bind_map_pair f dsi in
       return @@ E_constant ("GET", [i' ; ds'])
   | E_matching (expr, m) -> (
-      let%bind expr' = translate_annotated_expression env expr in
+      let%bind expr' = translate_annotated_expression expr in
       match m with
       | Match_bool {match_true ; match_false} ->
-          let%bind (t , f) = bind_map_pair (translate_annotated_expression env) (match_true, match_false) in
+          let%bind (t , f) = bind_map_pair (translate_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 env match_none in
+          let%bind n = translate_annotated_expression match_none in
           let%bind (tv' , s') =
             let%bind tv' = translate_type tv in
-            let env' = Environment.(add (name , tv') @@ env) in
+            let%bind s' = translate_annotated_expression s in
-            let%bind s' = translate_annotated_expression env' s in
             ok (tv' , s') in
           return @@ E_if_none (expr' , n , ((name , tv') , s'))
       | Match_variant (lst , variant) -> (
@@ -388,34 +402,31 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
             in aux tree'
           in
 
-          let rec aux (top , env) t =
+          let rec aux top t =
             match t with
             | ((`Leaf constructor_name) , tv) -> (
                 let%bind ((_ , name) , body) =
                   trace_option (simple_error "not supposed to happen here: missing match clause") @@
                   List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
-                let env' = Environment.(add (name , tv) env) in
+                let%bind body' = translate_annotated_expression body in
-                let%bind body' = translate_annotated_expression env' body in
                 return @@ E_let_in ((name , tv) , top , body')
               )
             | ((`Node (a , b)) , tv) ->
                 let%bind a' =
                   let%bind a_ty = get_t_left tv in
                   let a_var = "left" , a_ty in
-                  let env' = Environment.(add a_var env) in
+                  let%bind e = aux (((Expression.make (E_variable "left") a_ty))) a in
-                  let%bind e = aux (((Expression.make (E_variable "left") a_ty)) , env') a in
                   ok (a_var , e)
                 in
                 let%bind b' =
                   let%bind b_ty = get_t_right tv in
                   let b_var = "right" , b_ty in
-                  let env' = Environment.(add b_var env) in
+                  let%bind e = aux (((Expression.make (E_variable "right") b_ty))) b in
-                  let%bind e = aux (((Expression.make (E_variable "right") b_ty)) , env') b in
                   ok (b_var , e)
                 in
                 return @@ E_if_left (top , a' , b')
           in
-          aux (expr' , env) tree''
+          aux expr' tree''
         )
       | AST.Match_list _ | AST.Match_tuple (_, _) ->
           simple_fail "only match bool and option exprs are translated yet"
@@ -442,7 +453,7 @@ and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.express
       let statements' = load_st :: statements in
       (statements' , body_env)
     in
-    let%bind result = translate_annotated_expression body_env.post_environment result in
+    let%bind result = translate_annotated_expression result in
     let tv = Mini_c.t_function input output in
     let f_literal = D_function { binder ; input ; output ; body ; result } in
     let expr = Expression.make_tpl (E_literal f_literal , tv) in
@@ -461,29 +472,31 @@ and translate_lambda env l =
       let ((body_bounds , _) as b) = block' bindings body in
       b , annotated_expression body_bounds result
     ) in
-  match (body_fvs, result_fvs) with
+  let%bind result =
-  | [] , [] -> (
+    match (body_fvs, result_fvs) with
-      let%bind empty_env =
+    | [] , [] -> (
+        let%bind empty_env =
+          let%bind input = translate_type input_type in
+          ok Environment.(add (binder, input) empty) in
+        let%bind body' = translate_block empty_env body in
+        let%bind result' = translate_annotated_expression result in
+        trace (simple_error "translate quote") @@
         let%bind input = translate_type input_type in
-        ok Environment.(add (binder, input) empty) in
+        let%bind output = translate_type output_type in
-      let%bind ((_, e) as body') = translate_block empty_env body in
+        let tv = Combinators.t_function input output in
-      let%bind result' = translate_annotated_expression e.post_environment result in
+        let content = D_function {binder;input;output;body=body';result=result'} in
-      trace (simple_error "translate quote") @@
+        ok @@ Combinators.Expression.make_tpl (E_literal content, tv)
-      let%bind input = translate_type input_type in
+      )
-      let%bind output = translate_type output_type in
+    | _ -> (
-      let tv = Combinators.t_function input output in
+        trace (simple_error "translate lambda deep") @@
-      let content = D_function {binder;input;output;body=body';result=result'} in
+        translate_lambda_deep env l
-      ok @@ Combinators.Expression.make_tpl (E_literal content, tv)
+      ) in
-    )
+  ok result
-  | _ -> (
-      trace (simple_error "translate lambda deep") @@
-      translate_lambda_deep env l
-    )
 
 let translate_declaration env (d:AST.declaration) : toplevel_statement result =
   match d with
   | Declaration_constant ({name;annotated_expression} , _) ->
-      let%bind expression = translate_annotated_expression env annotated_expression in
+      let%bind expression = translate_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')

src/typer/typer.ml

@@ -46,7 +46,6 @@ module Errors = struct
         I.PP.annotated_expression ae
     in
     error title full ()
-
 end
 open Errors
 
@@ -73,7 +72,7 @@ and type_declaration env : I.declaration -> (environment * O.declaration option)
       let%bind ae' =
         trace (constant_declaration_error name annotated_expression) @@
         type_annotated_expression env annotated_expression in
-      let env' = Environment.add_ez_declaration name (O.get_type_annotation ae') (O.get_expression ae') env in
+      let env' = Environment.add_ez_ae name ae' env in
       ok (env', Some (O.Declaration_constant ((make_n_e name ae') , env')))
 
 and type_block_full (e:environment) (b:I.block) : (O.block * environment) result =