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

transpile to mini_c expressions

Browse Source
This commit is contained in:
Galfour 2019-05-20 16:17:26 +00:00
parent e48a5fde28
commit 2a091edbc0
12 changed files with 181 additions and 256 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/compiler/compiler_environment.ml
View File

@ -135,11 +135,18 @@ let select : environment -> string list -> michelson result = fun e lst ->
ok code
let clear : environment -> michelson result = fun e -> select e []
let select_env : environment -> environment -> michelson result = fun source filter ->
let lst = Environment.get_names filter in
select source lst
let select_env : environment -> environment -> michelson result = fun e e' ->
let lst = Environment.get_names e' in
select e lst
let clear : environment -> (michelson * environment) result = fun e ->
let lst = Environment.get_names e in
let%bind first_name =
trace_option (simple_error "try to clear empty env") @@
List.nth_opt lst 0 in
let%bind code = select e [ first_name ] in
let e' = Environment.select [ first_name ] e in
ok (code , e')
let pack : environment -> michelson result = fun e ->
let%bind () =
@ -276,3 +283,8 @@ let add_packed_anon : environment -> type_value -> michelson result = fun e type
in
ok code
let pop : environment -> environment result = fun e ->
match e with
| [] -> simple_fail "pop empty env"
| _ :: tl -> ok tl

95
src/compiler/compiler_program.ml
View File

@ -87,6 +87,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
let error_message () =
Format.asprintf "\n- expr: %a\n- type: %a\n" PP.expression expr PP.type_ ty
in
let i_skip = i_push_unit in
let return ?prepend_env ?end_env code =
let%bind env' =
@ -123,6 +124,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
trace (error (thunk "compiling expression") error_message) @@
match expr' with
| E_skip -> return @@ i_skip
| E_environment_capture c ->
let%bind code = Compiler_environment.pack_select env c in
return @@ code
@ -130,14 +132,26 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
let%bind (expr' , _) = translate_expression expr env in
let%bind clear = Compiler_environment.select env [] in
let%bind unpack = Compiler_environment.unpack load_env in
return ~end_env:load_env @@ seq [
return ~prepend_env:load_env @@ seq [
expr' ;
dip clear ;
unpack ;
i_skip ;
]
| E_environment_select sub_env ->
let%bind code = Compiler_environment.select_env env sub_env in
return ~end_env:sub_env code
return ~prepend_env:sub_env @@ seq [
code ;
i_skip ;
]
| E_environment_return expr -> (
let%bind (expr' , env) = translate_expression expr env in
let%bind (code , cleared_env) = Compiler_environment.clear env in
return ~end_env:cleared_env @@ seq [
expr' ;
code ;
]
)
| E_literal v ->
let%bind v = translate_value v in
let%bind t = Compiler_type.type_ ty in
@ -195,11 +209,21 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
return code
| E_sequence (a , b) ->
let%bind (a' , env_a) = translate_expression a env in
let%bind (b' , env_b) = translate_expression b env_a in
return ~prepend_env:env_b @@ seq [
let%bind env_a' = Compiler_environment.pop env_a in
let%bind (b' , env_b) = translate_expression b env_a' in
return ~end_env:env_b @@ seq [
a' ;
i_drop ;
b' ;
]
(* | E_sequence_drop (a , b) ->
* let%bind (a' , env_a) = translate_expression a env in
* let%bind (b' , env_b) = translate_expression b env_a in
* return ~end_env:env_b @@ seq [
* a' ;
* i_drop ;
* b' ;
* ] *)
| E_constant(str, lst) ->
let module L = Logger.Stateful() in
let%bind lst' =
@ -250,8 +274,9 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
return @@ i_none o'
| E_if_bool (c, a, b) -> (
let%bind (c' , env') = translate_expression c env in
let%bind (a' , _) = translate_expression a env' in
let%bind (b' , _) = translate_expression b env' in
let%bind popped = Compiler_environment.pop env' in
let%bind (a' , _) = translate_expression a popped in
let%bind (b' , _) = translate_expression b popped in
let%bind code = ok (seq [
c' ;
i_if a' b' ;
@ -259,16 +284,18 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
return code
)
| E_if_none (c, n, (ntv , s)) -> (
let%bind (c' , _env') = translate_expression c env in
let%bind (n' , _) = translate_expression n env in
let s_env = Environment.add ntv env in
let%bind (s' , _) = translate_expression s s_env in
let%bind restrict_s = Compiler_environment.select_env s_env env in
let%bind (c' , env') = translate_expression c env in
let%bind popped = Compiler_environment.pop env' in
let%bind (n' , _) = translate_expression n popped in
let s_env = Environment.add ntv popped in
let%bind (s' , s_env') = translate_expression s s_env in
let%bind popped' = Compiler_environment.pop s_env' in
let%bind restrict_s = Compiler_environment.select_env popped' popped in
let%bind code = ok (seq [
c' ;
i_if_none n' (seq [
s' ;
restrict_s ;
dip restrict_s ;
])
;
]) in
@ -298,10 +325,14 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
return code
)
| E_let_in (v, expr , body) -> (
let%bind (expr' , _) = translate_expression expr env in
let env' = Environment.add v env in
let%bind (body' , _) = translate_expression body env' in
let%bind restrict = Compiler_environment.select_env env' env in
let%bind (expr' , expr_env) = translate_expression expr env in
let%bind env' =
let%bind popped = Compiler_environment.pop expr_env in
ok @@ Environment.add v popped in
let%bind (body' , body_env) = translate_expression body env' in
let%bind restrict =
let%bind popped = Compiler_environment.pop body_env in
Compiler_environment.select_env popped env in
let%bind code = ok (seq [
expr' ;
body' ;
@ -312,6 +343,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
)
| E_assignment (name , lrs , expr) -> (
let%bind (expr' , env') = translate_expression expr env in
(* Format.printf "\nass env':%a\n" PP.environment env' ; *)
let%bind get_code = Compiler_environment.get env' name in
let modify_code =
let aux acc step = match step with
@ -333,23 +365,33 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
in
error title content in
trace error @@
return ~end_env:env @@ seq [
return ~prepend_env:env @@ seq [
i_comment "assign: start # env" ;
expr' ;
i_comment "assign: compute rhs # rhs : env" ;
get_code ;
i_swap ; modify_code ;
i_comment "assign: get name # name : rhs : env" ;
i_swap ;
i_comment "assign: swap # rhs : name : env" ;
modify_code ;
i_comment "assign: modify code # name+rhs : env" ;
set_code ;
i_comment "assign: set new # new_env" ;
i_skip ;
]
)
| E_while (expr, block) -> (
let%bind (expr' , env') = translate_expression expr env in
let%bind (block' , env'') = translate_expression block env' in
let%bind restrict_block = Compiler_environment.select_env env'' env' in
let%bind popped = Compiler_environment.pop env' in
let%bind (block' , env'') = translate_expression block popped in
let%bind restrict_block = Compiler_environment.select_env env'' popped in
return @@ seq [
expr' ;
prim ~children:[seq [
block' ;
restrict_block ;
expr']] I_LOOP ;
i_skip ;
]
)
@ -528,16 +570,12 @@ and translate_regular_block ((b, env):block) : michelson result =
let code = seq (List.rev codes) in
ok code
and translate_quote_body ({body;result} as f:anon_function) : michelson result =
let%bind body' = translate_regular_block body in
let%bind (expr , _) = translate_expression result (snd body).post_environment in
let%bind restrict = Compiler_environment.clear (snd body).post_environment in
and translate_quote_body ({result ; binder ; input} as f:anon_function) : michelson result =
let env = Environment.(add (binder , input) empty) in
let%bind (expr , _) = translate_expression result env in
let code = seq [
i_comment "function body" ;
body' ;
i_comment "function result" ;
expr ;
dip restrict ;
] in
let%bind _assert_type =
@ -547,11 +585,10 @@ and translate_quote_body ({body;result} as f:anon_function) : michelson result =
let output_stack_ty = Stack.(output_ty @: nil) in
let error_message () =
Format.asprintf
"\ncode : %a\ninput : %a\noutput : %a\nenv : %a\n"
"\ncode : %a\ninput : %a\noutput : %a\n"
Michelson.pp code
PP.type_ f.input
PP.type_ f.output
PP.environment (snd body).post_environment
in
let%bind _ =
Trace.trace_tzresult_lwt (

4
src/contracts/assign.ligo Normal file
View File

@ -0,0 +1,4 @@
function main (const i : int) : int is
begin
i := i + 1 ;
end with i

8
src/contracts/condition-simple.ligo Normal file
View File

@ -0,0 +1,8 @@
function main (const i : int) : int is
begin
if 1 = 1 then
i := 42
else
i := 0
end with i

3
src/contracts/declaration-local.ligo Normal file
View File

@ -0,0 +1,3 @@
function main (const i : int) : int is block {
const j : int = 42 ;
} with j

8
src/mini_c/PP.ml
View File

@ -64,6 +64,8 @@ and expression' ppf (e:expression') = match e with
| E_environment_capture s -> fprintf ppf "capture(%a)" (list_sep string (const " ; ")) s
| E_environment_load (expr , env) -> fprintf ppf "load %a in %a" expression expr environment env
| E_environment_select env -> fprintf ppf "select %a" environment env
| E_environment_return expr -> fprintf ppf "return %a" expression expr
| E_skip -> fprintf ppf "skip"
| E_variable v -> fprintf ppf "%s" v
| E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b
| E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst
@ -76,6 +78,7 @@ and expression' ppf (e:expression') = match e with
| E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
fprintf ppf "%a ?? %s -> %a : %s -> %a" expression c name_l expression l name_r expression r
| E_sequence (a , b) -> fprintf ppf "%a ; %a" expression a expression b
(* | E_sequence_drop (a , b) -> fprintf ppf "%a ;- %a" expression a expression b *)
| E_let_in ((name , _) , expr , body) ->
fprintf ppf "let %s = %a in %a" name expression expr expression body
| E_assignment (r , path , e) ->
@ -91,12 +94,11 @@ and expression_with_type : _ -> expression -> _ = fun ppf e ->
expression' e.content
type_ e.type_value
and function_ ppf ({binder ; input ; output ; body ; result}:anon_function) =
fprintf ppf "fun (%s:%a) : %a %a return %a"
and function_ ppf ({binder ; input ; output ; result}:anon_function) =
fprintf ppf "fun (%s:%a) : %a return %a"
binder
type_ input
type_ output
block body
expression result
and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e

27
src/mini_c/combinators.ml
View File

@ -136,25 +136,34 @@ let t_deep_closure x y z : type_value = T_deep_closure ( x , y , z )
let t_pair x y : type_value = T_pair ( x , y )
let t_union x y : type_value = T_or ( x , y )
let quote binder input output body result : anon_function =
let quote binder input output result : anon_function =
{
binder ; input ; output ;
body ; result ;
result ;
}
let basic_quote i o b : anon_function result =
let%bind (_, _e) = get_last_statement b in
let r : expression = Expression.make_tpl (E_variable "output", o) in
ok @@ quote "input" i o b r
let basic_int_quote b : anon_function result =
basic_quote t_int t_int b
let e_int expr : expression = Expression.make_tpl (expr, t_int)
let e_unit : expression = Expression.make_tpl (E_literal D_unit, t_unit)
let e_skip : expression = Expression.make_tpl (E_skip, t_unit)
let e_var_int name : expression = e_int (E_variable name)
let e_let_int v tv expr body : expression = Expression.(make_tpl (
E_let_in ((v , tv) , expr , body) ,
get_type body
))
let ez_e_sequence a b : expression = Expression.(make_tpl (E_sequence (make_tpl (a , t_unit) , b) , get_type b))
let ez_e_return e : expression = Expression.(make_tpl ((E_environment_return e) , get_type e))
let d_unit : value = D_unit
let basic_quote i o expr : anon_function result =
ok @@ quote "input" i o (ez_e_return expr)
let basic_int_quote expr : anon_function result =
basic_quote t_int t_int expr
let environment_wrap pre_environment post_environment = { pre_environment ; post_environment }
let id_environment_wrap e = environment_wrap e e

4
src/mini_c/types.ml
View File

@ -56,6 +56,8 @@ and expression' =
| E_environment_capture of selector
| E_environment_select of environment
| E_environment_load of (expression * environment)
| E_environment_return of expression
| E_skip
| E_constant of string * expression list
| E_application of expression * expression
| E_variable of var_name
@ -67,6 +69,7 @@ and expression' =
| E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression)
| E_let_in of ((var_name * type_value) * expression * expression)
| E_sequence of (expression * expression)
(* | E_sequence_drop of (expression * expression) *)
| E_assignment of (string * [`Left | `Right] list * expression)
| E_while of expression * expression
@ -98,7 +101,6 @@ and anon_function = {
binder : string ;
input : type_value ;
output : type_value ;
body : block ;
result : expression ;
}

26
src/test/compiler_tests.ml
View File

@ -11,29 +11,19 @@ let run_entry_int (e:anon_function) (n:int) : int result =
| _ -> simple_fail "result is not an int"
let identity () : unit result =
let e = basic_int_quote_env in
let s = statement (S_declaration ("output", e_var_int "input")) e in
let%bind b = block [s] in
let%bind f = basic_int_quote b in
let%bind f = basic_int_quote (e_var_int "input") in
let%bind result = run_entry_int f 42 in
let%bind _ = Assert.assert_equal_int ~msg:__LOC__ 42 result in
ok ()
let multiple_vars () : unit result =
let e = basic_int_quote_env in
(*
Statements can change the environment, and you don't want to pass the new environment manually.
[statements] deals with this and this is why those statements are parametrized over an environment.
Yes. One could do a monad. Feel free when we have the time.
*)
let ss = statements [
(fun e -> statement (S_declaration ("a", e_var_int "input")) e) ;
(fun e -> statement (S_declaration ("b", e_var_int "input")) e) ;
(fun e -> statement (S_declaration ("c", e_var_int "a")) e) ;
(fun e -> statement (S_declaration ("output", e_var_int "c")) e) ;
] e in
let%bind b = block ss in
let%bind f = basic_int_quote b in
let expr =
e_let_int "a" t_int (e_var_int "input") @@
e_let_int "b" t_int (e_var_int "input") @@
e_let_int "c" t_int (e_var_int "a") @@
e_let_int "output" t_int (e_var_int "c") @@
e_var_int "output" in
let%bind f = basic_int_quote expr in
let%bind result = run_entry_int f 42 in
let%bind _ = Assert.assert_equal_int ~msg:__LOC__ 42 result in
ok ()

20
src/test/integration_tests.ml
View File

@ -15,6 +15,11 @@ let function_ () : unit result =
let make_expect = fun n -> n in
expect_eq_n_int program "main" make_expect
let assign () : unit result =
let%bind program = type_file "./contracts/assign.ligo" in
let make_expect = fun n -> n + 1 in
expect_eq_n_int program "main" make_expect
let annotation () : unit result =
let%bind program = type_file "./contracts/annotation.ligo" in
let%bind () =
@ -311,6 +316,12 @@ let condition () : unit result =
let make_expected = fun n -> e_a_int (if n = 2 then 42 else 0) in
expect_eq_n program "main" make_input make_expected
let condition_simple () : unit result =
let%bind program = type_file "./contracts/condition-simple.ligo" in
let make_input = e_a_int in
let make_expected = fun _ -> e_a_int 42 in
expect_eq_n program "main" make_input make_expected
let loop () : unit result =
let%bind program = type_file "./contracts/loop.ligo" in
let%bind () =
@ -379,6 +390,12 @@ let declarations () : unit result =
let make_expected = fun n -> e_a_int (42 + n) in
expect_eq_n program "main" make_input make_expected
let declaration_local () : unit result =
let%bind program = type_file "./contracts/declaration-local.ligo" in
let make_input = e_a_int in
let make_expected = fun _ -> e_a_int 42 in
expect_eq_n program "main" make_input make_expected
let quote_declaration () : unit result =
let%bind program = type_file "./contracts/quote-declaration.ligo" in
let make_input = e_a_int in
@ -436,11 +453,14 @@ let guess_the_hash_mligo () : unit result =
let main = "Integration (End to End)", [
test "function" function_ ;
test "assign" assign ;
test "declaration local" declaration_local ;
test "complex function" complex_function ;
test "variant" variant ;
test "variant matching" variant_matching ;
test "tuple" tuple ;
test "record" record ;
test "condition simple" condition_simple ;
test "condition" condition ;
test "shadow" shadow ;
test "annotation" annotation ;

2
src/test/test_helpers.ml
View File

@ -20,7 +20,7 @@ let expect ?options program entry_point input expecter =
let content () = Format.asprintf "Entry_point: %s" entry_point in
error title content in
trace run_error @@
Ligo.easy_run_typed_simplified ~debug_michelson:false ?options entry_point program input in
Ligo.easy_run_typed_simplified ~debug_michelson:true ?options entry_point program input in
expecter result
let expect_eq ?options program entry_point input expected =

220
src/transpiler/transpiler.ml
View File

@ -119,107 +119,17 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -
bind_fold_list aux (ty , []) lr_path in
ok lst
(* let rec translate_block env (b:AST.block) : block result =
* let aux = fun (precs, env) instruction ->
* let%bind lst = translate_instruction env instruction in
* let env' = List.fold_left (fun _ i -> (snd i).post_environment) env lst in (\* Get last environment *\)
* ok (precs @ lst, env') in
* let%bind (instructions, env') = bind_fold_list aux ([], env) b in
* ok (instructions, environment_wrap env env')
*
* and translate_instruction (env:Environment.t) (i:AST.instruction) : statement list result =
* let return ?(env' = env) x : statement list result = ok ([x, environment_wrap env env']) in
* match i with
* | I_declaration {name;annotated_expression} ->
* let%bind expression = translate_annotated_expression annotated_expression in
* let env' = Environment.add (name, (Combinators.Expression.get_type expression)) env in
* return ~env' (S_declaration (name, expression))
* | I_assignment {name;annotated_expression} ->
* let%bind expression = translate_annotated_expression annotated_expression in
* return (S_assignment (name, expression))
* | I_patch (r, s, v) -> (
* let ty = r.type_value in
* let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result =
* fun (prev, acc) cur ->
* let%bind ty' = translate_type prev in
* match cur with
* | Access_tuple ind ->
* let%bind ty_lst = AST.Combinators.get_t_tuple prev in
* let%bind ty'_lst = bind_map_list translate_type ty_lst in
* let%bind path = tuple_access_to_lr ty' ty'_lst ind in
* let path' = List.map snd path in
* ok (List.nth ty_lst ind, acc @ path')
* | Access_record prop ->
* let%bind ty_map =
* let error =
* let title () = "accessing property on not a record" in
* let content () = Format.asprintf "%s on %a in %a"
* prop Ast_typed.PP.type_value prev Ast_typed.PP.instruction i in
* error title content
* in
* trace error @@
* AST.Combinators.get_t_record prev in
* let%bind ty'_map = bind_map_smap translate_type ty_map in
* let%bind path = record_access_to_lr ty' ty'_map prop in
* let path' = List.map snd path in
* ok (Map.String.find prop ty_map, acc @ path')
* | Access_map _k -> simple_fail "no patch for map yet"
* in
* let%bind (_, path) = bind_fold_right_list aux (ty, []) s in
* let%bind v' = translate_annotated_expression v in
* return (S_patch (r.type_name, path, v'))
* )
* | I_matching (expr, m) -> (
* let%bind expr' = translate_annotated_expression expr in
* let env' = env in
* let return s =
* ok [ (s, environment_wrap env env) ] in
* match m with
* | Match_bool {match_true ; match_false} -> (
* let%bind true_branch = translate_block env' match_true in
* let%bind false_branch = translate_block env' match_false in
* return @@ S_cond (expr', true_branch, false_branch)
* )
* | Match_option {match_none ; match_some = ((name, t), sm)} -> (
* let%bind none_branch = translate_block env' match_none in
* let%bind t' = translate_type t in
* let%bind some_branch =
* let env'' = Environment.add (name, t') env' in
* translate_block env'' sm
* in
* return @@ S_if_none (expr', none_branch, ((name, t'), some_branch))
* )
* | _ -> simple_fail "todo : match"
* )
* | I_loop (expr, body) ->
* let%bind expr' = translate_annotated_expression expr in
* let%bind body' = translate_block env body in
* return (S_while (expr', body'))
* | I_skip -> ok []
* | I_do ae -> (
* let%bind ae' = translate_annotated_expression ae in
* return @@ S_do ae'
* ) *)
let rec translate_block env (b:AST.block) : block result =
let aux = fun (precs, env) instruction ->
let%bind lst = translate_instruction env instruction in
let env' = List.fold_left (fun _ i -> (snd i).post_environment) env lst in (* Get last environment *)
ok (precs @ lst, env') in
let%bind (instructions, env') = bind_fold_list aux ([], env) b in
ok (instructions, environment_wrap env env')
and translate_block' : expression option -> AST.block -> expression result = fun expr_opt block ->
let rec translate_block : expression option -> AST.block -> expression result = fun expr_opt block ->
let aux = fun expr_opt i ->
let%bind expr = translate_instruction' i expr_opt in
let%bind expr = translate_instruction i expr_opt in
ok (Some expr) in
let%bind expr_opt = bind_fold_right_list aux expr_opt block in
let default = e_unit in
ok (Option.unopt ~default expr_opt)
and translate_instruction' : AST.instruction -> expression option -> expression result = fun i expr_opt ->
and translate_instruction : AST.instruction -> expression option -> expression result = fun i expr_opt ->
let expr =
let default = e_unit in
let default = e_skip in
Option.unopt ~default expr_opt in
let return ?(tv = expr.type_value) expr' = ok @@ Combinators.Expression.make_tpl (expr' , tv) in
let skip = ok expr in
@ -227,6 +137,11 @@ and translate_instruction' : AST.instruction -> expression option -> expression
let lhs = Expression.make_tpl (expr' , t_unit) in
let rhs = expr in
ok @@ Combinators.Expression.make_tpl (E_sequence ( lhs , rhs ) , tv) in
let return_seq_drop ?(tv = expr.type_value) expr' =
let lhs = Expression.make_tpl (expr' , t_unit) in
let rhs = expr in
(* ok @@ Combinators.Expression.make_tpl (E_sequence_drop ( lhs , rhs ) , tv) in *)
ok @@ Combinators.Expression.make_tpl (E_sequence ( lhs , rhs ) , tv) in
match i with
| I_declaration { name ; annotated_expression } ->
let%bind rhs = translate_annotated_expression annotated_expression in
@ -238,15 +153,15 @@ and translate_instruction' : AST.instruction -> expression option -> expression
let%bind expr' = translate_annotated_expression matched in
match clauses with
| Match_bool {match_true ; match_false} ->
let%bind (t , f) = bind_map_pair (translate_block' None) (match_true, match_false) in
return_seq @@ E_if_bool (expr', t, f)
let%bind (t , f) = bind_map_pair (translate_block None) (match_true, match_false) in
return_seq_drop @@ E_if_bool (expr', t, f)
| Match_option { match_none; match_some = ((name, tv), s) } ->
let%bind n = translate_block' None match_none in
let%bind n = translate_block None match_none in
let%bind (tv' , s') =
let%bind tv' = translate_type tv in
let%bind s' = translate_block' None s in
let%bind s' = translate_block None s in
ok (tv' , s') in
return_seq @@ E_if_none (expr' , n , ((name , tv') , s'))
return_seq_drop @@ E_if_none (expr' , n , ((name , tv') , s'))
| Match_variant (lst , variant) -> (
let%bind tree = tree_of_sum variant in
let%bind tree' = match tree with
@ -272,7 +187,7 @@ and translate_instruction' : AST.instruction -> expression option -> expression
let%bind ((_ , name) , body) =
trace_option (simple_error "not supposed to happen here: missing match clause") @@
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
let%bind body' = translate_block' None body in
let%bind body' = translate_block None body in
return @@ E_let_in ((name , tv) , top , body')
)
| ((`Node (a , b)) , tv) ->
@ -288,7 +203,7 @@ and translate_instruction' : AST.instruction -> expression option -> expression
let%bind e = aux (((Expression.make (E_variable "right") b_ty))) b in
ok (b_var , e)
in
return @@ E_if_left (top , a' , b')
return_seq_drop @@ E_if_left (top , a' , b')
in
aux expr' tree''
)
@ -297,7 +212,7 @@ and translate_instruction' : AST.instruction -> expression option -> expression
)
| I_loop (condition , body) ->
let%bind condition' = translate_annotated_expression condition in
let%bind body' = translate_block' None body in
let%bind body' = translate_block None body in
return_seq @@ E_while (condition' , body')
| I_do action ->
let%bind action' = translate_annotated_expression action in
@ -336,80 +251,6 @@ and translate_instruction' : AST.instruction -> expression option -> expression
return_seq (E_assignment (typed_name.type_name, path, expr'))
)
and translate_instruction (env:Environment.t) (i:AST.instruction) : statement list result =
let return ?(env' = env) x : statement list result = ok ([x, environment_wrap env env']) in
match i with
| I_declaration {name;annotated_expression} ->
let%bind expression = translate_annotated_expression annotated_expression in
let env' = Environment.add (name, (Combinators.Expression.get_type expression)) env in
return ~env' (S_declaration (name, expression))
| I_assignment {name;annotated_expression} ->
let%bind expression = translate_annotated_expression annotated_expression in
return (S_assignment (name, expression))
| I_patch (r, s, v) -> (
let ty = r.type_value in
let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result =
fun (prev, acc) cur ->
let%bind ty' = translate_type prev in
match cur with
| Access_tuple ind ->
let%bind ty_lst = AST.Combinators.get_t_tuple prev in
let%bind ty'_lst = bind_map_list translate_type ty_lst in
let%bind path = tuple_access_to_lr ty' ty'_lst ind in
let path' = List.map snd path in
ok (List.nth ty_lst ind, acc @ path')
| Access_record prop ->
let%bind ty_map =
let error =
let title () = "accessing property on not a record" in
let content () = Format.asprintf "%s on %a in %a"
prop Ast_typed.PP.type_value prev Ast_typed.PP.instruction i in
error title content
in
trace error @@
AST.Combinators.get_t_record prev in
let%bind ty'_map = bind_map_smap translate_type ty_map in
let%bind path = record_access_to_lr ty' ty'_map prop in
let path' = List.map snd path in
ok (Map.String.find prop ty_map, acc @ path')
| Access_map _k -> simple_fail "no patch for map yet"
in
let%bind (_, path) = bind_fold_right_list aux (ty, []) s in
let%bind v' = translate_annotated_expression v in
return (S_patch (r.type_name, path, v'))
)
| I_matching (expr, m) -> (
let%bind expr' = translate_annotated_expression expr in
let env' = env in
let return s =
ok [ (s, environment_wrap env env) ] in
match m with
| Match_bool {match_true ; match_false} -> (
let%bind true_branch = translate_block env' match_true in
let%bind false_branch = translate_block env' match_false in
return @@ S_cond (expr', true_branch, false_branch)
)
| Match_option {match_none ; match_some = ((name, t), sm)} -> (
let%bind none_branch = translate_block env' match_none in
let%bind t' = translate_type t in
let%bind some_branch =
let env'' = Environment.add (name, t') env' in
translate_block env'' sm
in
return @@ S_if_none (expr', none_branch, ((name, t'), some_branch))
)
| _ -> simple_fail "todo : match"
)
| I_loop (expr, body) ->
let%bind expr' = translate_annotated_expression expr in
let%bind body' = translate_block env body in
return (S_while (expr', body'))
| I_skip -> ok []
| I_do ae -> (
let%bind ae' = translate_annotated_expression ae in
return @@ S_do ae'
)
and translate_literal : AST.literal -> value = fun l -> match l with
| Literal_bool b -> D_bool b
| Literal_int n -> D_int n
@ -701,17 +542,16 @@ and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.express
let init_env = Environment.(add (binder , raw_input) c_env) in
let input = Environment.closure_representation init_env in
let%bind output = translate_type output_type in
let%bind (statements , body_env) = translate_block init_env body in
let body =
let load_env = Environment.(add ("closure_arg" , input) empty) in
let load_expr = Expression.make_tpl (E_variable "closure_arg" , input) in
let load_st = Mini_c.statement (S_environment_load (load_expr , init_env)) load_env in
let statements' = load_st :: statements in
(statements' , body_env)
in
let%bind result = translate_annotated_expression result in
let%bind result =
let%bind result_expression = translate_annotated_expression result in
let%bind body_expression = translate_block (Some result_expression) body in
let%bind body_wrap_expression =
let load_expr = Expression.make_tpl (E_variable binder , input) in
ok @@ ez_e_return @@ ez_e_sequence (E_environment_load (load_expr , init_env)) body_expression
in
ok body_wrap_expression in
let tv = Mini_c.t_function input output in
let f_literal = D_function { binder ; input ; output ; body ; result } in
let f_literal = D_function { binder ; input ; output ; result } in
let expr = Expression.make_tpl (E_literal f_literal , tv) in
ok (expr , raw_input , output) in
let%bind c_expr =
@ -731,16 +571,14 @@ and translate_lambda env l =
let%bind result =
match (body_fvs, result_fvs) with
| [] , [] -> (
let%bind empty_env =
let%bind input = translate_type input_type in
ok Environment.(add (binder, input) empty) in
let%bind body' = translate_block empty_env body in
let%bind result' = translate_annotated_expression result in
let%bind body_expression = translate_block (Some result') body in
let body_wrapped = ez_e_return body_expression in
trace (simple_error "translate quote") @@
let%bind input = translate_type input_type in
let%bind output = translate_type output_type in
let tv = Combinators.t_function input output in
let content = D_function {binder;input;output;body=body';result=result'} in
let content = D_function {binder;input;output;result=body_wrapped} in
ok @@ Combinators.Expression.make_tpl (E_literal content, tv)
)
| _ -> (