Properly typed multi-variable binding simplification
Thanks for the help Sanders. :)
This commit is contained in:
parent
fe76f82bb0
commit
9b0eb636fb
@ -538,7 +538,7 @@ and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result =
|
|||||||
let%bind lst = bind_list @@ List.map simpl_expression lst in
|
let%bind lst = bind_list @@ List.map simpl_expression lst in
|
||||||
return @@ e_tuple ?loc lst
|
return @@ e_tuple ?loc lst
|
||||||
|
|
||||||
and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
|
and simpl_declaration : Raw.declaration -> declaration Location.wrap list result =
|
||||||
fun t ->
|
fun t ->
|
||||||
let open! Raw in
|
let open! Raw in
|
||||||
let loc : 'a . 'a Raw.reg -> _ -> _ =
|
let loc : 'a . 'a Raw.reg -> _ -> _ =
|
||||||
@ -547,33 +547,96 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
|
|||||||
| TypeDecl x ->
|
| TypeDecl x ->
|
||||||
let {name;type_expr} : Raw.type_decl = x.value in
|
let {name;type_expr} : Raw.type_decl = x.value in
|
||||||
let%bind type_expression = simpl_type_expression type_expr in
|
let%bind type_expression = simpl_type_expression type_expr in
|
||||||
ok @@ loc x @@ Declaration_type (name.value , type_expression)
|
ok @@ [loc x @@ Declaration_type (name.value , type_expression)]
|
||||||
| Let x -> (
|
| Let x -> (
|
||||||
let _ , binding = x.value in
|
let binding, _ = r_split x in
|
||||||
|
let binding = snd binding in
|
||||||
let {binders; lhs_type; let_rhs} = binding in
|
let {binders; lhs_type; let_rhs} = binding in
|
||||||
|
let%bind (hd, _) =
|
||||||
|
let (hd, tl) = binders in ok (hd, tl) in
|
||||||
|
match hd with
|
||||||
|
| PTuple pt ->
|
||||||
|
let process_variable (var_pair: pattern * Raw.expr) :
|
||||||
|
Ast_simplified.declaration Location.wrap result =
|
||||||
|
(let (par_var, rhs_expr) = var_pair in
|
||||||
|
let%bind (v, v_type) = pattern_to_typed_var par_var in
|
||||||
|
let%bind v_type_expression =
|
||||||
|
match v_type with
|
||||||
|
| Some v_type -> ok @@ (simpl_type_expression v_type)
|
||||||
|
| None -> fail @@ wrong_pattern "typed var tuple" par_var in
|
||||||
|
let%bind v_type_expression = v_type_expression in
|
||||||
|
let%bind simpl_rhs_expr = simpl_expression rhs_expr in
|
||||||
|
ok @@ loc x @@ Declaration_constant (v.value, Some v_type_expression, simpl_rhs_expr) )
|
||||||
|
in let%bind variables = ok @@ npseq_to_list pt.value
|
||||||
|
in let%bind expr_bind_lst =
|
||||||
|
match let_rhs with
|
||||||
|
| ETuple et -> ok @@ npseq_to_list et.value
|
||||||
|
| EVar v -> (* Handle variable bound to tuple *)
|
||||||
|
let name = v.value in
|
||||||
|
let rec gen_access_tuple ?(i: int = 0)
|
||||||
|
?(accesses: Raw.expr list = []) (name: string)
|
||||||
|
: Raw.expr list =
|
||||||
|
let build_access_expr : Raw.expr = EProj
|
||||||
|
{region = v.region;
|
||||||
|
value =
|
||||||
|
{ struct_name = v;
|
||||||
|
selector = Region.ghost ;
|
||||||
|
field_path =
|
||||||
|
(
|
||||||
|
(Component
|
||||||
|
{region = Region.ghost;
|
||||||
|
value = name, Z.of_int i;} : Raw.selection)
|
||||||
|
, []);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
in
|
||||||
|
if i = (List.length variables) then accesses
|
||||||
|
else
|
||||||
|
let accesses =
|
||||||
|
build_access_expr :: accesses
|
||||||
|
in
|
||||||
|
gen_access_tuple name ~i: (i + 1) ~accesses
|
||||||
|
in ok (gen_access_tuple name)
|
||||||
|
(* TODO: Improve this error message *)
|
||||||
|
| other -> fail @@ simplifying_expr other
|
||||||
|
in let%bind decls =
|
||||||
|
bind_map_list process_variable (List.combine variables expr_bind_lst)
|
||||||
|
in ok @@ decls
|
||||||
|
| PPar {region = _ ; value = { lpar = _ ; inside = pt; rpar = _; } } ->
|
||||||
|
(* Extract parenthetical multi-bind *)
|
||||||
|
let wild = fst @@ fst @@ r_split x in
|
||||||
|
simpl_declaration
|
||||||
|
(Let {
|
||||||
|
region = x.region;
|
||||||
|
value = (wild, {binders = (pt, []);
|
||||||
|
lhs_type = lhs_type;
|
||||||
|
eq = Region.ghost ;
|
||||||
|
let_rhs = let_rhs})}
|
||||||
|
: Raw.declaration)
|
||||||
|
| _ ->
|
||||||
let%bind (var, args) =
|
let%bind (var, args) =
|
||||||
let%bind (hd, tl) =
|
let%bind (hd, tl) =
|
||||||
let hd, tl = binders in ok (hd, tl) in
|
let hd, tl = binders in ok (hd, tl) in
|
||||||
let%bind var = pattern_to_var hd in
|
let%bind var = pattern_to_var hd in
|
||||||
ok (var , tl)
|
ok (var , tl)
|
||||||
in
|
in
|
||||||
match args with
|
match args with
|
||||||
[] ->
|
| [] ->
|
||||||
let%bind lhs_type' =
|
let%bind lhs_type' =
|
||||||
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in
|
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in
|
||||||
let%bind rhs' = simpl_expression let_rhs in
|
let%bind rhs' = simpl_expression let_rhs in
|
||||||
ok @@ loc x @@ (Declaration_constant (var.value , lhs_type' , rhs'))
|
ok @@ [loc x @@ Declaration_constant (var.value , lhs_type' , rhs')]
|
||||||
| param1::others ->
|
| param1::others ->
|
||||||
let fun_ = {
|
let fun_ = {
|
||||||
kwd_fun = Region.ghost;
|
kwd_fun = Region.ghost;
|
||||||
binders = param1, others;
|
binders = param1, others;
|
||||||
lhs_type;
|
lhs_type;
|
||||||
arrow = Region.ghost;
|
arrow = Region.ghost;
|
||||||
body = let_rhs} in
|
body = let_rhs} in
|
||||||
let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in
|
let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in
|
||||||
let%bind rhs' = simpl_expression rhs in
|
let%bind rhs' = simpl_expression rhs in
|
||||||
ok @@ loc x @@ (Declaration_constant (var.value , None , rhs'))
|
ok @@ [loc x @@ Declaration_constant (var.value , None , rhs')]
|
||||||
)
|
)
|
||||||
|
|
||||||
and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
|
and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
|
||||||
fun t ->
|
fun t ->
|
||||||
@ -690,4 +753,5 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
|
|||||||
in bind_or (as_option () , as_variant ())
|
in bind_or (as_option () , as_variant ())
|
||||||
|
|
||||||
let simpl_program : Raw.ast -> program result = fun t ->
|
let simpl_program : Raw.ast -> program result = fun t ->
|
||||||
bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl
|
let%bind decls = bind_list (List.map simpl_declaration @@ nseq_to_list t.decl) in
|
||||||
|
ok @@ List.concat @@ decls
|
||||||
|
14
src/test/contracts/let_multiple.mligo
Normal file
14
src/test/contracts/let_multiple.mligo
Normal file
@ -0,0 +1,14 @@
|
|||||||
|
(* Simple test of binding multiple values *)
|
||||||
|
|
||||||
|
let (x: int), (y: int) = 1,2
|
||||||
|
|
||||||
|
let main (p: unit) : int = x + y
|
||||||
|
|
||||||
|
let ((x : int) , (y :int)) = 3,3
|
||||||
|
|
||||||
|
let main_paren (p: unit) : int = x + y
|
||||||
|
|
||||||
|
let foobar : (int * int) = (23 , 42)
|
||||||
|
let (foo : int) , (bar : int) = foobar
|
||||||
|
|
||||||
|
let non_tuple_rhs (p: unit) : int = foo + bar
|
@ -1175,6 +1175,25 @@ let website2_mligo () : unit result =
|
|||||||
e_pair (e_typed_list [] t_operation) (e_int (op 42 n)) in
|
e_pair (e_typed_list [] t_operation) (e_int (op 42 n)) in
|
||||||
expect_eq_n program "main" make_input make_expected
|
expect_eq_n program "main" make_input make_expected
|
||||||
|
|
||||||
|
let mligo_let_multiple () : unit result =
|
||||||
|
let%bind program = mtype_file "./contracts/let_multiple.mligo" in
|
||||||
|
let%bind () =
|
||||||
|
let input = e_unit () in
|
||||||
|
let expected = e_int 3 in
|
||||||
|
expect_eq program "main" input expected
|
||||||
|
in
|
||||||
|
let%bind () =
|
||||||
|
let input = e_unit () in
|
||||||
|
let expected = e_int 6 in
|
||||||
|
expect_eq program "main_paren" input expected
|
||||||
|
in
|
||||||
|
let%bind () =
|
||||||
|
let input = e_unit () in
|
||||||
|
let expected = e_int 65 in
|
||||||
|
expect_eq program "non_tuple_rhs" input expected
|
||||||
|
in
|
||||||
|
ok ()
|
||||||
|
|
||||||
let balance_constant () : unit result =
|
let balance_constant () : unit result =
|
||||||
let%bind program = type_file "./contracts/balance_constant.ligo" in
|
let%bind program = type_file "./contracts/balance_constant.ligo" in
|
||||||
let input = e_tuple [e_unit () ; e_mutez 0] in
|
let input = e_tuple [e_unit () ; e_mutez 0] in
|
||||||
@ -1281,6 +1300,7 @@ let main = test_suite "Integration (End to End)" [
|
|||||||
test "website1 ligo" website1_ligo ;
|
test "website1 ligo" website1_ligo ;
|
||||||
test "website2 ligo" website2_ligo ;
|
test "website2 ligo" website2_ligo ;
|
||||||
test "website2 (mligo)" website2_mligo ;
|
test "website2 (mligo)" website2_mligo ;
|
||||||
|
test "let multiple (mligo)" mligo_let_multiple ;
|
||||||
test "balance constant" balance_constant ;
|
test "balance constant" balance_constant ;
|
||||||
test "balance constant (mligo)" balance_constant_mligo ;
|
test "balance constant (mligo)" balance_constant_mligo ;
|
||||||
test "simple_access (ligo)" simple_access_ligo;
|
test "simple_access (ligo)" simple_access_ligo;
|
||||||
|
Loading…
Reference in New Issue
Block a user