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

Merge branch 'feature/cameligo-let-in-expand' into 'dev'

Browse Source 
[LIGO-214] CameLIGO does not support multiple value bindings

See merge request ligolang/ligo!180
This commit is contained in:
John David Pressman 2019-11-19 21:13:52 +00:00
commit 35cd4a75f6
3 changed files with 120 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

108
src/passes/2-simplify/ligodity.ml
View File

@ -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
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 ->
let open! Raw in
let loc : 'a . 'a Raw.reg -> _ -> _ =
@ -547,33 +547,96 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
| TypeDecl x ->
let {name;type_expr} : Raw.type_decl = x.value 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 _ , binding = x.value in
let binding, _ = r_split x in
let binding = snd 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 (hd, tl) =
let hd, tl = binders in ok (hd, tl) in
let%bind var = pattern_to_var hd in
ok (var , tl)
in
match args with
[] ->
let%bind lhs_type' =
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in
let%bind rhs' = simpl_expression let_rhs in
ok @@ loc x @@ (Declaration_constant (var.value , lhs_type' , rhs'))
| param1::others ->
let fun_ = {
kwd_fun = Region.ghost;
binders = param1, others;
lhs_type;
arrow = Region.ghost;
body = let_rhs} in
let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in
let%bind rhs' = simpl_expression rhs in
ok @@ loc x @@ (Declaration_constant (var.value , None , rhs'))
)
in
match args with
| [] ->
let%bind lhs_type' =
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in
let%bind rhs' = simpl_expression let_rhs in
ok @@ [loc x @@ Declaration_constant (var.value , lhs_type' , rhs')]
| param1::others ->
let fun_ = {
kwd_fun = Region.ghost;
binders = param1, others;
lhs_type;
arrow = Region.ghost;
body = let_rhs} in
let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in
let%bind rhs' = simpl_expression rhs in
ok @@ [loc x @@ Declaration_constant (var.value , None , rhs')]
)
and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
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 ())
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
View 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

20
src/test/integration_tests.ml
View File

@ -1175,6 +1175,25 @@ let website2_mligo () : unit result =
e_pair (e_typed_list [] t_operation) (e_int (op 42 n)) in
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%bind program = type_file "./contracts/balance_constant.ligo" 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 "website2 ligo" website2_ligo ;
test "website2 (mligo)" website2_mligo ;
test "let multiple (mligo)" mligo_let_multiple ;
test "balance constant" balance_constant ;
test "balance constant (mligo)" balance_constant_mligo ;
test "simple_access (ligo)" simple_access_ligo;