diff --git a/src/ast_typed/ast_typed.ml b/src/ast_typed/ast_typed.ml index f01780254..2ed4ec59e 100644 --- a/src/ast_typed/ast_typed.ml +++ b/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 diff --git a/src/ast_typed/environment.ml b/src/ast_typed/environment.ml index de0798c91..7d254d500 100644 --- a/src/ast_typed/environment.ml +++ b/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 -> - List.Ne.hd_map (Small.add k (make_element_declaration v e expr)) e -let add_ez_ae : string -> annotated_expression -> t -> t = fun k ae e -> - add_ez_declaration k (get_type_annotation ae) (get_expression ae) e +let add_ez_declaration : string -> annotated_expression -> t -> t = fun k ae e -> + List.Ne.hd_map (Small.add k (make_element_declaration e ae)) e +let add_ez_ae = add_ez_declaration 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 diff --git a/src/ast_typed/misc.ml b/src/ast_typed/misc.ml index b562be0ff..cb03a38b0 100644 --- a/src/ast_typed/misc.ml +++ b/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 ; - } diff --git a/src/ast_typed/misc_smart.ml b/src/ast_typed/misc_smart.ml new file mode 100644 index 000000000..d333705fe --- /dev/null +++ b/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 diff --git a/src/ast_typed/types.ml b/src/ast_typed/types.ml index 78dc31ab1..c82abd1c6 100644 --- a/src/ast_typed/types.ml +++ b/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 ; diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index 2e572fe98..4538bae16 100644 --- a/src/compiler/compiler_program.ml +++ b/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' = diff --git a/src/main/main.ml b/src/main/main.ml index f0f9ca758..0dce98a61 100644 --- a/src/main/main.ml +++ b/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) - (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression env e +let transpile_expression (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression e let transpile_value (e:AST_Typed.annotated_expression) : Mini_c.value result = let%bind f = diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 96192c01b..4aa5d8498 100644 --- a/src/transpiler/transpiler.ml +++ b/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") @@ - bind_fold_right_list aux Environment.empty x' + let%bind result = + 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%bind env' = transpile_environment ae.environment in *) - ok @@ Combinators.Expression.make_tpl (expr, tv) in - let f = translate_annotated_expression env in + let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in + let f = translate_annotated_expression 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 -> - let%bind tv = - trace_option (simple_error "transpiler: variable not in env") @@ - Environment.get_opt name env in + | E_variable name -> ( + let%bind ele = + trace_option (simple_error "name not in environment") @@ + 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 b = translate_annotated_expression env b in + let%bind a = translate_annotated_expression a 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 env' s in + let%bind s' = translate_annotated_expression 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 env' body in + let%bind body' = translate_annotated_expression 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)) , env') a in + let%bind e = aux (((Expression.make (E_variable "left") a_ty))) 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)) , env') b in + let%bind e = aux (((Expression.make (E_variable "right") b_ty))) 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 empty_env = + let%bind result = + match (body_fvs, result_fvs) with + | [] , [] -> ( + 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 ((_, e) as body') = translate_block empty_env body in - let%bind result' = translate_annotated_expression e.post_environment result in - trace (simple_error "translate quote") @@ - let%bind input = translate_type input_type in - let%bind output = translate_type output_type in - let tv = Combinators.t_function input output in - let content = D_function {binder;input;output;body=body';result=result'} in - ok @@ Combinators.Expression.make_tpl (E_literal content, tv) - ) - | _ -> ( - trace (simple_error "translate lambda deep") @@ - translate_lambda_deep env l - ) + let%bind output = translate_type output_type in + let tv = Combinators.t_function input output in + let content = D_function {binder;input;output;body=body';result=result'} in + ok @@ Combinators.Expression.make_tpl (E_literal content, tv) + ) + | _ -> ( + trace (simple_error "translate lambda deep") @@ + translate_lambda_deep env l + ) in + ok result 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') diff --git a/src/typer/typer.ml b/src/typer/typer.ml index d07876397..0956ce58c 100644 --- a/src/typer/typer.ml +++ b/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 =