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

remove environments from the ast

Browse Source
This commit is contained in:
Gabriel ALFOUR 2020-05-27 23:01:07 +02:00
parent c19c34d5d3
commit 294e048aff
22 changed files with 217 additions and 221 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 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 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) =
(* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in
@ -290,7 +290,7 @@ let interpret =
| Some init_file ->
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 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)
| 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 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 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) =
(* fails if the given entry point is not a valid contract *)
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 =
toplevel ~display_format @@
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 michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
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 =
toplevel ~display_format @@
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

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 =
fun prg ->
let%bind (res,_) = bind_fold_list
(fun (pp,top_env) el ->
let (Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _}) = Location.unwrap el in
let%bind v =
(*TODO This TRY-CATCH is here until we properly implement effects*)
try
eval expr top_env
with Temporary_hack s -> ok @@ V_Failure s
(*TODO This TRY-CATCH is here until we properly implement effects*)
in
let pp' = pp^"\n val "^(Var.to_name binder)^" = "^(Ligo_interpreter.PP.pp_value v) in
let top_env' = Env.extend top_env (binder, v) in
ok @@ (pp',top_env')
)
let aux (pp,top_env) el =
match Location.unwrap el with
| Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _} ->
let%bind v =
(*TODO This TRY-CATCH is here until we properly implement effects*)
try
eval expr top_env
with Temporary_hack s ->
ok (V_Failure s)
(*TODO This TRY-CATCH is here until we properly implement effects*)
in
let pp' = pp^"\n val "^(Var.to_name binder)^" = "^(Ligo_interpreter.PP.pp_value v) in
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
ok @@ res

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

@ -374,8 +374,8 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
| Literal_unit -> D_unit
| Literal_void -> D_none
and transpile_environment_element_type : AST.environment_element -> type_expression result = fun ele ->
transpile_type ele.type_value
(* 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 ->
let%bind map_tv = get_t_sum t in
@ -397,11 +397,11 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
return (E_let_in ((let_binder, rhs'.type_expression), inline, rhs', result'))
| E_literal l -> return @@ E_literal (transpile_literal l)
| E_variable name -> (
let%bind ele =
trace_option (corner_case ~loc:__LOC__ "name not in environment") @@
AST.Environment.get_opt name ae.environment in
let%bind tv = transpile_environment_element_type ele in
return ~tv @@ E_variable (name)
(* let%bind ele =
* 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 tv in *)
return @@ E_variable (name)
)
| E_application {lamb; args} ->
let%bind a = transpile_annotated_expression lamb in
@ -759,19 +759,21 @@ 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
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
| Declaration_constant { binder ; expr ; inline ; post_env=_ } ->
| Declaration_constant { binder ; expr ; inline } ->
let%bind expression = transpile_annotated_expression expr in
let tv = Combinators.Expression.get_type expression 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 aux (prev:(toplevel_statement list * Environment.t) result) cur =
let%bind (hds, env) = prev in
let%bind ((_, env') as cur') = transpile_declaration env cur in
ok (hds @ [ cur' ], env'.post_environment)
match%bind transpile_declaration env cur with
| Some ((_ , env') as cur') -> ok (hds @ [ cur' ] , env'.post_environment)
| None -> ok (hds , env)
in
let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in
ok statements

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 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
| T_variable (name) when Var.equal name Stage_common.Constant.t_bool -> (
let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in
return (e_bool b Environment.empty)
return (e_bool b)
)
| t when (compare t (t_bool ()).type_content) = 0-> (
let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in
return (e_bool b Environment.empty)
return (e_bool b)
)
| T_constant type_constant -> (
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) @@
get_option v in
match opt with
| None -> ok (e_a_empty_none o)
| None -> ok (e_a_none o)
| Some s ->
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}-> (
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) @@
type_expression env state expression 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 =
@ -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 tv = t_variable type_name () 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
let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in
let main_error =

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

@ -504,17 +504,17 @@ let rec type_program (p:I.program) : (O.program * O.typer_state) result =
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
| Declaration_type (type_name , type_expression) ->
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type (type_name) tv env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None)
| Declaration_type (type_binder , type_expr) ->
let%bind tv = evaluate_type env type_expr in
let env' = Environment.add_type (type_binder) tv env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_type { type_binder ; type_expr = tv } ))
| Declaration_constant (binder , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind expr =
trace (constant_declaration_error binder expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression 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 ()) , Some (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 =
@ -674,6 +674,7 @@ and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression
= fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
let%bind res = type_expression' e ?tv_opt ae in
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 ->
let module L = Logger.Stateful() in
let return expr tv =
@ -682,7 +683,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
| None -> ok ()
| Some tv' -> O.assert_type_expression_eq (tv' , tv) 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 title () = "typing expression" in
let content () = "" in
@ -736,7 +737,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
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
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
let%bind ae =
trace (simple_info "accessing") @@ aux e' path in
@ -832,7 +833,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
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 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 tv_lst = List.map get_type_expression lst' in
let%bind (opname', tv) =
@ -853,7 +854,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let e' = Environment.add_ez_binder lname input_type e in
let%bind body = type_expression' e' result 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 tv_lst = List.map get_type_expression lst' in
let%bind (opname',tv) = type_constant opname tv_lst tv_opt in

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 ->
let aux = fun (x : declaration) ->
match x with
| Declaration_constant {binder; expr ; inline ; post_env} -> (
| Declaration_constant {binder; expr ; inline} -> (
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
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 ->
let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
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 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}])
)
| Declaration_type t -> (
let wrap_content = Declaration_type t in
ok (acc, List.append acc_prg [{x with wrap_content}])
)
in
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 main_decl = List.rev @@ List.filter
(fun declt ->
let (Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ }) = Location.unwrap declt in
String.equal (Var.to_name binder) main_fname
)
program
let aux declt = match Location.unwrap declt with
| Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
if String.equal (Var.to_name binder) main_fname
then Some p
else None
| Declaration_type _ -> None
in
match main_decl with
| (hd::_) -> (
let (Declaration_constant { binder=_ ; expr ; inline=_ ; post_env=_ }) = Location.unwrap hd in
match expr.type_expression.type_content with
| T_arrow {type1 ; type2} -> (
match type1.type_content , type2.type_content with
| T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) ->
let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in
let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in
let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@
Ast_typed.assert_t_list_operation listop in
let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@
Ast_typed.assert_type_expression_eq (storage,storage') in
(* TODO: on storage/parameter : assert_storable, assert_passable ? *)
ok { parameter ; storage }
| _ -> fail @@ Errors.bad_contract_io main_fname expr
)
| _ -> fail @@ Errors.bad_contract_io main_fname expr
let main_decl_opt = List.find_map aux @@ List.rev program in
let%bind main_decl =
trace_option (simple_error ("Entrypoint '"^main_fname^"' does not exist")) @@
main_decl_opt
in
let { binder=_ ; expr ; inline=_ } = main_decl in
match expr.type_expression.type_content with
| T_arrow {type1 ; type2} -> (
match type1.type_content , type2.type_content with
| T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) ->
let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in
let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in
let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@
Ast_typed.assert_t_list_operation listop in
let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@
Ast_typed.assert_type_expression_eq (storage,storage') in
(* TODO: on storage/parameter : assert_storable, assert_passable ? *)
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} ;
location = Location.generated ;
type_expression = t ;
environment = record.environment }
}
let constructor (constructor:constructor') (element:expression) (t:type_expression) =
{ expression_content = E_constructor { constructor ; element } ;
location = Location.generated ;
type_expression = t ;
environment = element.environment }
}
let match_var (t:type_expression) =
{ expression_content = E_variable (Var.of_name "x") ;
location = Location.generated ;
type_expression = t ;
environment = Environment.add_ez_binder (Var.of_name "x") t Environment.empty}
}
let matching (e:expression) matchee cases =
{ expression_content = E_matching {matchee ; cases};
location = Location.generated ;
type_expression = e.type_expression ;
environment = e.environment }
}
let rec descend_types s lmap i =
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 } ;
location = Location.generated ;
type_expression = field_type ;
environment = prev.environment } in
} 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'

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

@ -13,8 +13,8 @@ let contract_passes = [
let all_program program =
let all_p = List.map Helpers.map_program all_passes in
let%bind program' = bind_chain all_p program in
let program'' = Recompute_environment.program Environment.default program' in
ok program''
(* let program'' = Recompute_environment.program Environment.default program' in *)
ok program'
let all_expression =
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) =
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
| Declaration_type {type_binder; type_expr} ->
fprintf ppf "type %a = %a" type_variable type_binder type_expression type_expr
let program ppf (p : program) =
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
(* 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 = {
binder : expression_variable ;
expr : expression ;
inline : bool ;
post_env : environment ;
}
and declaration_type = {
type_binder : type_variable ;
type_expr : type_expression ;
}
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_type of (type_variable * type_expression)
| Declaration_constant of (named_expression * (environment * environment))
*)
(* | Macro_declaration of macro_declaration *)
| Declaration_type of declaration_type
and expression = {
expression_content: expression_content ;
location: location ;
type_expression: type_expression ;
environment: environment ;
}
and map_kv = {

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

@ -15,3 +15,5 @@ module Helpers = Helpers
include Types
include Misc
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
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 ;
type_expression ;
environment ;
location ;
}
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' (x:type_expression) = x.type_content
let get_environment (x:expression) = x.environment
let get_expression (x:expression) = x.expression_content
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_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_int n = make_e (e_int n) (t_int ())
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_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_address s = make_e (e_address s) (t_address ())
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 aux : declaration -> bool = fun declaration ->
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
trace_option (Errors.declaration_not_found name ()) @@
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_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_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 get_type_expression : expression -> type_expression
val get_type' : type_expression -> type_content
val get_environment : expression -> environment
val get_expression : expression -> expression_content
val get_lambda : expression -> lambda 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_nat : 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_bytes : bytes -> 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_let_in : expression_variable -> inline -> expression -> expression -> expression_content
val e_a_unit : environment -> expression
val e_a_int : Z.t -> environment -> expression
val e_a_nat : Z.t -> environment -> expression
val e_a_mutez : Z.t -> environment -> expression
val e_a_bool : bool -> environment -> expression
val e_a_string : ligo_string -> environment -> expression
val e_a_address : string -> environment -> expression
val e_a_pair : expression -> expression -> environment -> expression
val e_a_some : expression -> environment -> expression
val e_a_lambda : lambda -> type_expression -> type_expression -> environment -> expression
val e_a_none : type_expression -> environment -> expression
val e_a_record : expression label_map -> environment -> expression
val e_a_application : expression -> expression -> environment -> expression
val e_a_variable : expression_variable -> type_expression -> environment -> expression
val ez_e_a_record : ( label * expression ) list -> environment -> expression
val e_a_let_in : expression_variable -> bool -> expression -> expression -> environment -> expression
val e_a_unit : expression
val e_a_int : Z.t -> expression
val e_a_nat : Z.t -> expression
val e_a_mutez : Z.t -> expression
val e_a_bool : bool -> expression
val e_a_string : ligo_string -> expression
val e_a_address : string -> expression
val e_a_pair : expression -> expression -> expression
val e_a_some : expression -> expression
val e_a_lambda : lambda -> type_expression -> type_expression -> expression
val e_a_none : type_expression -> expression
val e_a_record : expression label_map -> expression
val e_a_application : expression -> expression -> expression
val e_a_variable : expression_variable -> type_expression -> expression
val ez_e_a_record : ( label * expression ) list -> expression
val e_a_let_in : expression_variable -> bool -> expression -> expression -> expression
val get_a_int : expression -> Z.t result
val get_a_unit : expression -> unit result

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

@ -1,21 +1,21 @@
open Types
open Combinators
let make_a_e_empty expression type_annotation = make_e expression type_annotation Environment.empty
(* 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
(* 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

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

@ -1,19 +1,19 @@
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 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
(*
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.
*)
open Types
let rec expression : environment -> expression -> expression = fun env expr ->
(* Standard helper functions to help with the fold *)
let return ?(env' = env) content = {
let return content = {
expr with
environment = env' ;
expression_content = 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 mc = c.match_cons 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
{ mc with body }
in
@ -139,24 +125,27 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs ->
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
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.
*)
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 (Declaration_constant c) = Location.unwrap decl_wrapped in
let expr = expression pre_env c.expr in
let post_env = Environment.add_ez_declaration c.binder expr pre_env in
let post_env' = merge c.post_env post_env in
let wrap_content = Declaration_constant { c with expr ; post_env = post_env' } in
let decl_wrapped' = { decl_wrapped with wrap_content } in
(post_env , decl_wrapped' :: rev_decls)
match Location.unwrap decl_wrapped with
| Declaration_constant c -> (
let expr = expression pre_env c.expr in
let post_env = Environment.add_ez_declaration c.binder expr pre_env in
let wrap_content = Declaration_constant { c with expr } in
let decl_wrapped' = { decl_wrapped with wrap_content } in
(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
let (_last_env , rev_decls) = List.fold_left aux (init_env , []) prog in
List.rev rev_decls
let (last_env , rev_decls) = List.fold_left aux (init_env , []) prog in
(last_env , List.rev rev_decls)

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

@ -511,18 +511,21 @@ let merge_annotation (a:type_expression option) (b:type_expression option) err :
let get_entry (lst : program) (name : string) : expression result =
trace_option (Errors.missing_entry_point name) @@
let aux x =
let (Declaration_constant { binder ; expr ; inline=_ ; _ }) = Location.unwrap x in
if Var.equal binder (Var.of_name name)
then Some expr
else None
let aux x =
match Location.unwrap x with
| Declaration_constant { binder ; expr ; inline=_ } -> (
if Var.equal binder (Var.of_name name)
then Some expr
else None
)
| Declaration_type _ -> None
in
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 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 =
match a.expression_content, b.expression_content with

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

@ -70,7 +70,7 @@ val assert_literal_eq : ( literal * literal ) -> unit result
*)
val get_entry : program -> string -> expression result
val program_environment : program -> environment
(* val program_environment : program -> environment *)
val p_constant : constant_tag -> p_ctor_args -> type_value
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 pred = fun d ->
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_type _ -> None
in
let%bind main =
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
ok (main , input_ty , output_ty)
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 result =
let input_expr = e_a_variable binder input_type env in
let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) env in
e_a_application main_expr input_expr 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) in
e_a_application main_expr input_expr in
ok {
binder ;
result ;
@ -46,8 +42,8 @@ module Captured_variables = struct
let of_list : expression_variable list -> bindings = fun x -> x
let rec expression : bindings -> expression -> bindings result = fun b e ->
expression_content b e.environment e.expression_content
and expression_content : bindings -> environment -> expression_content -> bindings result = fun b env ec ->
expression_content b e.expression_content
and expression_content : bindings -> expression_content -> bindings result = fun b ec ->
let self = expression b in
match ec with
| 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
ok @@ unions lst'
| E_variable name -> (
let%bind env_element =
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"
if mem name b then ok empty else ok (singleton name)
)
| E_application {lamb;args} ->
let%bind lst' = bind_map_list self [ lamb ; args ] in
@ -84,7 +75,7 @@ module Captured_variables = struct
expression b' li.let_result
| E_recursive r ->
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 } ->
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
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 type_expr = s_type_expression ~substs type_expression in
let%bind environment = s_environment ~substs environment 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 ->
function
Ast_typed.Declaration_constant {binder ; expr ; inline ; post_env} ->
let%bind binder = s_variable ~substs binder 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; post_env}
| Ast_typed.Declaration_constant {binder ; expr ; inline} ->
let%bind binder = s_variable ~substs binder in
let%bind expr = s_expression ~substs expr in
ok @@ Ast_typed.Declaration_constant {binder; expr; inline}
| Declaration_type t -> ok (Ast_typed.Declaration_type t)
and s_declaration_wrap :T.declaration Location.wrap w = fun ~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%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 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)
(input: Ast_imperative.expression) : Compiler.compiled_expression result =
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%bind sugar = Compile.Of_imperative.compile_expression input in
let%bind core = Compile.Of_sugar.compile_expression sugar in