From 60edd0cf5b0be4c8a209de0647e2f5b5e2c2f1a5 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Fri, 10 Jan 2020 16:41:47 +0100 Subject: [PATCH] after review 1 --- src/passes/1-parser/cameligo/AST.ml | 2 ++ src/passes/1-parser/cameligo/Parser.mly | 12 +++++++--- src/passes/1-parser/cameligo/ParserLog.ml | 6 +++-- src/passes/1-parser/cameligo/Tests/pp.mligo | 3 +++ src/passes/1-parser/pascaligo/Tests/pp.ligo | 2 ++ src/passes/4-typer-new/typer.ml | 26 +++++++++++++++------ src/passes/4-typer-old/typer.ml | 13 +++++++---- src/stages/ast_simplified/misc.ml | 16 ++++++------- src/test/contracts/record.ligo | 11 ++++++++- src/test/contracts/record.mligo | 8 ++++++- src/test/integration_tests.ml | 22 +++++++++++++++-- 11 files changed, 92 insertions(+), 29 deletions(-) diff --git a/src/passes/1-parser/cameligo/AST.ml b/src/passes/1-parser/cameligo/AST.ml index f8b008a9a..9c7f1f982 100644 --- a/src/passes/1-parser/cameligo/AST.ml +++ b/src/passes/1-parser/cameligo/AST.ml @@ -335,9 +335,11 @@ and field_assign = { } and update = { + lbrace : lbrace; record : path; kwd_with : kwd_with; updates : record reg; + rbrace : rbrace; } and path = Name of variable diff --git a/src/passes/1-parser/cameligo/Parser.mly b/src/passes/1-parser/cameligo/Parser.mly index 5cba24a52..f37c463f9 100644 --- a/src/passes/1-parser/cameligo/Parser.mly +++ b/src/passes/1-parser/cameligo/Parser.mly @@ -616,12 +616,18 @@ record_expr: in {region; value} } update_record: - "{" path "with" record_expr "}" { + "{" path "with" sep_or_term_list(field_assignment,";") "}" { let region = cover $1 $5 in + let ne_elements, terminator = $4 in let value = { - record = $2; + lbrace = $1; + record = $2; kwd_with = $3; - updates = $4} + updates = { value = {compound = Braces($1,$5); + ne_elements; + terminator}; + region = cover $3 $5}; + rbrace = $5} in {region; value} } field_assignment: diff --git a/src/passes/1-parser/cameligo/ParserLog.ml b/src/passes/1-parser/cameligo/ParserLog.ml index 07dcd19ca..e10539e3e 100644 --- a/src/passes/1-parser/cameligo/ParserLog.ml +++ b/src/passes/1-parser/cameligo/ParserLog.ml @@ -176,10 +176,12 @@ and print_projection state {value; _} = print_nsepseq state "." print_selection field_path and print_update state {value; _} = - let {record; kwd_with; updates} = value in + let {lbrace; record; kwd_with; updates; rbrace} = value in + print_token state lbrace "{"; print_path state record; print_token state kwd_with "with"; - print_record_expr state updates + print_record_expr state updates; + print_token state rbrace "}" and print_path state = function Name var -> print_var state var diff --git a/src/passes/1-parser/cameligo/Tests/pp.mligo b/src/passes/1-parser/cameligo/Tests/pp.mligo index 99aff4f23..d84c270aa 100644 --- a/src/passes/1-parser/cameligo/Tests/pp.mligo +++ b/src/passes/1-parser/cameligo/Tests/pp.mligo @@ -24,3 +24,6 @@ let e = Some (a, B b) let z = z.1.2 let v = "hello" ^ "world" ^ "!" let w = Map.literal [(1,"1"); (2,"2")] + +let r = { field = 0} +let r = { r with field = 42} diff --git a/src/passes/1-parser/pascaligo/Tests/pp.ligo b/src/passes/1-parser/pascaligo/Tests/pp.ligo index 78c06c34d..a2e873338 100644 --- a/src/passes/1-parser/pascaligo/Tests/pp.ligo +++ b/src/passes/1-parser/pascaligo/Tests/pp.ligo @@ -24,6 +24,8 @@ function back (var store : store) : list (operation) * store is x := map [1 -> "1"; 2 -> "2"]; y := a.b.c[3]; a := "hello " ^ "world" ^ "!"; + r := record a = 0 end; + r := r with record a = 42 end; patch store.backers with set [(1); f(2*3)]; remove (1,2,3) from set foo.bar; remove 3 from map foo.bar; diff --git a/src/passes/4-typer-new/typer.ml b/src/passes/4-typer-new/typer.ml index b65df8593..da0543b74 100644 --- a/src/passes/4-typer-new/typer.ml +++ b/src/passes/4-typer-new/typer.ml @@ -530,14 +530,26 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e let wrapped = Wrap.record (I.LMap.map get_type_annotation m') in return_wrapped (E_record m') state' wrapped | E_update {record; updates} -> - let%bind (record, state') = type_expression e state record in - let aux (acc, state) (k, expr) = - let%bind (expr',state') = type_expression e state expr in - ok ((k,expr')::acc, state') + let%bind (record, state) = type_expression e state record in + let aux (lst,state) (k, expr) = + let%bind (expr', state) = type_expression e state expr in + ok ((k,expr')::lst, state) in - let%bind(updates,state') = bind_fold_list aux ([], state') updates in - let wrapped = Wrap.list (List.map (fun (_,e) -> get_type_annotation e) updates) in - return_wrapped (E_record_update (record, updates)) state' wrapped + let%bind (updates, state) = bind_fold_list aux ([], state) updates in + let wrapped = get_type_annotation record in + let%bind wrapped = match wrapped.type_value' with + | T_record record -> + let aux (k, e) = + let field_op = I.LMap.find_opt k record in + match field_op with + | None -> failwith @@ Format.asprintf "field %a is not part of record" Stage_common.PP.label k + | Some tv -> O.assert_type_value_eq (tv, get_type_annotation e) + in + let%bind () = bind_iter_list aux updates in + ok (record) + | _ -> failwith "Update an expression which is not a record" + in + return_wrapped (E_record_update (record, updates)) state (Wrap.record wrapped) (* Data-structure *) (* diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index 6e54cfe63..59cbbf8bc 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -504,13 +504,16 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O. in let%bind updates = bind_fold_list aux ([]) updates in let wrapped = get_type_annotation record in - let wrapped = match wrapped.type_value' with + let%bind () = match wrapped.type_value' with | T_record record -> - let aux acc (k, e) = - I.LMap.add k (get_type_annotation e) acc + let aux (k, e) = + let field_op = I.LMap.find_opt k record in + match field_op with + | None -> failwith @@ Format.asprintf "field %a is not part of record" Stage_common.PP.label k + | Some tv -> O.assert_type_value_eq (tv, get_type_annotation e) in - t_record (List.fold_left aux record updates) () - | _ -> failwith "Update something which is not a record" + bind_iter_list aux updates + | _ -> failwith "Update an expression which is not a record" in return (E_record_update (record, updates)) wrapped (* Data-structure *) diff --git a/src/stages/ast_simplified/misc.ml b/src/stages/ast_simplified/misc.ml index b4f40c803..a37e57cf3 100644 --- a/src/stages/ast_simplified/misc.ml +++ b/src/stages/ast_simplified/misc.ml @@ -99,7 +99,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = PP.expression a PP.expression b in - fail @@ (fun () -> error (thunk "comparing constant with other stuff") error_content ()) + fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ()) | E_constructor (ca, a), E_constructor (cb, b) when ca = cb -> ( let%bind _eq = assert_value_eq (a, b) in @@ -108,7 +108,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | E_constructor _, E_constructor _ -> simple_fail "different constructors" | E_constructor _, _ -> - simple_fail "comparing constructor with other stuff" + simple_fail "comparing constructor with other expression" | E_tuple lsta, E_tuple lstb -> ( let%bind lst = @@ -118,7 +118,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = ok () ) | E_tuple _, _ -> - simple_fail "comparing tuple with other stuff" + simple_fail "comparing tuple with other expression" | E_record sma, E_record smb -> ( let aux _ a b = @@ -130,7 +130,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = ok () ) | E_record _, _ -> - simple_fail "comparing record with other stuff" + simple_fail "comparing record with other expression" | E_update ura, E_update urb -> let%bind lst = @@ -143,7 +143,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = let%bind _all = bind_list @@ List.map aux lst in ok () | E_update _, _ -> - simple_fail "comparing record update with orther stuff" + simple_fail "comparing record update with other expression" | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( let%bind lst = generic_try (simple_error "maps of different lengths") @@ -159,7 +159,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = ok () ) | (E_map _ | E_big_map _), _ -> - simple_fail "comparing map with other stuff" + simple_fail "comparing map with other expression" | E_list lsta, E_list lstb -> ( let%bind lst = @@ -169,7 +169,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = ok () ) | E_list _, _ -> - simple_fail "comparing list with other stuff" + simple_fail "comparing list with other expression" | E_set lsta, E_set lstb -> ( let lsta' = List.sort (compare) lsta in @@ -181,7 +181,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = ok () ) | E_set _, _ -> - simple_fail "comparing set with other stuff" + simple_fail "comparing set with other expression" | (E_ascription (a , _) , _b') -> assert_value_eq (a , b) | (_a' , E_ascription (b , _)) -> assert_value_eq (a , b) diff --git a/src/test/contracts/record.ligo b/src/test/contracts/record.ligo index 0ce9737fd..dca49f72c 100644 --- a/src/test/contracts/record.ligo +++ b/src/test/contracts/record.ligo @@ -38,7 +38,7 @@ function modify (const r : foobar) : foobar is function modify_abc (const r : abc) : abc is block { - r := r with record b = 2048; end; + r := r with record b = 2048; c = 42; end; } with r type big_record is record @@ -56,3 +56,12 @@ const br : big_record = record d = 23 ; e = 23 ; end + +type double_record is record + inner : abc; +end + +function modify_inner (const r : double_record) : double_record is + block { + r := r with record inner = r.inner with record b = 2048; end; end; + } with r diff --git a/src/test/contracts/record.mligo b/src/test/contracts/record.mligo index ecd5f99d8..8b340cd1e 100644 --- a/src/test/contracts/record.mligo +++ b/src/test/contracts/record.mligo @@ -28,7 +28,7 @@ let projection (r : foobar) : int = r.foo + r.bar let modify (r : foobar) : foobar = {foo = 256; bar = r.bar} -let modify_abc (r : abc) : abc = {r with {b = 2048}} +let modify_abc (r : abc) : abc = {r with b = 2048; c = 42} type big_record = { a : int ; @@ -45,3 +45,9 @@ let br : big_record = { d = 23 ; e = 23 ; } + +type double_record = { + inner : abc; +} + +let modify_inner (r : double_record) : double_record = {r with inner = {r.inner with b = 2048 }} diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 555f66119..26915dc4c 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -682,7 +682,7 @@ let record () : unit result = let make_expected = fun n -> ez_e_record [ ("a" , e_int n) ; ("b" , e_int 2048) ; - ("c" , e_int n) + ("c" , e_int 42) ] in expect_eq_n program "modify_abc" make_input make_expected in @@ -690,6 +690,15 @@ let record () : unit result = let expected = record_ez_int ["a";"b";"c";"d";"e"] 23 in expect_eq_evaluate program "br" expected in + let%bind () = + let make_input = fun n -> ez_e_record [("inner", record_ez_int ["a";"b";"c"] n)] in + let make_expected = fun n -> ez_e_record [("inner", ez_e_record[ + ("a" , e_int n) ; + ("b" , e_int 2048) ; + ("c" , e_int n) + ])] in + expect_eq_n program "modify_inner" make_input make_expected + in ok () let record_mligo () : unit result = @@ -719,7 +728,7 @@ let record_mligo () : unit result = let make_expected = fun n -> ez_e_record [ ("a" , e_int n) ; ("b" , e_int 2048) ; - ("c" , e_int n) + ("c" , e_int 42) ] in expect_eq_n program "modify_abc" make_input make_expected in @@ -727,6 +736,15 @@ let record_mligo () : unit result = let expected = record_ez_int ["a";"b";"c";"d";"e"] 23 in expect_eq_evaluate program "br" expected in + let%bind () = + let make_input = fun n -> ez_e_record [("inner", record_ez_int ["a";"b";"c"] n)] in + let make_expected = fun n -> ez_e_record [("inner", ez_e_record[ + ("a" , e_int n) ; + ("b" , e_int 2048) ; + ("c" , e_int n) + ])] in + expect_eq_n program "modify_inner" make_input make_expected + in ok () let tuple () : unit result =