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

Merge branch 'refactor/remove-environments' into 'dev'

Browse Source 
Remove environments from the AST

See merge request ligolang/ligo!646
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-05-28 09:03:40 +00:00
commit daf6971fd1
27 changed files with 194 additions and 250 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/bin/cli.ml
View File

@ -263,7 +263,7 @@ let compile_parameter =
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let env = Ast_typed.program_environment typed_prg in let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind (_contract: Tezos_utils.Michelson.michelson) = let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *) (* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in Compile.Of_michelson.build_contract michelson_prg in
@ -290,7 +290,7 @@ let interpret =
| Some init_file -> | Some init_file ->
let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let env = Ast_typed.program_environment typed_prg in let env = Ast_typed.program_environment Environment.default typed_prg in
ok (mini_c_prg,state,env) ok (mini_c_prg,state,env)
| None -> ok ([],Typer.Solver.initial_state,Environment.default) in | None -> ok ([],Typer.Solver.initial_state,Environment.default) in
@ -332,7 +332,7 @@ let compile_storage =
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let env = Ast_typed.program_environment typed_prg in let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind (_contract: Tezos_utils.Michelson.michelson) = let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *) (* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in Compile.Of_michelson.build_contract michelson_prg in
@ -356,7 +356,7 @@ let dry_run =
let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format = let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let env = Ast_typed.program_environment typed_prg in let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let%bind (_contract: Tezos_utils.Michelson.michelson) = let%bind (_contract: Tezos_utils.Michelson.michelson) =
@ -386,7 +386,7 @@ let run_function =
let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format = let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in
let env = Ast_typed.program_environment typed_prg in let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in

6
src/environment/bool.ml
View File

@ -1,4 +1,8 @@
open Ast_typed open Ast_typed
open Stage_common.Constant open Stage_common.Constant
let environment = env_sum_type ~type_name:t_bool @@ [(Constructor "true",{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=0});(Constructor "false",{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=1})] let environment = Ast_typed.Environment.add_ez_sum_type ~type_name:t_bool @@
[
(Constructor "true" ,{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=0});
(Constructor "false",{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=1});
]

32
src/passes/10-interpreter/interpreter.ml
View File

@ -368,19 +368,23 @@ and eval : Ast_typed.expression -> env -> value result
let dummy : Ast_typed.program -> string result = let dummy : Ast_typed.program -> string result =
fun prg -> fun prg ->
let%bind (res,_) = bind_fold_list let aux (pp,top_env) el =
(fun (pp,top_env) el -> match Location.unwrap el with
let (Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _}) = Location.unwrap el in | Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _} ->
let%bind v = let%bind v =
(*TODO This TRY-CATCH is here until we properly implement effects*) (*TODO This TRY-CATCH is here until we properly implement effects*)
try try
eval expr top_env eval expr top_env
with Temporary_hack s -> ok @@ V_Failure s with Temporary_hack s ->
(*TODO This TRY-CATCH is here until we properly implement effects*) ok (V_Failure s)
in (*TODO This TRY-CATCH is here until we properly implement effects*)
let pp' = pp^"\n val "^(Var.to_name binder)^" = "^(Ligo_interpreter.PP.pp_value v) in in
let top_env' = Env.extend top_env (binder, v) in let pp' = pp^"\n val "^(Var.to_name binder)^" = "^(Ligo_interpreter.PP.pp_value v) in
ok @@ (pp',top_env') let top_env' = Env.extend top_env (binder, v) in
) ok @@ (pp',top_env')
| Ast_typed.Declaration_type _ ->
ok (pp , top_env)
in
let%bind (res,_) = bind_fold_list aux
("",Env.empty_env) prg in ("",Env.empty_env) prg in
ok @@ res ok @@ res

26
src/passes/10-transpiler/transpiler.ml
View File

