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

fix order

Browse Source
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-04-08 18:00:03 +02:00
parent e6cba7c34f
commit c46210b656
4 changed files with 150 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/passes/2-concrete_to_imperative/cameligo.ml
View File

@ -634,15 +634,15 @@ let rec compile_expression :
| ESeq s -> ( | ESeq s -> (
let (s , loc) = r_split s in let (s , loc) = r_split s in
let items : Raw.expr list = pseq_to_list s.elements in let items : Raw.expr list = pseq_to_list s.elements in
(match items with (match List.rev items with
[] -> return @@ e_skip ~loc () [] -> return @@ e_skip ~loc ()
| expr::more -> | expr::more ->
let expr' = compile_expression expr in let expr' = compile_expression expr in
let apply (e1: Raw.expr) (e2: expression Trace.result) = let apply e1 e2 =
let%bind a = compile_expression e1 in let%bind a = compile_expression e2 in
let%bind e2' = e2 in let%bind e1' = e1 in
return @@ e_sequence a e2' return @@ e_sequence a e1'
in List.fold_right apply more expr') in List.fold_left apply expr' more)
) )
| ECond c -> ( | ECond c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in

229
src/passes/4-imperative_to_sugar/imperative_to_sugar.ml
View File

@ -102,12 +102,14 @@ and store_mutable_variable (free_vars : I.expression_variable list) =
let aux var = (O.Label (Var.to_name var), O.e_variable var) in let aux var = (O.Label (Var.to_name var), O.e_variable var) in
O.e_record @@ O.LMap.of_list (List.map aux free_vars) O.e_record @@ O.LMap.of_list (List.map aux free_vars)
and restore_mutable_variable (expr : O.expression->O.expression_content) (free_vars : O.expression_variable list) (env : O.expression_variable) = and restore_mutable_variable (expr : O.expression->O.expression) (free_vars : O.expression_variable list) (env : O.expression_variable) =
let aux (f: O.expression -> O.expression) (ev: O.expression_variable) = let aux (f: O.expression -> O.expression) (ev: O.expression_variable) =
fun expr -> f (O.e_let_in (ev,None) true false (O.e_record_accessor (O.e_variable env) (Label (Var.to_name ev))) expr) fun expr -> f (O.e_let_in (ev,None) true false (O.e_record_accessor (O.e_variable env) (Label (Var.to_name ev))) expr)
in in
let ef = List.fold_left aux (fun e -> e) free_vars in let ef = List.fold_left aux (fun e -> e) free_vars in
expr (ef (O.e_skip ())) fun e -> match e with
| None -> expr (ef (O.e_skip ()))
| Some e -> expr (ef e)
let rec compile_type_expression : I.type_expression -> O.type_expression result = let rec compile_type_expression : I.type_expression -> O.type_expression result =
@ -189,36 +191,45 @@ and compile_type_operator : I.type_operator -> O.type_operator result =
let rec compile_expression : I.expression -> O.expression result = let rec compile_expression : I.expression -> O.expression result =
fun e -> fun e ->
let return expr = ok @@ O.make_e ~loc:e.location expr in let%bind e = compile_expression' e in
ok @@ e None
and compile_expression' : I.expression -> (O.expression option -> O.expression) result =
fun e ->
let return expr = ok @@ function
| None -> expr
| Some e -> O.e_sequence expr e
in
let loc = e.location in
match e.expression_content with match e.expression_content with
| I.E_literal literal -> return @@ O.E_literal literal | I.E_literal literal -> return @@ O.e_literal ~loc literal
| I.E_constant {cons_name;arguments} -> | I.E_constant {cons_name;arguments} ->
let%bind arguments = bind_map_list compile_expression arguments in let%bind arguments = bind_map_list compile_expression arguments in
return @@ O.E_constant {cons_name;arguments} return @@ O.e_constant ~loc cons_name arguments
| I.E_variable name -> return @@ O.E_variable name | I.E_variable name -> return @@ O.e_variable ~loc name
| I.E_application {lamb;args} -> | I.E_application {lamb;args} ->
let%bind lamb = compile_expression lamb in let%bind lamb = compile_expression lamb in
let%bind args = compile_expression args in let%bind args = compile_expression args in
return @@ O.E_application {lamb;args} return @@ O.e_application ~loc lamb args
| I.E_lambda lambda -> | I.E_lambda lambda ->
let%bind lambda = compile_lambda lambda in let%bind lambda = compile_lambda lambda in
return @@ O.E_lambda lambda return @@ O.make_e ~loc (O.E_lambda lambda)
| I.E_recursive {fun_name;fun_type;lambda} -> | I.E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = compile_type_expression fun_type in let%bind fun_type = compile_type_expression fun_type in
let%bind lambda = compile_lambda lambda in let%bind lambda = compile_lambda lambda in
return @@ O.E_recursive {fun_name;fun_type;lambda} return @@ O.e_recursive ~loc fun_name fun_type lambda
| I.E_let_in {let_binder;inline;rhs;let_result} -> | I.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
let%bind rhs = compile_expression rhs in let%bind rhs = compile_expression rhs in
let%bind let_result = compile_expression let_result in let%bind let_result = compile_expression let_result in
return @@ O.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result} return @@ O.e_let_in ~loc (binder,ty_opt) false inline rhs let_result
| I.E_constructor {constructor;element} -> | I.E_constructor {constructor;element} ->
let%bind element = compile_expression element in let%bind element = compile_expression element in
return @@ O.E_constructor {constructor;element} return @@ O.e_constructor ~loc constructor element
| I.E_matching m -> | I.E_matching m ->
let%bind m = compile_matching m in let%bind m = compile_matching m in
return @@ m ok @@ m
| I.E_record record -> | I.E_record record ->
let record = I.LMap.to_kv_list record in let record = I.LMap.to_kv_list record in
let%bind record = let%bind record =
@ -227,39 +238,39 @@ let rec compile_expression : I.expression -> O.expression result =
ok @@ (k,v) ok @@ (k,v)
) record ) record
in in
return @@ O.E_record (O.LMap.of_list record) return @@ O.e_record ~loc (O.LMap.of_list record)
| I.E_record_accessor {record;path} -> | I.E_record_accessor {record;path} ->
let%bind record = compile_expression record in let%bind record = compile_expression record in
return @@ O.E_record_accessor {record;path} return @@ O.e_record_accessor ~loc record path
| I.E_record_update {record;path;update} -> | I.E_record_update {record;path;update} ->
let%bind record = compile_expression record in let%bind record = compile_expression record in
let%bind update = compile_expression update in let%bind update = compile_expression update in
return @@ O.E_record_update {record;path;update} return @@ O.e_record_update ~loc record path update
| I.E_map map -> | I.E_map map ->
let%bind map = bind_map_list ( let%bind map = bind_map_list (
bind_map_pair compile_expression bind_map_pair compile_expression
) map ) map
in in
return @@ O.E_map map return @@ O.e_map ~loc map
| I.E_big_map big_map -> | I.E_big_map big_map ->
let%bind big_map = bind_map_list ( let%bind big_map = bind_map_list (
bind_map_pair compile_expression bind_map_pair compile_expression
) big_map ) big_map
in in
return @@ O.E_big_map big_map return @@ O.e_big_map ~loc big_map
| I.E_list lst -> | I.E_list lst ->
let%bind lst = bind_map_list compile_expression lst in let%bind lst = bind_map_list compile_expression lst in
return @@ O.E_list lst return @@ O.e_list ~loc lst
| I.E_set set -> | I.E_set set ->
let%bind set = bind_map_list compile_expression set in let%bind set = bind_map_list compile_expression set in
return @@ O.E_set set return @@ O.e_set ~loc set
| I.E_look_up look_up -> | I.E_look_up look_up ->
let%bind look_up = bind_map_pair compile_expression look_up in let%bind (a,b) = bind_map_pair compile_expression look_up in
return @@ O.E_look_up look_up return @@ O.e_look_up ~loc a b
| I.E_ascription {anno_expr; type_annotation} -> | I.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = compile_expression anno_expr in let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = compile_type_expression type_annotation in let%bind type_annotation = compile_type_expression type_annotation in
return @@ O.E_ascription {anno_expr; type_annotation} return @@ O.e_annotation ~loc anno_expr type_annotation
| I.E_cond {condition;then_clause;else_clause} -> | I.E_cond {condition;then_clause;else_clause} ->
let%bind condition = compile_expression condition in let%bind condition = compile_expression condition in
let%bind then_clause' = compile_expression then_clause in let%bind then_clause' = compile_expression then_clause in
@ -274,43 +285,32 @@ let rec compile_expression : I.expression -> O.expression result =
if (List.length free_vars != 0) then if (List.length free_vars != 0) then
let cond_expr = O.e_cond condition then_clause else_clause in let cond_expr = O.e_cond condition then_clause else_clause in
let return_expr = fun expr -> let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
let_result=O.e_let_in (env,None) false false cond_expr @@ O.e_let_in (env,None) false false cond_expr @@
expr expr
}
in in
return @@ restore_mutable_variable return_expr free_vars env ok @@ restore_mutable_variable return_expr free_vars env
else else
return @@ O.E_cond {condition; then_clause=then_clause'; else_clause=else_clause'} return @@ O.e_cond ~loc condition then_clause' else_clause'
| I.E_sequence {expr1; expr2} -> | I.E_sequence {expr1; expr2} ->
let%bind expr1 = compile_expression expr1 in let%bind expr1 = compile_expression' expr1 in
let%bind expr2 = compile_expression expr2 in let%bind expr2 = compile_expression' expr2 in
ok @@ add_to_end expr1 expr2 ok @@ fun e -> (match e with
| I.E_skip -> return @@ O.E_skip | None -> expr1 (Some (expr2 None))
| Some e -> expr1 (Some (expr2 (Some e)))
)
| I.E_skip -> return @@ O.e_skip ~loc ()
| I.E_tuple tuple -> | I.E_tuple tuple ->
let%bind tuple = bind_map_list compile_expression tuple in let%bind tuple = bind_map_list compile_expression tuple in
return @@ O.E_tuple (tuple) return @@ O.e_tuple ~loc tuple
| I.E_tuple_accessor {tuple;path} -> | I.E_tuple_accessor {tuple;path} ->
let%bind tuple = compile_expression tuple in let%bind tuple = compile_expression tuple in
return @@ O.E_tuple_accessor {tuple;path} return @@ O.e_tuple_accessor ~loc tuple path
| I.E_tuple_update {tuple;path;update} -> | I.E_tuple_update {tuple;path;update} ->
let%bind tuple = compile_expression tuple in let%bind tuple = compile_expression tuple in
let%bind update = compile_expression update in let%bind update = compile_expression update in
return @@ O.E_tuple_update {tuple;path;update} return @@ O.e_tuple_update ~loc tuple path update
| I.E_assign ass -> | I.E_assign {variable; access_path; expression} ->
let%bind content = compile_assign ass @@ O.e_skip () in
return @@ content
| I.E_for f ->
let%bind f = compile_for f in
return @@ f
| I.E_for_each fe ->
let%bind fe = compile_for_each fe in
return @@ fe
| I.E_while w ->
let%bind w = compile_while w in
return @@ w
and compile_assign {variable; access_path; expression} expr =
let accessor ?loc s a = let accessor ?loc s a =
match a with match a with
I.Access_tuple _i -> failwith "adding tuple soon" I.Access_tuple _i -> failwith "adding tuple soon"
@ -338,7 +338,20 @@ and compile_assign {variable; access_path; expression} expr =
let%bind (_,rhs) = bind_fold_list aux (O.e_variable variable, fun e -> ok @@ e) access_path in let%bind (_,rhs) = bind_fold_list aux (O.e_variable variable, fun e -> ok @@ e) access_path in
let%bind expression = compile_expression expression in let%bind expression = compile_expression expression in
let%bind rhs = rhs @@ expression in let%bind rhs = rhs @@ expression in
ok @@ O.E_let_in {let_binder=(variable,None); mut=true; rhs; let_result=expr;inline = false} ok @@ fun expr -> (match expr with
| None -> O.e_let_in ~loc (variable,None) true false rhs (O.e_skip ())
| Some e -> O.e_let_in ~loc (variable, None) true false rhs e
)
| I.E_for f ->
let%bind f = compile_for f in
ok @@ f
| I.E_for_each fe ->
let%bind fe = compile_for_each fe in
ok @@ fe
| I.E_while w ->
let%bind w = compile_while w in
ok @@ w
and compile_lambda : I.lambda -> O.lambda result = and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}-> fun {binder;input_type;output_type;result}->
@ -347,8 +360,12 @@ and compile_lambda : I.lambda -> O.lambda result =
let%bind result = compile_expression result in let%bind result = compile_expression result in
ok @@ O.{binder;input_type;output_type;result} ok @@ O.{binder;input_type;output_type;result}
and compile_matching : I.matching -> O.expression_content result = and compile_matching : I.matching -> (O.expression option -> O.expression) result =
fun {matchee;cases} -> fun {matchee;cases} ->
let return expr = ok @@ function
| None -> expr
| Some e -> O.e_sequence expr e
in
let%bind matchee = compile_expression matchee in let%bind matchee = compile_expression matchee in
match cases with match cases with
| I.Match_bool {match_true;match_false} -> | I.Match_bool {match_true;match_false} ->
@ -364,14 +381,13 @@ and compile_matching : I.matching -> O.expression_content result =
if (List.length free_vars != 0) then if (List.length free_vars != 0) then
let match_expr = O.e_matching matchee (O.Match_bool {match_true; match_false}) in let match_expr = O.e_matching matchee (O.Match_bool {match_true; match_false}) in
let return_expr = fun expr -> let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
let_result=O.e_let_in (env,None) false false match_expr @@ O.e_let_in (env,None) false false match_expr @@
expr expr
}
in in
ok @@ restore_mutable_variable return_expr free_vars env ok @@ restore_mutable_variable return_expr free_vars env
else else
ok @@ O.E_matching {matchee;cases=O.Match_bool {match_true=match_true';match_false=match_false'}} return @@ O.e_matching matchee @@ O.Match_bool {match_true=match_true';match_false=match_false'}
| I.Match_option {match_none;match_some} -> | I.Match_option {match_none;match_some} ->
let%bind match_none' = compile_expression match_none in let%bind match_none' = compile_expression match_none in
let (n,expr,tv) = match_some in let (n,expr,tv) = match_some in
@ -385,14 +401,13 @@ and compile_matching : I.matching -> O.expression_content result =
if (List.length free_vars != 0) then if (List.length free_vars != 0) then
let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr,tv)}) in let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr,tv)}) in
let return_expr = fun expr -> let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
let_result=O.e_let_in (env,None) false false match_expr @@ O.e_let_in (env,None) false false match_expr @@
expr expr
}
in in
ok @@ restore_mutable_variable return_expr free_vars env ok @@ restore_mutable_variable return_expr free_vars env
else else
ok @@ O.E_matching {matchee; cases=O.Match_option {match_none=match_none'; match_some=(n,expr',tv)}} return @@ O.e_matching matchee @@ O.Match_option {match_none=match_none'; match_some=(n,expr',tv)}
| I.Match_list {match_nil;match_cons} -> | I.Match_list {match_nil;match_cons} ->
let%bind match_nil' = compile_expression match_nil in let%bind match_nil' = compile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in let (hd,tl,expr,tv) = match_cons in
@ -406,17 +421,16 @@ and compile_matching : I.matching -> O.expression_content result =
if (List.length free_vars != 0) then if (List.length free_vars != 0) then
let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}) in let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}) in
let return_expr = fun expr -> let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
let_result=O.e_let_in (env,None) false false match_expr @@ O.e_let_in (env,None) false false match_expr @@
expr expr
}
in in
ok @@ restore_mutable_variable return_expr free_vars env ok @@ restore_mutable_variable return_expr free_vars env
else else
ok @@ O.E_matching {matchee;cases=O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)}} return @@ O.e_matching matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)}
| I.Match_tuple ((lst,expr), tv) -> | I.Match_tuple ((lst,expr), tv) ->
let%bind expr = compile_expression expr in let%bind expr = compile_expression expr in
ok @@ O.E_matching {matchee; cases=O.Match_tuple ((lst,expr), tv)} return @@ O.e_matching matchee @@ O.Match_tuple ((lst,expr), tv)
| I.Match_variant (lst,tv) -> | I.Match_variant (lst,tv) ->
let env = Var.fresh () in let env = Var.fresh () in
let aux fv ((c,n),expr) = let aux fv ((c,n),expr) =
@ -429,15 +443,14 @@ and compile_matching : I.matching -> O.expression_content result =
let free_vars = List.sort_uniq Var.compare @@ List.concat fv in let free_vars = List.sort_uniq Var.compare @@ List.concat fv in
if (List.length free_vars == 0) then ( if (List.length free_vars == 0) then (
let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in
ok @@ O.E_matching{matchee; cases=O.Match_variant (cases,tv)} return @@ O.e_matching matchee @@ O.Match_variant (cases,tv)
) else ( ) else (
let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in
let match_expr = O.e_matching matchee @@ O.Match_variant (cases,tv) in let match_expr = O.e_matching matchee @@ O.Match_variant (cases,tv) in
let return_expr = fun expr -> let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false; rhs=(store_mutable_variable free_vars); O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
let_result=O.e_let_in (env,None) false false match_expr @@ O.e_let_in (env,None) false false match_expr @@
expr expr
}
in in
ok @@ restore_mutable_variable return_expr free_vars env ok @@ restore_mutable_variable return_expr free_vars env
) )
@ -469,11 +482,10 @@ and compile_while I.{condition;body} =
let loop = O.e_constant C_FOLD_WHILE [aux_func; O.e_variable env_rec] in let loop = O.e_constant C_FOLD_WHILE [aux_func; O.e_variable env_rec] in
let let_binder = (env_rec,None) in let let_binder = (env_rec,None) in
let return_expr = fun expr -> let return_expr = fun expr ->
O.E_let_in {let_binder; mut=false; inline=false; rhs=init_rec; let_result= O.e_let_in let_binder false false init_rec @@
O.e_let_in let_binder false false loop @@ O.e_let_in let_binder false false loop @@
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label"0")) @@ O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label"0")) @@
expr expr
}
in in
ok @@ restore_mutable_variable return_expr captured_name_list env_rec ok @@ restore_mutable_variable return_expr captured_name_list env_rec
@ -515,12 +527,11 @@ and compile_for I.{binder;start;final;increment;body} =
let%bind start = compile_expression start in let%bind start = compile_expression start in
let let_binder = (env_rec,None) in let let_binder = (env_rec,None) in
let return_expr = fun expr -> let return_expr = fun expr ->
O.E_let_in {let_binder=(binder, Some (O.t_int ()));mut=false; inline=false;rhs=start;let_result= O.e_let_in (binder, Some (O.t_int ())) false false start @@
O.e_let_in let_binder false false init_rec @@ O.e_let_in let_binder false false init_rec @@
O.e_let_in let_binder false false loop @@ O.e_let_in let_binder false false loop @@
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label "0")) @@ O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label "0")) @@
expr expr
}
in in
ok @@ restore_mutable_variable return_expr captured_name_list env_rec ok @@ restore_mutable_variable return_expr captured_name_list env_rec
@ -555,10 +566,10 @@ and compile_for_each I.{binder;collection;collection_type; body} =
| Map -> ok @@ O.C_MAP_FOLD | Set -> ok @@ O.C_SET_FOLD | List -> ok @@ O.C_LIST_FOLD | Map -> ok @@ O.C_MAP_FOLD | Set -> ok @@ O.C_SET_FOLD | List -> ok @@ O.C_LIST_FOLD
in in
let fold = fun expr -> let fold = fun expr ->
O.E_let_in {let_binder=(env,None);mut=false; inline=false;rhs=(O.e_constant op_name [lambda; collect ; init_record]); O.e_let_in (env,None) false false (O.e_constant op_name [lambda; collect ; init_record]) expr
let_result=expr;}
in in
ok @@ restore_mutable_variable fold free_vars env ok @@ restore_mutable_variable fold free_vars env
let compile_declaration : I.declaration Location.wrap -> _ = let compile_declaration : I.declaration Location.wrap -> _ =
fun {wrap_content=declaration;location} -> fun {wrap_content=declaration;location} ->
let return decl = ok @@ Location.wrap ~loc:location decl in let return decl = ok @@ Location.wrap ~loc:location decl in
@ -639,18 +650,18 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
ok @@ I.TC_arrow (i,o) ok @@ I.TC_arrow (i,o)
let rec uncompile_expression : O.expression -> I.expression result = let rec uncompile_expression' : O.expression -> I.expression result =
fun e -> fun e ->
let return expr = ok @@ I.make_e ~loc:e.location expr in let return expr = ok @@ I.make_e ~loc:e.location expr in
match e.expression_content with match e.expression_content with
O.E_literal lit -> return @@ I.E_literal lit O.E_literal lit -> return @@ I.E_literal lit
| O.E_constant {cons_name;arguments} -> | O.E_constant {cons_name;arguments} ->
let%bind arguments = bind_map_list uncompile_expression arguments in let%bind arguments = bind_map_list uncompile_expression' arguments in
return @@ I.E_constant {cons_name;arguments} return @@ I.E_constant {cons_name;arguments}
| O.E_variable name -> return @@ I.E_variable name | O.E_variable name -> return @@ I.E_variable name
| O.E_application {lamb; args} -> | O.E_application {lamb; args} ->
let%bind lamb = uncompile_expression lamb in let%bind lamb = uncompile_expression' lamb in
let%bind args = uncompile_expression args in let%bind args = uncompile_expression' args in
return @@ I.E_application {lamb; args} return @@ I.E_application {lamb; args}
| O.E_lambda lambda -> | O.E_lambda lambda ->
let%bind lambda = uncompile_lambda lambda in let%bind lambda = uncompile_lambda lambda in
@ -662,75 +673,75 @@ let rec uncompile_expression : O.expression -> I.expression result =
| O.E_let_in {let_binder;inline;rhs;let_result} -> | O.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
let%bind rhs = uncompile_expression rhs in let%bind rhs = uncompile_expression' rhs in
let%bind let_result = uncompile_expression let_result in let%bind let_result = uncompile_expression' let_result in
return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
| O.E_constructor {constructor;element} -> | O.E_constructor {constructor;element} ->
let%bind element = uncompile_expression element in let%bind element = uncompile_expression' element in
return @@ I.E_constructor {constructor;element} return @@ I.E_constructor {constructor;element}
| O.E_matching {matchee; cases} -> | O.E_matching {matchee; cases} ->
let%bind matchee = uncompile_expression matchee in let%bind matchee = uncompile_expression' matchee in
let%bind cases = uncompile_matching cases in let%bind cases = uncompile_matching cases in
return @@ I.E_matching {matchee;cases} return @@ I.E_matching {matchee;cases}
| O.E_record record -> | O.E_record record ->
let record = I.LMap.to_kv_list record in let record = I.LMap.to_kv_list record in
let%bind record = let%bind record =
bind_map_list (fun (k,v) -> bind_map_list (fun (k,v) ->
let%bind v = uncompile_expression v in let%bind v = uncompile_expression' v in
ok @@ (k,v) ok @@ (k,v)
) record ) record
in in
return @@ I.E_record (O.LMap.of_list record) return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {record;path} -> | O.E_record_accessor {record;path} ->
let%bind record = uncompile_expression record in let%bind record = uncompile_expression' record in
return @@ I.E_record_accessor {record;path} return @@ I.E_record_accessor {record;path}
| O.E_record_update {record;path;update} -> | O.E_record_update {record;path;update} ->
let%bind record = uncompile_expression record in let%bind record = uncompile_expression' record in
let%bind update = uncompile_expression update in let%bind update = uncompile_expression' update in
return @@ I.E_record_update {record;path;update} return @@ I.E_record_update {record;path;update}
| O.E_tuple tuple -> | O.E_tuple tuple ->
let%bind tuple = bind_map_list uncompile_expression tuple in let%bind tuple = bind_map_list uncompile_expression' tuple in
return @@ I.E_tuple tuple return @@ I.E_tuple tuple
| O.E_tuple_accessor {tuple;path} -> | O.E_tuple_accessor {tuple;path} ->
let%bind tuple = uncompile_expression tuple in let%bind tuple = uncompile_expression' tuple in
return @@ I.E_tuple_accessor {tuple;path} return @@ I.E_tuple_accessor {tuple;path}
| O.E_tuple_update {tuple;path;update} -> | O.E_tuple_update {tuple;path;update} ->
let%bind tuple = uncompile_expression tuple in let%bind tuple = uncompile_expression' tuple in
let%bind update = uncompile_expression update in let%bind update = uncompile_expression' update in
return @@ I.E_tuple_update {tuple;path;update} return @@ I.E_tuple_update {tuple;path;update}
| O.E_map map -> | O.E_map map ->
let%bind map = bind_map_list ( let%bind map = bind_map_list (
bind_map_pair uncompile_expression bind_map_pair uncompile_expression'
) map ) map
in in
return @@ I.E_map map return @@ I.E_map map
| O.E_big_map big_map -> | O.E_big_map big_map ->
let%bind big_map = bind_map_list ( let%bind big_map = bind_map_list (
bind_map_pair uncompile_expression bind_map_pair uncompile_expression'
) big_map ) big_map
in in
return @@ I.E_big_map big_map return @@ I.E_big_map big_map
| O.E_list lst -> | O.E_list lst ->
let%bind lst = bind_map_list uncompile_expression lst in let%bind lst = bind_map_list uncompile_expression' lst in
return @@ I.E_list lst return @@ I.E_list lst
| O.E_set set -> | O.E_set set ->
let%bind set = bind_map_list uncompile_expression set in let%bind set = bind_map_list uncompile_expression' set in
return @@ I.E_set set return @@ I.E_set set
| O.E_look_up look_up -> | O.E_look_up look_up ->
let%bind look_up = bind_map_pair uncompile_expression look_up in let%bind look_up = bind_map_pair uncompile_expression' look_up in
return @@ I.E_look_up look_up return @@ I.E_look_up look_up
| O.E_ascription {anno_expr; type_annotation} -> | O.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = uncompile_expression anno_expr in let%bind anno_expr = uncompile_expression' anno_expr in
let%bind type_annotation = uncompile_type_expression type_annotation in let%bind type_annotation = uncompile_type_expression type_annotation in
return @@ I.E_ascription {anno_expr; type_annotation} return @@ I.E_ascription {anno_expr; type_annotation}
| O.E_cond {condition;then_clause;else_clause} -> | O.E_cond {condition;then_clause;else_clause} ->
let%bind condition = uncompile_expression condition in let%bind condition = uncompile_expression' condition in
let%bind then_clause = uncompile_expression then_clause in let%bind then_clause = uncompile_expression' then_clause in
let%bind else_clause = uncompile_expression else_clause in let%bind else_clause = uncompile_expression' else_clause in
return @@ I.E_cond {condition; then_clause; else_clause} return @@ I.E_cond {condition; then_clause; else_clause}
| O.E_sequence {expr1; expr2} -> | O.E_sequence {expr1; expr2} ->
let%bind expr1 = uncompile_expression expr1 in let%bind expr1 = uncompile_expression' expr1 in
let%bind expr2 = uncompile_expression expr2 in let%bind expr2 = uncompile_expression' expr2 in
return @@ I.E_sequence {expr1; expr2} return @@ I.E_sequence {expr1; expr2}
| O.E_skip -> return @@ I.E_skip | O.E_skip -> return @@ I.E_skip
@ -738,32 +749,32 @@ and uncompile_lambda : O.lambda -> I.lambda result =
fun {binder;input_type;output_type;result}-> fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option uncompile_type_expression input_type in let%bind input_type = bind_map_option uncompile_type_expression input_type in
let%bind output_type = bind_map_option uncompile_type_expression output_type in let%bind output_type = bind_map_option uncompile_type_expression output_type in
let%bind result = uncompile_expression result in let%bind result = uncompile_expression' result in
ok @@ I.{binder;input_type;output_type;result} ok @@ I.{binder;input_type;output_type;result}
and uncompile_matching : O.matching_expr -> I.matching_expr result = and uncompile_matching : O.matching_expr -> I.matching_expr result =
fun m -> fun m ->
match m with match m with
| O.Match_bool {match_true;match_false} -> | O.Match_bool {match_true;match_false} ->
let%bind match_true = uncompile_expression match_true in let%bind match_true = uncompile_expression' match_true in
let%bind match_false = uncompile_expression match_false in let%bind match_false = uncompile_expression' match_false in
ok @@ I.Match_bool {match_true;match_false} ok @@ I.Match_bool {match_true;match_false}
| O.Match_list {match_nil;match_cons} -> | O.Match_list {match_nil;match_cons} ->
let%bind match_nil = uncompile_expression match_nil in let%bind match_nil = uncompile_expression' match_nil in
let (hd,tl,expr,tv) = match_cons in let (hd,tl,expr,tv) = match_cons in
let%bind expr = uncompile_expression expr in let%bind expr = uncompile_expression' expr in
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)} ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
| O.Match_option {match_none;match_some} -> | O.Match_option {match_none;match_some} ->
let%bind match_none = uncompile_expression match_none in let%bind match_none = uncompile_expression' match_none in
let (n,expr,tv) = match_some in let (n,expr,tv) = match_some in
let%bind expr = uncompile_expression expr in let%bind expr = uncompile_expression' expr in
ok @@ I.Match_option {match_none; match_some=(n,expr,tv)} ok @@ I.Match_option {match_none; match_some=(n,expr,tv)}
| O.Match_tuple ((lst,expr), tv) -> | O.Match_tuple ((lst,expr), tv) ->
let%bind expr = uncompile_expression expr in let%bind expr = uncompile_expression' expr in
ok @@ O.Match_tuple ((lst,expr), tv) ok @@ O.Match_tuple ((lst,expr), tv)
| O.Match_variant (lst,tv) -> | O.Match_variant (lst,tv) ->
let%bind lst = bind_map_list ( let%bind lst = bind_map_list (
fun ((c,n),expr) -> fun ((c,n),expr) ->
let%bind expr = uncompile_expression expr in let%bind expr = uncompile_expression' expr in
ok @@ ((c,n),expr) ok @@ ((c,n),expr)
) lst ) lst
in in

2
src/stages/2-ast_sugar/combinators.ml
View File

@ -118,7 +118,7 @@ let e_lambda ?loc binder input_type output_type result : expression = make_e ?lo
let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda} let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_let_in ?loc (binder, ascr) mut inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut } let e_let_in ?loc (binder, ascr) mut inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut }
let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = s; element = a}
let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b} let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
let e_record ?loc map : expression = make_e ?loc @@ E_record map let e_record ?loc map : expression = make_e ?loc @@ E_record map

2
src/stages/2-ast_sugar/combinators.mli
View File

@ -68,7 +68,7 @@ val e_some : ?loc:Location.t -> expression -> expression
val e_none : ?loc:Location.t -> unit -> expression val e_none : ?loc:Location.t -> unit -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_constructor : ?loc:Location.t -> string -> expression -> expression val e_constructor : ?loc:Location.t -> constructor' -> expression -> expression
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression