balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

remove environment from transpilation of expressions

Browse Source
This commit is contained in:
Galfour 2019-05-17 16:03:41 +00:00
parent 4e76b5344d
commit 21f09da759
9 changed files with 255 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/ast_typed/ast_typed.ml
View File

@ -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

11
src/ast_typed/environment.ml
View File

@ -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

42
src/ast_typed/misc.ml
View File

@ -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 ;
}

160
src/ast_typed/misc_smart.ml Normal file
View File

@ -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

4
src/ast_typed/types.ml
View File

@ -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 ;

4
src/compiler/compiler_program.ml
View File

@ -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' =

3
src/main/main.ml
View File

@ -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 =

139
src/transpiler/transpiler.ml
View File

@ -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')

3
src/typer/typer.ml
View File

@ -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 =