@ -374,9 +374,6 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
| Literal_unit -> D_unit | Literal_unit -> D_unit
| Literal_void -> D_none | Literal_void -> D_none
and transpile_environment_element_type : AST.environment_element -> type_expression result = fun ele ->
transpile_type ele.type_value
and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression) Append_tree.t result = fun t -> and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression) Append_tree.t result = fun t ->
let%bind map_tv = get_t_sum t in let%bind map_tv = get_t_sum t in
let kt_list = List.map (fun (k,({ctor_type;_}:AST.ctor_content)) -> (k,ctor_type)) (kv_list_of_cmap map_tv) in let kt_list = List.map (fun (k,({ctor_type;_}:AST.ctor_content)) -> (k,ctor_type)) (kv_list_of_cmap map_tv) in
@ -397,11 +394,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
return (E_let_in ((let_binder, rhs'.type_expression), inline, rhs', result')) return (E_let_in ((let_binder, rhs'.type_expression), inline, rhs', result'))
| E_literal l -> return @@ E_literal (transpile_literal l) | E_literal l -> return @@ E_literal (transpile_literal l)
| E_variable name -> ( | E_variable name -> (
let%bind ele = return @@ E_variable (name)
trace_option (corner_case ~loc:__LOC__ "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 {lamb; args} -> | E_application {lamb; args} ->
let%bind a = transpile_annotated_expression lamb in let%bind a = transpile_annotated_expression lamb in
@ -441,7 +434,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
return ~tv ae return ~tv ae
) )
| E_record m -> ( | E_record m -> (
(*list_of_lmap to record_to_list*)
let node = Append_tree.of_list @@ Ast_typed.Helpers.list_of_record_or_tuple m in let node = Append_tree.of_list @@ Ast_typed.Helpers.list_of_record_or_tuple m in
let aux a b : expression result = let aux a b : expression result =
let%bind a = a in let%bind a = a in
@ -759,25 +751,29 @@ and transpile_recursive {fun_name; fun_type; lambda} =
let body = Expression.make (E_iterator (C_LOOP_LEFT, ((lambda.binder, loop_type),body), expr)) output_type in let body = Expression.make (E_iterator (C_LOOP_LEFT, ((lambda.binder, loop_type),body), expr)) output_type in
ok @@ Expression.make (E_closure {binder;body}) fun_type ok @@ Expression.make (E_closure {binder;body}) fun_type
let transpile_declaration env (d:AST.declaration) : toplevel_statement result = let transpile_declaration env (d:AST.declaration) : toplevel_statement option result =
match d with match d with
| Declaration_constant { binder ; expr ; inline ; post_env=_ } -> | Declaration_constant { binder ; expr ; inline } ->
let%bind expression = transpile_annotated_expression expr in let%bind expression = transpile_annotated_expression expr in
let tv = Combinators.Expression.get_type expression in let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (binder, tv) env in let env' = Environment.add (binder, tv) env in
ok @@ ((binder, inline, expression), environment_wrap env env') ok @@ Some ((binder, inline, expression), environment_wrap env env')
| _ -> ok None
let transpile_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 aux (prev:(toplevel_statement list * Environment.t) result) cur =
let%bind (hds, env) = prev in let%bind (hds, env) = prev in
let%bind ((_, env') as cur') = transpile_declaration env cur in match%bind transpile_declaration env cur with
ok (hds @ [ cur' ], env'.post_environment) | Some ((_ , env') as cur') -> ok (hds @ [ cur' ] , env'.post_environment)
| None -> ok (hds , env)
in in
let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in
ok statements ok statements
(* check whether the storage contains a big_map, if yes, check that (* check whether the storage contains a big_map, if yes, check that
it appears on the left hand side of a pair *) it appears on the left hand side of a pair
TODO : checking should appears in check_pass.
*)
let check_storage f ty loc : (anon_function * _) result = let check_storage f ty loc : (anon_function * _) result =
let rec aux (t:type_expression) on_big_map = let rec aux (t:type_expression) on_big_map =
match t.type_content with match t.type_content with

10
src/passes/10-transpiler/untranspiler.ml
View File

@ -42,19 +42,19 @@ open Errors
let rec untranspile (v : value) (t : AST.type_expression) : AST.expression result = let rec untranspile (v : value) (t : AST.type_expression) : AST.expression result =
let open! AST in let open! AST in
let return e = ok (make_a_e_empty e t) in let return e = ok (make_e e t) in
match t.type_content with match t.type_content with
| T_variable (name) when Var.equal name Stage_common.Constant.t_bool -> ( | T_variable (name) when Var.equal name Stage_common.Constant.t_bool -> (
let%bind b = let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@ trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in get_bool v in
return (e_bool b Environment.empty) return (e_bool b)
) )
| t when (compare t (t_bool ()).type_content) = 0-> ( | t when (compare t (t_bool ()).type_content) = 0-> (
let%bind b = let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@ trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in get_bool v in
return (e_bool b Environment.empty) return (e_bool b)
) )
| T_constant type_constant -> ( | T_constant type_constant -> (
match type_constant with match type_constant with
@ -152,10 +152,10 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
trace_strong (wrong_mini_c_value "option" v) @@ trace_strong (wrong_mini_c_value "option" v) @@
get_option v in get_option v in
match opt with match opt with
| None -> ok (e_a_empty_none o) | None -> ok (e_a_none o)
| Some s -> | Some s ->
let%bind s' = untranspile s o in let%bind s' = untranspile s o in
ok (e_a_empty_some s') ok (e_a_some s')
) )
| TC_map {k=k_ty;v=v_ty}-> ( | TC_map {k=k_ty;v=v_ty}-> (
let%bind map = let%bind map =

4
src/passes/8-typer-new/typer.ml
View File

@ -29,7 +29,7 @@ let rec type_declaration env state : I.declaration -> (environment * O.typer_sta
trace (constant_declaration_error binder expression tv'_opt) @@ trace (constant_declaration_error binder expression tv'_opt) @@
type_expression env state expression in type_expression env state expression in
let post_env = Environment.add_ez_declaration binder expr env in let post_env = Environment.add_ez_declaration binder expr env in
ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline ; post_env} )) ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline} ))
) )
and type_match : environment -> O.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O.typer_state) result = and type_match : environment -> O.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O.typer_state) result =
@ -196,7 +196,7 @@ and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression
let%bind new_state = aggregate_constraints state constraints in let%bind new_state = aggregate_constraints state constraints in
let tv = t_variable type_name () in let tv = t_variable type_name () in
let location = ae.location in let location = ae.location in
let expr' = make_e ~location expr tv e in let expr' = make_e ~location expr tv in
ok @@ (expr' , new_state) in ok @@ (expr' , new_state) in
let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in
let main_error = let main_error =

25
src/passes/8-typer-old/typer.ml
View File

@ -494,27 +494,25 @@ let rec type_program (p:I.program) : (O.program * O.typer_state) result =
let%bind ed' = (bind_map_location (type_declaration e (Solver.placeholder_for_state_of_new_typer ()))) d in let%bind ed' = (bind_map_location (type_declaration e (Solver.placeholder_for_state_of_new_typer ()))) d in
let loc : 'a . 'a Location.wrap -> _ -> _ = fun x v -> Location.wrap ~loc:x.location v in let loc : 'a . 'a Location.wrap -> _ -> _ = fun x v -> Location.wrap ~loc:x.location v in
let (e', _placeholder_for_state_of_new_typer , d') = Location.unwrap ed' in let (e', _placeholder_for_state_of_new_typer , d') = Location.unwrap ed' in
match d' with ok (e', loc ed' d' :: acc)
| None -> ok (e', acc)
| Some d' -> ok (e', loc ed' d' :: acc)
in in
let%bind (_, lst) = let%bind (_, lst) =
trace (fun () -> program_error p ()) @@ trace (fun () -> program_error p ()) @@
bind_fold_list aux (DEnv.default, []) p in bind_fold_list aux (DEnv.default, []) p in
ok @@ (List.rev lst , (Solver.placeholder_for_state_of_new_typer ())) ok @@ (List.rev lst , (Solver.placeholder_for_state_of_new_typer ()))
and type_declaration env (_placeholder_for_state_of_new_typer : O.typer_state) : I.declaration -> (environment * O.typer_state * O.declaration option) result = function and type_declaration env (_placeholder_for_state_of_new_typer : O.typer_state) : I.declaration -> (environment * O.typer_state * O.declaration) result = function
| Declaration_type (type_name , type_expression) -> | Declaration_type (type_binder , type_expr) ->
let%bind tv = evaluate_type env type_expression in let%bind tv = evaluate_type env type_expr in
let env' = Environment.add_type (type_name) tv env in let env' = Environment.add_type (type_binder) tv env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None) ok (env', (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_type { type_binder ; type_expr = tv } ))
| Declaration_constant (binder , tv_opt , inline, expression) -> ( | Declaration_constant (binder , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind expr = let%bind expr =
trace (constant_declaration_error binder expression tv'_opt) @@ trace (constant_declaration_error binder expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in type_expression' ?tv_opt:tv'_opt env expression in
let post_env = Environment.add_ez_declaration binder expr env in let post_env = Environment.add_ez_declaration binder expr env in
ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant { binder ; expr ; inline ; post_env})) ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline}))
) )
and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result = and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result =
@ -674,6 +672,7 @@ and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression
= fun e _placeholder_for_state_of_new_typer ?tv_opt ae -> = fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
let%bind res = type_expression' e ?tv_opt ae in let%bind res = type_expression' e ?tv_opt ae in
ok (res, (Solver.placeholder_for_state_of_new_typer ())) ok (res, (Solver.placeholder_for_state_of_new_typer ()))
and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression -> O.expression result = fun e ?tv_opt ae -> and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression -> O.expression result = fun e ?tv_opt ae ->
let module L = Logger.Stateful() in let module L = Logger.Stateful() in
let return expr tv = let return expr tv =
@ -682,7 +681,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
| None -> ok () | None -> ok ()
| Some tv' -> O.assert_type_expression_eq (tv' , tv) in | Some tv' -> O.assert_type_expression_eq (tv' , tv) in
let location = ae.location in let location = ae.location in
ok @@ make_e ~location expr tv e in ok @@ make_e ~location expr tv in
let main_error = let main_error =
let title () = "typing expression" in let title () = "typing expression" in
let content () = "" in let content () = "" in
@ -736,7 +735,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
generic_try (bad_record_access property ae prev.type_expression ae.location) generic_try (bad_record_access property ae prev.type_expression ae.location)
@@ (fun () -> let ({field_type;_} : O.field_content) = O.LMap.find (convert_label property) r_tv in field_type) in @@ (fun () -> let ({field_type;_} : O.field_content) = O.LMap.find (convert_label property) r_tv in field_type) in
let location = ae.location in let location = ae.location in
ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv e ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv
in in
let%bind ae = let%bind ae =
trace (simple_info "accessing") @@ aux e' path in trace (simple_info "accessing") @@ aux e' path in
@ -832,7 +831,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let e' = Environment.add_ez_binder lname input_type e in let e' = Environment.add_ez_binder lname input_type e in
let%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in let%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in
let output_type = body.type_expression in let output_type = body.type_expression in
let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) in
let lst' = [lambda'; v_col; v_initr] in let lst' = [lambda'; v_col; v_initr] in
let tv_lst = List.map get_type_expression lst' in let tv_lst = List.map get_type_expression lst' in
let%bind (opname', tv) = let%bind (opname', tv) =
@ -853,7 +852,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let e' = Environment.add_ez_binder lname input_type e in let e' = Environment.add_ez_binder lname input_type e in
let%bind body = type_expression' e' result in let%bind body = type_expression' e' result in
let output_type = body.type_expression in let output_type = body.type_expression in
let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) in
let lst' = [lambda';v_initr] in let lst' = [lambda';v_initr] in
let tv_lst = List.map get_type_expression lst' in let tv_lst = List.map get_type_expression lst' in
let%bind (opname',tv) = type_constant opname tv_lst tv_opt in let%bind (opname',tv) = type_constant opname tv_lst tv_opt in

2
src/passes/8-typer-old/typer.mli
View File

@ -39,7 +39,7 @@ module Errors : sig
end end
val type_program : I.program -> (O.program * O.typer_state) result val type_program : I.program -> (O.program * O.typer_state) result
val type_declaration : environment -> O.typer_state -> I.declaration -> (environment * O.typer_state * O.declaration option) result val type_declaration : environment -> O.typer_state -> I.declaration -> (environment * O.typer_state * O.declaration) result
(* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *) (* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
val evaluate_type : environment -> I.type_expression -> O.type_expression result val evaluate_type : environment -> I.type_expression -> O.type_expression result
val type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O.typer_state) result val type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O.typer_state) result

66
src/passes/9-self_ast_typed/helpers.ml
View File

@ -156,10 +156,11 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
and map_program : mapper -> program -> program result = fun m p -> and map_program : mapper -> program -> program result = fun m p ->
let aux = fun (x : declaration) -> let aux = fun (x : declaration) ->
match x with match x with
| Declaration_constant {binder; expr ; inline ; post_env} -> ( | Declaration_constant {binder; expr ; inline} -> (
let%bind expr = map_expression m expr in let%bind expr = map_expression m expr in
ok (Declaration_constant {binder; expr ; inline ; post_env}) ok (Declaration_constant {binder; expr ; inline})
) )
| Declaration_type t -> ok (Declaration_type t)
in in
bind_map_list (bind_map_location aux) p bind_map_list (bind_map_location aux) p
@ -246,11 +247,15 @@ and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matchin
and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p -> and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p ->
let aux = fun (acc,acc_prg) (x : declaration Location.wrap) -> let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
match Location.unwrap x with match Location.unwrap x with
| Declaration_constant {binder ; expr ; inline ; post_env} -> ( | Declaration_constant {binder ; expr ; inline} -> (
let%bind (acc', expr) = fold_map_expression m acc expr in let%bind (acc', expr) = fold_map_expression m acc expr in
let wrap_content = Declaration_constant {binder ; expr ; inline ; post_env} in let wrap_content = Declaration_constant {binder ; expr ; inline} in
ok (acc', List.append acc_prg [{x with wrap_content}]) ok (acc', List.append acc_prg [{x with wrap_content}])
) )
| Declaration_type t -> (
let wrap_content = Declaration_type t in
ok (acc, List.append acc_prg [{x with wrap_content}])
)
in in
bind_fold_list aux (init,[]) p bind_fold_list aux (init,[]) p
@ -298,30 +303,31 @@ type contract_type = {
} }
let fetch_contract_type : string -> program -> contract_type result = fun main_fname program -> let fetch_contract_type : string -> program -> contract_type result = fun main_fname program ->
let main_decl = List.rev @@ List.filter let aux declt = match Location.unwrap declt with
(fun declt -> | Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
let (Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ }) = Location.unwrap declt in if String.equal (Var.to_name binder) main_fname
String.equal (Var.to_name binder) main_fname then Some p
) else None
program | Declaration_type _ -> None
in in
match main_decl with let main_decl_opt = List.find_map aux @@ List.rev program in
| (hd::_) -> ( let%bind main_decl =
let (Declaration_constant { binder=_ ; expr ; inline=_ ; post_env=_ }) = Location.unwrap hd in trace_option (simple_error ("Entrypoint '"^main_fname^"' does not exist")) @@
match expr.type_expression.type_content with main_decl_opt
| T_arrow {type1 ; type2} -> ( in
match type1.type_content , type2.type_content with let { binder=_ ; expr ; inline=_ } = main_decl in
| T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) -> match expr.type_expression.type_content with
let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in | T_arrow {type1 ; type2} -> (
let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in match type1.type_content , type2.type_content with
let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@ | T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) ->
Ast_typed.assert_t_list_operation listop in let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in
let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@ let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in
Ast_typed.assert_type_expression_eq (storage,storage') in let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@
(* TODO: on storage/parameter : assert_storable, assert_passable ? *) Ast_typed.assert_t_list_operation listop in
ok { parameter ; storage } let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@
| _ -> fail @@ Errors.bad_contract_io main_fname expr Ast_typed.assert_type_expression_eq (storage,storage') in
) (* TODO: on storage/parameter : assert_storable, assert_passable ? *)
| _ -> fail @@ Errors.bad_contract_io main_fname expr ok { parameter ; storage }
| _ -> fail @@ Errors.bad_contract_io main_fname expr
) )
| [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist") | _ -> fail @@ Errors.bad_contract_io main_fname expr

10
src/passes/9-self_ast_typed/michelson_layout.ml
View File

@ -13,25 +13,25 @@ let accessor (record:expression) (path:label) (t:type_expression) =
{ expression_content = E_record_accessor {record; path} ; { expression_content = E_record_accessor {record; path} ;
location = Location.generated ; location = Location.generated ;
type_expression = t ; type_expression = t ;
environment = record.environment } }
let constructor (constructor:constructor') (element:expression) (t:type_expression) = let constructor (constructor:constructor') (element:expression) (t:type_expression) =
{ expression_content = E_constructor { constructor ; element } ; { expression_content = E_constructor { constructor ; element } ;
location = Location.generated ; location = Location.generated ;
type_expression = t ; type_expression = t ;
environment = element.environment } }
let match_var (t:type_expression) = let match_var (t:type_expression) =
{ expression_content = E_variable (Var.of_name "x") ; { expression_content = E_variable (Var.of_name "x") ;
location = Location.generated ; location = Location.generated ;
type_expression = t ; type_expression = t ;
environment = Environment.add_ez_binder (Var.of_name "x") t Environment.empty} }
let matching (e:expression) matchee cases = let matching (e:expression) matchee cases =
{ expression_content = E_matching {matchee ; cases}; { expression_content = E_matching {matchee ; cases};
location = Location.generated ; location = Location.generated ;
type_expression = e.type_expression ; type_expression = e.type_expression ;
environment = e.environment } }
let rec descend_types s lmap i = let rec descend_types s lmap i =
if i > 0 then if i > 0 then
@ -105,7 +105,7 @@ let rec to_right_comb_record
let exp = { expression_content = E_record_accessor {record = prev ; path = label } ; let exp = { expression_content = E_record_accessor {record = prev ; path = label } ;
location = Location.generated ; location = Location.generated ;
type_expression = field_type ; type_expression = field_type ;
environment = prev.environment } in } in
let conv_map' = LMap.add (Label "0") exp conv_map in let conv_map' = LMap.add (Label "0") exp conv_map in
LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb_record prev tl conv_map')}) conv_map' LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb_record prev tl conv_map')}) conv_map'

3
src/passes/9-self_ast_typed/self_ast_typed.ml
View File

@ -13,8 +13,7 @@ let contract_passes = [
let all_program program = let all_program program =
let all_p = List.map Helpers.map_program all_passes in let all_p = List.map Helpers.map_program all_passes in
let%bind program' = bind_chain all_p program in let%bind program' = bind_chain all_p program in
let program'' = Recompute_environment.program Environment.default program' in ok program'
ok program''
let all_expression = let all_expression =
let all_p = List.map Helpers.map_expression all_passes in let all_p = List.map Helpers.map_expression all_passes in

4
src/stages/4-ast_typed/PP.ml
View File

@ -326,8 +326,10 @@ and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit =
let declaration ppf (d : declaration) = let declaration ppf (d : declaration) =
match d with match d with
| Declaration_constant {binder; expr; inline; post_env=_} -> | Declaration_constant {binder; expr; inline} ->
fprintf ppf "const %a = %a%a" expression_variable binder expression expr option_inline inline fprintf ppf "const %a = %a%a" expression_variable binder expression expr option_inline inline
| Declaration_type {type_binder; type_expr} ->
fprintf ppf "type %a = %a" type_variable type_binder type_expression type_expr
let program ppf (p : program) = let program ppf (p : program) =
fprintf ppf "@[<v>%a@]" fprintf ppf "@[<v>%a@]"

23
src/stages/4-ast_typed/ast.ml
View File

@ -272,31 +272,30 @@ and declaration_loc = declaration location_wrap
and program = declaration_loc list and program = declaration_loc list
(* A Declaration_constant is described by
* a name + a type-annotated expression
* a boolean indicating whether it should be inlined
* the environment before the declaration (the original environment)
* the environment after the declaration (i.e. with that new declaration added to the original environment). *)
and declaration_constant = { and declaration_constant = {
binder : expression_variable ; binder : expression_variable ;
expr : expression ; expr : expression ;
inline : bool ; inline : bool ;
post_env : environment ; }
and declaration_type = {
type_binder : type_variable ;
type_expr : type_expression ;
} }
and declaration = and declaration =
(* A Declaration_constant is described by
* a name + a type-annotated expression
* a boolean indicating whether it should be inlined
* the environment before the declaration (the original environment)
* the environment after the declaration (i.e. with that new declaration added to the original environment). *)
| Declaration_constant of declaration_constant | Declaration_constant of declaration_constant
(* | Declaration_type of declaration_type
| Declaration_type of (type_variable * type_expression)
| Declaration_constant of (named_expression * (environment * environment))
*)
(* | Macro_declaration of macro_declaration *)
and expression = { and expression = {
expression_content: expression_content ; expression_content: expression_content ;
location: location ; location: location ;
type_expression: type_expression ; type_expression: type_expression ;
environment: environment ;
} }
and map_kv = { and map_kv = {

3
src/stages/4-ast_typed/ast_typed.ml
View File

@ -4,7 +4,6 @@ module PP = PP
module PP_generic = PP_generic module PP_generic = PP_generic
module Combinators = struct module Combinators = struct
include Combinators include Combinators
include Combinators_environment
end end
module Misc = struct module Misc = struct
include Misc include Misc
@ -15,3 +14,5 @@ module Helpers = Helpers
include Types include Types
include Misc include Misc
include Combinators include Combinators
let program_environment env program = fst (Compute_environment.program env program)

11
src/stages/4-ast_typed/combinators.ml
View File

@ -24,10 +24,9 @@ module Errors = struct
end end
let make_t ?(loc = Location.generated) type_content core = {type_content; location=loc; type_meta = core} let make_t ?(loc = Location.generated) type_content core = {type_content; location=loc; type_meta = core}
let make_e ?(location = Location.generated) expression_content type_expression environment = { let make_e ?(location = Location.generated) expression_content type_expression = {
expression_content ; expression_content ;
type_expression ; type_expression ;
environment ;
location ; location ;
} }
let make_n_t type_name type_value = { type_name ; type_value } let make_n_t type_name type_value = { type_name ; type_value }
@ -83,7 +82,6 @@ let t_shallow_closure param result ?loc ?s () : type_expression = make_t ?loc (T
let get_type_expression (x:expression) = x.type_expression let get_type_expression (x:expression) = x.type_expression
let get_type' (x:type_expression) = x.type_content let get_type' (x:type_expression) = x.type_content
let get_environment (x:expression) = x.environment
let get_expression (x:expression) = x.expression_content let get_expression (x:expression) = x.expression_content
let get_lambda e : _ result = match e.expression_content with let get_lambda e : _ result = match e.expression_content with
@ -330,13 +328,13 @@ let e_let_in let_binder inline rhs let_result = E_let_in { let_binder ; rhs ; le
let e_constructor constructor element: expression_content = E_constructor {constructor;element} let e_constructor constructor element: expression_content = E_constructor {constructor;element}
let e_bool b env : expression_content = e_constructor (Constructor (string_of_bool b)) (make_e (e_unit ())(t_unit()) env) let e_bool b : expression_content = e_constructor (Constructor (string_of_bool b)) (make_e (e_unit ())(t_unit()))
let e_a_unit = make_e (e_unit ()) (t_unit ()) let e_a_unit = make_e (e_unit ()) (t_unit ())
let e_a_int n = make_e (e_int n) (t_int ()) let e_a_int n = make_e (e_int n) (t_int ())
let e_a_nat n = make_e (e_nat n) (t_nat ()) let e_a_nat n = make_e (e_nat n) (t_nat ())
let e_a_mutez n = make_e (e_mutez n) (t_mutez ()) let e_a_mutez n = make_e (e_mutez n) (t_mutez ())
let e_a_bool b = fun env -> make_e (e_bool b env) (t_bool ()) env let e_a_bool b = make_e (e_bool b) (t_bool ())
let e_a_string s = make_e (e_string s) (t_string ()) let e_a_string s = make_e (e_string s) (t_string ())
let e_a_address s = make_e (e_address s) (t_address ()) let e_a_address s = make_e (e_address s) (t_address ())
let e_a_pair a b = make_e (e_pair a b) let e_a_pair a b = make_e (e_pair a b)
@ -381,7 +379,8 @@ let get_a_record_accessor = fun t ->
let get_declaration_by_name : program -> string -> declaration result = fun p name -> let get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration -> let aux : declaration -> bool = fun declaration ->
match declaration with match declaration with
| Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ } -> binder = Var.of_name name | Declaration_constant { binder ; expr=_ ; inline=_ } -> binder = Var.of_name name
| Declaration_type _ -> false
in in
trace_option (Errors.declaration_not_found name ()) @@ trace_option (Errors.declaration_not_found name ()) @@
List.find_opt aux @@ List.map Location.unwrap p List.find_opt aux @@ List.map Location.unwrap p

37
src/stages/4-ast_typed/combinators.mli
View File

@ -3,7 +3,7 @@ open Types
val make_n_t : type_variable -> type_expression -> named_type_content val make_n_t : type_variable -> type_expression -> named_type_content
val make_t : ?loc:Location.t -> type_content -> S.type_expression option -> type_expression val make_t : ?loc:Location.t -> type_content -> S.type_expression option -> type_expression
val make_e : ?location:Location.t -> expression_content -> type_expression -> environment -> expression val make_e : ?location:Location.t -> expression_content -> type_expression -> expression
val t_bool : ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression val t_bool : ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
val t_string : ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression val t_string : ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
@ -38,7 +38,6 @@ val t_function : type_expression -> type_expression -> ?loc:Location.t -> ?s:S.t
val t_shallow_closure : type_expression -> type_expression -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression val t_shallow_closure : type_expression -> type_expression -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
val get_type_expression : expression -> type_expression val get_type_expression : expression -> type_expression
val get_type' : type_expression -> type_content val get_type' : type_expression -> type_content
val get_environment : expression -> environment
val get_expression : expression -> expression_content val get_expression : expression -> expression_content
val get_lambda : expression -> lambda result val get_lambda : expression -> lambda result
val get_lambda_with_type : expression -> (lambda * ( type_expression * type_expression) ) result val get_lambda_with_type : expression -> (lambda * ( type_expression * type_expression) ) result
@ -119,7 +118,7 @@ val e_unit : unit -> expression_content
val e_int : Z.t -> expression_content val e_int : Z.t -> expression_content
val e_nat : Z.t -> expression_content val e_nat : Z.t -> expression_content
val e_mutez : Z.t -> expression_content val e_mutez : Z.t -> expression_content
val e_bool : bool -> environment -> expression_content val e_bool : bool -> expression_content
val e_string : ligo_string -> expression_content val e_string : ligo_string -> expression_content
val e_bytes : bytes -> expression_content val e_bytes : bytes -> expression_content
val e_timestamp : Z.t -> expression_content val e_timestamp : Z.t -> expression_content
@ -135,22 +134,22 @@ val e_application : expression -> expression -> expression_content
val e_variable : expression_variable -> expression_content val e_variable : expression_variable -> expression_content
val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content
val e_a_unit : environment -> expression val e_a_unit : expression
val e_a_int : Z.t -> environment -> expression val e_a_int : Z.t -> expression
val e_a_nat : Z.t -> environment -> expression val e_a_nat : Z.t -> expression
val e_a_mutez : Z.t -> environment -> expression val e_a_mutez : Z.t -> expression
val e_a_bool : bool -> environment -> expression val e_a_bool : bool -> expression
val e_a_string : ligo_string -> environment -> expression val e_a_string : ligo_string -> expression
val e_a_address : string -> environment -> expression val e_a_address : string -> expression
val e_a_pair : expression -> expression -> environment -> expression val e_a_pair : expression -> expression -> expression
val e_a_some : expression -> environment -> expression val e_a_some : expression -> expression
val e_a_lambda : lambda -> type_expression -> type_expression -> environment -> expression val e_a_lambda : lambda -> type_expression -> type_expression -> expression
val e_a_none : type_expression -> environment -> expression val e_a_none : type_expression -> expression
val e_a_record : expression label_map -> environment -> expression val e_a_record : expression label_map -> expression
val e_a_application : expression -> expression -> environment -> expression val e_a_application : expression -> expression -> expression
val e_a_variable : expression_variable -> type_expression -> environment -> expression val e_a_variable : expression_variable -> type_expression -> expression
val ez_e_a_record : ( label * expression ) list -> environment -> expression val ez_e_a_record : ( label * expression ) list -> expression
val e_a_let_in : expression_variable -> bool -> expression -> expression -> environment -> expression val e_a_let_in : expression_variable -> bool -> expression -> expression -> expression
val get_a_int : expression -> Z.t result val get_a_int : expression -> Z.t result
val get_a_unit : expression -> unit result val get_a_unit : expression -> unit result

25
src/stages/4-ast_typed/combinators_environment.ml
View File

@ -1,25 +0,0 @@
open Types
open Combinators
let make_a_e_empty expression type_annotation = make_e expression type_annotation Environment.empty
let e_a_empty_unit = e_a_unit Environment.empty
let e_a_empty_int n = e_a_int n Environment.empty
let e_a_empty_nat n = e_a_nat n Environment.empty
let e_a_empty_mutez n = e_a_mutez n Environment.empty
let e_a_empty_bool b = e_a_bool b Environment.empty
let e_a_empty_string s = e_a_string s Environment.empty
let e_a_empty_address s = e_a_address s Environment.empty
let e_a_empty_pair a b = e_a_pair a b Environment.empty
let e_a_empty_some s = e_a_some s Environment.empty
let e_a_empty_none t = e_a_none t Environment.empty
let e_a_empty_record r = e_a_record r Environment.empty
let ez_e_a_empty_record r = ez_e_a_record r Environment.empty
let e_a_empty_lambda l i o = e_a_lambda l i o Environment.empty
open Environment
let env_sum_type ?(env = empty)
?(type_name = Var.of_name "a_sum_type")
(lst : (constructor' * ctor_content) list) =
add_type type_name (make_t_ez_sum lst) env

19
src/stages/4-ast_typed/combinators_environment.mli
View File

@ -1,19 +0,0 @@
open Types
val make_a_e_empty : expression_content -> type_expression -> expression
val e_a_empty_unit : expression
val e_a_empty_int : Z.t -> expression
val e_a_empty_nat : Z.t -> expression
val e_a_empty_mutez : Z.t -> expression
val e_a_empty_bool : bool -> expression
val e_a_empty_string : ligo_string -> expression
val e_a_empty_address : string -> expression
val e_a_empty_pair : expression -> expression -> expression
val e_a_empty_some : expression -> expression
val e_a_empty_none : type_expression -> expression
val e_a_empty_record : expression label_map -> expression
val ez_e_a_empty_record : ( label * expression ) list -> expression
val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression
val env_sum_type : ?env:environment -> ?type_name:type_variable -> (constructor' * ctor_content) list -> environment

51
src/passes/9-self_ast_typed/recompute_environment.ml → src/stages/4-ast_typed/compute_environment.ml
View File

@ -1,23 +1,9 @@
open Ast_typed open Types
(*
During the modifications of the passes on `Ast_typed`, the binding
environments are not kept in sync. To palliate this, this module
recomputes them from scratch.
*)
(*
This module is very coupled to `typer.ml`. Given environments are
not used until the next pass, it makes sense to split this into
its own separate pass. This pass would go from `Ast_typed` without
environments to `Ast_typed` with embedded environments.
*)
let rec expression : environment -> expression -> expression = fun env expr -> let rec expression : environment -> expression -> expression = fun env expr ->
(* Standard helper functions to help with the fold *) (* Standard helper functions to help with the fold *)
let return ?(env' = env) content = { let return content = {
expr with expr with
environment = env' ;
expression_content = content ; expression_content = content ;
} in } in
let return_id = return expr.expression_content in let return_id = return expr.expression_content in
@ -90,7 +76,7 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs ->
let match_cons = let match_cons =
let mc = c.match_cons in let mc = c.match_cons in
let env_hd = Environment.add_ez_binder mc.hd mc.tv env in let env_hd = Environment.add_ez_binder mc.hd mc.tv env in
let env_tl = Environment.add_ez_binder mc.tl (t_list mc.tv ()) env_hd in let env_tl = Environment.add_ez_binder mc.tl (Combinators.t_list mc.tv ()) env_hd in
let body = self ~env':env_tl mc.body in let body = self ~env':env_tl mc.body in
{ mc with body } { mc with body }
in in
@ -139,24 +125,27 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs ->
return @@ Match_variant { c with cases } return @@ Match_variant { c with cases }
) )
let program : environment -> program -> program = fun init_env prog -> let program : environment -> program -> environment * program = fun init_env prog ->
(* (*
BAD BAD
We take the old type environment and add it to the current value environment We take the old type environment and add it to the current value environment
because type declarations are removed in the typer. They should be added back. because type declarations are removed in the typer. They should be added back.
*) *)
let merge old_env re_env = {
expression_environment = re_env.expression_environment ;
type_environment = old_env.type_environment ;
} in
let aux (pre_env , rev_decls) decl_wrapped = let aux (pre_env , rev_decls) decl_wrapped =
let (Declaration_constant c) = Location.unwrap decl_wrapped in match Location.unwrap decl_wrapped with
let expr = expression pre_env c.expr in | Declaration_constant c -> (
let post_env = Environment.add_ez_declaration c.binder expr pre_env in let expr = expression pre_env c.expr in
let post_env' = merge c.post_env post_env in let post_env = Environment.add_ez_declaration c.binder expr pre_env in
let wrap_content = Declaration_constant { c with expr ; post_env = post_env' } in let wrap_content = Declaration_constant { c with expr } in
let decl_wrapped' = { decl_wrapped with wrap_content } in let decl_wrapped' = { decl_wrapped with wrap_content } in
(post_env , decl_wrapped' :: rev_decls) (post_env , decl_wrapped' :: rev_decls)
)
| Declaration_type t -> (
let post_env = Environment.add_type t.type_binder t.type_expr pre_env in
let wrap_content = Declaration_type t in
let decl_wrapped' = { decl_wrapped with wrap_content } in
(post_env , decl_wrapped' :: rev_decls)
)
in in
let (_last_env , rev_decls) = List.fold_left aux (init_env , []) prog in let (last_env , rev_decls) = List.fold_left aux (init_env , []) prog in
List.rev rev_decls (last_env , List.rev rev_decls)

3
src/stages/4-ast_typed/environment.ml
View File

@ -38,6 +38,9 @@ let add_ez_binder : expression_variable -> type_expression -> t -> t = fun k v e
let add_ez_declaration : expression_variable -> expression -> t -> t = fun k ae e -> let add_ez_declaration : expression_variable -> expression -> t -> t = fun k ae e ->
add_expr k (make_element_declaration e ae) e add_expr k (make_element_declaration e ae) e
let add_ez_sum_type ?(env = empty) ?(type_name = Var.of_name "a_sum_type") (lst : (constructor' * ctor_content) list) =
add_type type_name (make_t_ez_sum lst) env
let convert_constructor' (S.Constructor c) = Constructor c let convert_constructor' (S.Constructor c) = Constructor c
let get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option = fun k x -> (* Left is the constructor, right is the sum type *) let get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option = fun k x -> (* Left is the constructor, right is the sum type *)

1
src/stages/4-ast_typed/environment.mli
View File

@ -11,6 +11,7 @@ val get_opt : expression_variable -> t -> element option
val get_type_opt : type_variable -> t -> type_expression option val get_type_opt : type_variable -> t -> type_expression option
val get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option val get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option
val add_ez_sum_type : ?env:environment -> ?type_name:type_variable -> (constructor' * ctor_content) list -> environment
module PP : sig module PP : sig
open Format open Format

18
src/stages/4-ast_typed/misc.ml
View File

@ -511,19 +511,17 @@ let merge_annotation (a:type_expression option) (b:type_expression option) err :
let get_entry (lst : program) (name : string) : expression result = let get_entry (lst : program) (name : string) : expression result =
trace_option (Errors.missing_entry_point name) @@ trace_option (Errors.missing_entry_point name) @@
let aux x = let aux x =
let (Declaration_constant { binder ; expr ; inline=_ ; _ }) = Location.unwrap x in match Location.unwrap x with
if Var.equal binder (Var.of_name name) | Declaration_constant { binder ; expr ; inline=_ } -> (
then Some expr if Var.equal binder (Var.of_name name)
else None then Some expr
else None
)
| Declaration_type _ -> None
in in
List.find_map aux lst List.find_map aux lst
let program_environment (program : program) : environment =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant { binder=_ ; expr=_ ; inline=_ ; post_env } -> post_env
let equal_variables a b : bool = let equal_variables a b : bool =
match a.expression_content, b.expression_content with match a.expression_content, b.expression_content with
| E_variable a, E_variable b -> Var.equal a b | E_variable a, E_variable b -> Var.equal a b

1
src/stages/4-ast_typed/misc.mli
View File

@ -70,7 +70,6 @@ val assert_literal_eq : ( literal * literal ) -> unit result
*) *)
val get_entry : program -> string -> expression result val get_entry : program -> string -> expression result
val program_environment : program -> environment
val p_constant : constant_tag -> p_ctor_args -> type_value val p_constant : constant_tag -> p_ctor_args -> type_value
val c_equation : type_value -> type_value -> string -> type_constraint val c_equation : type_value -> type_value -> string -> type_constraint

27
src/stages/4-ast_typed/misc_smart.ml
View File

@ -8,8 +8,9 @@ let program_to_main : program -> string -> lambda result = fun p s ->
let%bind (main , input_type , _) = let%bind (main , input_type , _) =
let pred = fun d -> let pred = fun d ->
match d with match d with
| Declaration_constant { binder; expr; inline=_ ; post_env=_ } when binder = Var.of_name s -> Some expr | Declaration_constant { binder; expr; inline=_ } when binder = Var.of_name s -> Some expr
| Declaration_constant _ -> None | Declaration_constant _ -> None
| Declaration_type _ -> None
in in
let%bind main = let%bind main =
trace_option (simple_error "no main with given name") @@ trace_option (simple_error "no main with given name") @@
@ -20,16 +21,11 @@ let program_to_main : program -> string -> lambda result = fun p s ->
| _ -> simple_fail "program main isn't a function" in | _ -> simple_fail "program main isn't a function" in
ok (main , input_ty , output_ty) ok (main , input_ty , output_ty)
in in
let env =
let aux = fun _ d ->
match d with
| Declaration_constant {binder=_ ; expr= _ ; inline=_ ; post_env } -> post_env in
List.fold_left aux Environment.empty (List.map Location.unwrap p) in
let binder = Var.of_name "@contract_input" in let binder = Var.of_name "@contract_input" in
let result = let result =
let input_expr = e_a_variable binder input_type env in let input_expr = e_a_variable binder input_type in
let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) env in let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) in
e_a_application main_expr input_expr env in e_a_application main_expr input_expr in
ok { ok {
binder ; binder ;
result ; result ;
@ -46,8 +42,8 @@ module Captured_variables = struct
let of_list : expression_variable list -> bindings = fun x -> x let of_list : expression_variable list -> bindings = fun x -> x
let rec expression : bindings -> expression -> bindings result = fun b e -> let rec expression : bindings -> expression -> bindings result = fun b e ->
expression_content b e.environment e.expression_content expression_content b e.expression_content
and expression_content : bindings -> environment -> expression_content -> bindings result = fun b env ec -> and expression_content : bindings -> expression_content -> bindings result = fun b ec ->
let self = expression b in let self = expression b in
match ec with match ec with
| E_lambda l -> ok @@ Free_variables.lambda empty l | E_lambda l -> ok @@ Free_variables.lambda empty l
@ -56,12 +52,7 @@ module Captured_variables = struct
let%bind lst' = bind_map_list self arguments in let%bind lst' = bind_map_list self arguments in
ok @@ unions lst' ok @@ unions lst'
| E_variable name -> ( | E_variable name -> (
let%bind env_element = if mem name b then ok empty else ok (singleton name)
trace_option (simple_error "missing var in env") @@
Environment.get_opt name env in
match env_element.definition with
| ED_binder -> ok empty
| ED_declaration {expr=_ ; free_variables=_} -> simple_fail "todo"
) )
| E_application {lamb;args} -> | E_application {lamb;args} ->
let%bind lst' = bind_map_list self [ lamb ; args ] in let%bind lst' = bind_map_list self [ lamb ; args ] in
@ -84,7 +75,7 @@ module Captured_variables = struct
expression b' li.let_result expression b' li.let_result
| E_recursive r -> | E_recursive r ->
let b' = union (singleton r.fun_name) b in let b' = union (singleton r.fun_name) b in
expression_content b' env @@ E_lambda r.lambda expression_content b' @@ E_lambda r.lambda
and matching_variant_case : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } -> and matching_variant_case : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } ->
f (union (singleton pattern) b) body f (union (singleton pattern) b) body

15
src/stages/typesystem/misc.ml
View File

@ -195,20 +195,19 @@ module Substitution = struct
let%bind cases = s_matching_expr ~substs cases in let%bind cases = s_matching_expr ~substs cases in
ok @@ T.E_matching {matchee;cases} ok @@ T.E_matching {matchee;cases}
and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; environment; location } -> and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; location } ->
let%bind expression_content = s_expression_content ~substs expression_content in let%bind expression_content = s_expression_content ~substs expression_content in
let%bind type_expr = s_type_expression ~substs type_expression in let%bind type_expr = s_type_expression ~substs type_expression in
let%bind environment = s_environment ~substs environment in
let location = location in let location = location in
ok T.{ expression_content;type_expression=type_expr; environment; location } ok T.{ expression_content;type_expression=type_expr; location }
and s_declaration : T.declaration w = fun ~substs -> and s_declaration : T.declaration w = fun ~substs ->
function function
Ast_typed.Declaration_constant {binder ; expr ; inline ; post_env} -> | Ast_typed.Declaration_constant {binder ; expr ; inline} ->
let%bind binder = s_variable ~substs binder in let%bind binder = s_variable ~substs binder in
let%bind expr = s_expression ~substs expr in let%bind expr = s_expression ~substs expr in
let%bind post_env = s_environment ~substs post_env in ok @@ Ast_typed.Declaration_constant {binder; expr; inline}
ok @@ Ast_typed.Declaration_constant {binder; expr; inline; post_env} | Declaration_type t -> ok (Ast_typed.Declaration_type t)
and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d -> and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d ->
Trace.bind_map_location (s_declaration ~substs) d Trace.bind_map_location (s_declaration ~substs) d

4
src/test/test_helpers.ml
View File

@ -38,7 +38,7 @@ open Ast_imperative
let pack_payload (program:Ast_typed.program) (payload:expression) : bytes result = let pack_payload (program:Ast_typed.program) (payload:expression) : bytes result =
let%bind code = let%bind code =
let env = Ast_typed.program_environment program in let env = Ast_typed.program_environment Environment.default program in
let%bind sugar = Compile.Of_imperative.compile_expression payload in let%bind sugar = Compile.Of_imperative.compile_expression payload in
let%bind core = Compile.Of_sugar.compile_expression sugar in let%bind core = Compile.Of_sugar.compile_expression sugar in
@ -89,7 +89,7 @@ let typed_program_with_imperative_input_to_michelson
(program: Ast_typed.program) (entry_point: string) (program: Ast_typed.program) (entry_point: string)
(input: Ast_imperative.expression) : Compiler.compiled_expression result = (input: Ast_imperative.expression) : Compiler.compiled_expression result =
Printexc.record_backtrace true; Printexc.record_backtrace true;
let env = Ast_typed.program_environment program in let env = Ast_typed.program_environment Environment.default program in
let state = Typer.Solver.initial_state in let state = Typer.Solver.initial_state in
let%bind sugar = Compile.Of_imperative.compile_expression input in let%bind sugar = Compile.Of_imperative.compile_expression input in
let%bind core = Compile.Of_sugar.compile_expression sugar in let%bind core = Compile.Of_sugar.compile_expression sugar in

4
src/test/typer_tests.ml
View File

@ -34,7 +34,7 @@ module TestExpressions = struct
module I = Simplified.Combinators module I = Simplified.Combinators
module O = Typed.Combinators module O = Typed.Combinators
module E = O module E = Typed.Environment
let unit () : unit result = test_expression I.(e_unit ()) O.(t_unit ()) let unit () : unit result = test_expression I.(e_unit ()) O.(t_unit ())
let int () : unit result = test_expression I.(e_int (Z.of_int 32)) O.(t_int ()) let int () : unit result = test_expression I.(e_int (Z.of_int 32)) O.(t_int ())
@ -59,7 +59,7 @@ module TestExpressions = struct
(Typed.Constructor "foo", {ctor_type = Typed.t_int () ; michelson_annotation = None ; ctor_decl_pos = 0}); (Typed.Constructor "foo", {ctor_type = Typed.t_int () ; michelson_annotation = None ; ctor_decl_pos = 0});
(Typed.Constructor "bar", {ctor_type = Typed.t_string () ; michelson_annotation = None ; ctor_decl_pos = 1}) ] (Typed.Constructor "bar", {ctor_type = Typed.t_string () ; michelson_annotation = None ; ctor_decl_pos = 1}) ]
in test_expression in test_expression
~env:(E.env_sum_type variant_foo_bar) ~env:(E.add_ez_sum_type variant_foo_bar)
I.(e_constructor "foo" (e_int (Z.of_int 32))) I.(e_constructor "foo" (e_int (Z.of_int 32)))
O.(make_t_ez_sum variant_foo_bar) O.(make_t_ez_sum variant_foo_bar)