From f36d6a01de0799747e9f285977e4763815de91a7 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Tue, 28 Jan 2020 14:12:46 +0000 Subject: [PATCH 1/2] Modify record update, using path for update --- src/passes/1-parser/cameligo/AST.ml | 7 +++- src/passes/1-parser/cameligo/Parser.mly | 10 ++++- src/passes/1-parser/cameligo/ParserLog.ml | 16 +++++++- src/passes/1-parser/pascaligo/AST.ml | 8 +++- src/passes/1-parser/pascaligo/Parser.mly | 10 ++++- src/passes/1-parser/pascaligo/ParserLog.ml | 19 +++++++-- src/passes/1-parser/reasonligo/Parser.mly | 20 +++++++++- src/passes/2-simplify/cameligo.ml | 15 +++++-- src/passes/2-simplify/pascaligo.ml | 15 +++++-- src/passes/3-self_ast_simplified/helpers.ml | 14 +++---- src/passes/4-typer-new/typer.ml | 36 +++++++---------- src/passes/4-typer-old/typer.ml | 39 ++++++++----------- src/passes/6-transpiler/transpiler.ml | 26 ++++++------- src/passes/7-self_mini_c/helpers.ml | 14 +++---- src/passes/7-self_mini_c/self_mini_c.ml | 8 ++-- src/passes/7-self_mini_c/subst.ml | 12 +++--- src/passes/8-compiler/compiler_program.ml | 43 ++++++++++----------- src/stages/ast_simplified/PP.ml | 4 +- src/stages/ast_simplified/combinators.ml | 7 ++-- src/stages/ast_simplified/combinators.mli | 2 +- src/stages/ast_simplified/misc.ml | 10 ++--- src/stages/ast_simplified/types.ml | 2 +- src/stages/ast_typed/PP.ml | 2 +- src/stages/ast_typed/misc.ml | 2 +- src/stages/ast_typed/misc_smart.ml | 10 ++--- src/stages/ast_typed/types.ml | 2 +- src/stages/common/PP.mli | 1 + src/stages/mini_c/PP.ml | 4 +- src/stages/mini_c/misc.ml | 2 +- src/stages/mini_c/types.ml | 2 +- src/stages/typesystem/misc.ml | 6 +-- src/test/contracts/record.ligo | 2 +- src/test/contracts/record.mligo | 2 +- src/test/contracts/record.religo | 2 +- 34 files changed, 215 insertions(+), 159 deletions(-) diff --git a/src/passes/1-parser/cameligo/AST.ml b/src/passes/1-parser/cameligo/AST.ml index d00cf9cd7..551d82077 100644 --- a/src/passes/1-parser/cameligo/AST.ml +++ b/src/passes/1-parser/cameligo/AST.ml @@ -333,10 +333,15 @@ and update = { lbrace : lbrace; record : path; kwd_with : kwd_with; - updates : record reg; + updates : field_path_assign reg ne_injection reg; rbrace : rbrace; } +and field_path_assign = { + field_path : (field_name, dot) nsepseq; + assignment : equal; + field_expr : expr +} and path = Name of variable | Path of projection reg diff --git a/src/passes/1-parser/cameligo/Parser.mly b/src/passes/1-parser/cameligo/Parser.mly index e6cc6f903..8becc88f5 100644 --- a/src/passes/1-parser/cameligo/Parser.mly +++ b/src/passes/1-parser/cameligo/Parser.mly @@ -627,7 +627,7 @@ record_expr: in {region; value} } update_record: - "{" path "with" sep_or_term_list(field_assignment,";") "}" { + "{" path "with" sep_or_term_list(field_path_assignment,";") "}" { let region = cover $1 $5 in let ne_elements, terminator = $4 in let value = { @@ -641,6 +641,14 @@ update_record: rbrace = $5} in {region; value} } +field_path_assignment : + nsepseq(field_name,".") "=" expr { + let region = cover (nsepseq_to_region (fun x -> x.region) $1) (expr_to_region $3) in + let value = {field_path = $1; + assignment = $2; + field_expr = $3} + in {region; value}} + field_assignment: field_name "=" expr { let start = $1.region in diff --git a/src/passes/1-parser/cameligo/ParserLog.ml b/src/passes/1-parser/cameligo/ParserLog.ml index e0b7fd09b..aa847e245 100644 --- a/src/passes/1-parser/cameligo/ParserLog.ml +++ b/src/passes/1-parser/cameligo/ParserLog.ml @@ -188,7 +188,7 @@ and print_update state {value; _} = print_token state lbrace "{"; print_path state record; print_token state kwd_with "with"; - print_record_expr state updates; + print_ne_injection state print_field_path_assign updates; print_token state rbrace "}" and print_path state = function @@ -513,6 +513,12 @@ and print_field_assign state {value; _} = print_token state assignment "="; print_expr state field_expr +and print_field_path_assign state {value; _} = + let {field_path; assignment; field_expr} = value in + print_nsepseq state "." print_var field_path; + print_token state assignment "="; + print_expr state field_expr + and print_sequence state seq = print_injection state print_expr seq @@ -905,7 +911,7 @@ and pp_projection state proj = and pp_update state update = pp_path state update.record; - pp_ne_injection pp_field_assign state update.updates.value + pp_ne_injection pp_field_path_assign state update.updates.value and pp_path state = function Name name -> @@ -928,6 +934,12 @@ and pp_field_assign state {value; _} = pp_ident (state#pad 2 0) value.field_name; pp_expr (state#pad 2 1) value.field_expr +and pp_field_path_assign state {value; _} = + pp_node state ""; + let path = Utils.nsepseq_to_list value.field_path in + List.iter (pp_ident (state#pad 2 0)) path; + pp_expr (state#pad 2 1) value.field_expr + and pp_constr_expr state = function ENone region -> pp_loc_node state "ENone" region diff --git a/src/passes/1-parser/pascaligo/AST.ml b/src/passes/1-parser/pascaligo/AST.ml index 5f95dc3e5..27dfdd585 100644 --- a/src/passes/1-parser/pascaligo/AST.ml +++ b/src/passes/1-parser/pascaligo/AST.ml @@ -577,7 +577,13 @@ and projection = { and update = { record : path; kwd_with : kwd_with; - updates : record reg; + updates : field_path_assign reg ne_injection reg +} + +and field_path_assign = { + field_path : (field_name, dot) nsepseq; + equal : equal; + field_expr : expr } and selection = diff --git a/src/passes/1-parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly index 9b41ba242..55ac2262e 100644 --- a/src/passes/1-parser/pascaligo/Parser.mly +++ b/src/passes/1-parser/pascaligo/Parser.mly @@ -937,7 +937,7 @@ record_expr: in {region; value} } update_record: - path "with" ne_injection("record",field_assignment){ + path "with" ne_injection("record",field_path_assignment){ let region = cover (path_to_region $1) $3.region in let value = { record = $1; @@ -954,6 +954,14 @@ field_assignment: field_expr = $3} in {region; value} } +field_path_assignment: + nsepseq(field_name,".") "=" expr { + let region = cover (nsepseq_to_region (fun x -> x.region) $1) (expr_to_region $3) + and value = {field_path = $1; + equal = $2; + field_expr = $3} + in {region; value} } + fun_call: fun_name arguments { let region = cover $1.region $2.region diff --git a/src/passes/1-parser/pascaligo/ParserLog.ml b/src/passes/1-parser/pascaligo/ParserLog.ml index 06c42718a..d423006f2 100644 --- a/src/passes/1-parser/pascaligo/ParserLog.ml +++ b/src/passes/1-parser/pascaligo/ParserLog.ml @@ -603,11 +603,18 @@ and print_field_assign state {value; _} = print_token state equal "="; print_expr state field_expr -and print_update_expr state {value; _} = +and print_field_path_assign state {value; _} = + let {field_path; equal; field_expr} = value in + print_nsepseq state "field_path" print_var field_path; + print_token state equal "="; + print_expr state field_expr + +and print_update_expr state {value; _} = let {record; kwd_with; updates} = value in print_path state record; print_token state kwd_with "with"; - print_record_expr state updates + print_ne_injection state "updates field" print_field_path_assign updates + and print_projection state {value; _} = let {struct_name; selector; field_path} = value in @@ -1215,7 +1222,7 @@ and pp_projection state proj = and pp_update state update = pp_path state update.record; - pp_ne_injection pp_field_assign state update.updates.value + pp_ne_injection pp_field_path_assign state update.updates.value and pp_selection state = function FieldName name -> @@ -1320,6 +1327,12 @@ and pp_field_assign state {value; _} = pp_ident (state#pad 2 0) value.field_name; pp_expr (state#pad 2 1) value.field_expr +and pp_field_path_assign state {value; _} = + pp_node state ""; + let path = Utils.nsepseq_to_list value.field_path in + List.iter (pp_ident (state#pad 2 0)) path; + pp_expr (state#pad 2 1) value.field_expr + and pp_map_patch state patch = pp_path (state#pad 2 0) patch.path; pp_ne_injection pp_binding state patch.map_inj.value diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly index 12f2e7f42..142a29313 100644 --- a/src/passes/1-parser/reasonligo/Parser.mly +++ b/src/passes/1-parser/reasonligo/Parser.mly @@ -812,7 +812,7 @@ path : | projection { Path $1} update_record : - "{""..."path "," sep_or_term_list(field_assignment,",") "}" { + "{""..."path "," sep_or_term_list(field_path_assignment,",") "}" { let region = cover $1 $6 in let ne_elements, terminator = $5 in let value = { @@ -873,3 +873,21 @@ field_assignment: assignment = $2; field_expr = $3} in {region; value} } + +field_path_assignment: + field_name { + let value = { + field_path = ($1,[]); + assignment = ghost; + field_expr = EVar $1 } + in {$1 with value} + } +| nsepseq(field_name,".") ":" expr { + let start = nsepseq_to_region (fun x -> x.region) $1 in + let stop = expr_to_region $3 in + let region = cover start stop in + let value = { + field_path = $1; + assignment = $2; + field_expr = $3} + in {region; value} } diff --git a/src/passes/2-simplify/cameligo.ml b/src/passes/2-simplify/cameligo.ml index 917d001bf..a836ce2b0 100644 --- a/src/passes/2-simplify/cameligo.ml +++ b/src/passes/2-simplify/cameligo.ml @@ -291,14 +291,23 @@ let rec simpl_expression : | _ -> e_accessor (e_variable (Var.of_name name)) path in let updates = u.updates.value.ne_elements in let%bind updates' = - let aux (f:Raw.field_assign Raw.reg) = + let aux (f:Raw.field_path_assign Raw.reg) = let (f,_) = r_split f in let%bind expr = simpl_expression f.field_expr in - ok (f.field_name.value, expr) + ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) in bind_map_list aux @@ npseq_to_list updates in - return @@ e_update ~loc record updates' + let aux ur (path, expr) = + let rec aux record = function + | [] -> failwith "error in parsing" + | hd :: [] -> ok @@ e_update ~loc record hd expr + | hd :: tl -> + let%bind expr = (aux (e_accessor ~loc record [Access_record hd]) tl) in + ok @@ e_update ~loc record hd expr + in + aux ur path in + bind_fold_list aux record updates' in trace (simplifying_expr t) @@ diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index 113ab7c63..fa98720c8 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -473,14 +473,23 @@ and simpl_update = fun (u:Raw.update Region.reg) -> | _ -> e_accessor (e_variable (Var.of_name name)) path in let updates = u.updates.value.ne_elements in let%bind updates' = - let aux (f:Raw.field_assign Raw.reg) = + let aux (f:Raw.field_path_assign Raw.reg) = let (f,_) = r_split f in let%bind expr = simpl_expression f.field_expr in - ok (f.field_name.value, expr) + ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) in bind_map_list aux @@ npseq_to_list updates in - ok @@ e_update ~loc record updates' + let aux ur (path, expr) = + let rec aux record = function + | [] -> failwith "error in parsing" + | hd :: [] -> ok @@ e_update ~loc record hd expr + | hd :: tl -> + let%bind expr = (aux (e_accessor ~loc record [Access_record hd]) tl) in + ok @@ e_update ~loc record hd expr + in + aux ur path in + bind_fold_list aux record updates' and simpl_logic_expression (t:Raw.logic_expr) : expression result = let return x = ok x in diff --git a/src/passes/3-self_ast_simplified/helpers.ml b/src/passes/3-self_ast_simplified/helpers.ml index fc4346147..47b06e9b9 100644 --- a/src/passes/3-self_ast_simplified/helpers.ml +++ b/src/passes/3-self_ast_simplified/helpers.ml @@ -41,13 +41,9 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = bind_fold_lmap aux (ok init') m in ok res ) - | E_update {record;updates} -> ( + | E_update {record;update=(_,expr)} -> ( let%bind res = self init' record in - let aux res (_, expr) = - let%bind res = fold_expression self res expr in - ok res - in - let%bind res = bind_fold_list aux res updates in + let%bind res = fold_expression self res expr in ok res ) | E_let_in { binder = _ ; rhs ; result } -> ( @@ -140,10 +136,10 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind m' = bind_map_lmap self m in return @@ E_record m' ) - | E_update {record; updates} -> ( + | E_update {record; update=(l,expr)} -> ( let%bind record = self record in - let%bind updates = bind_map_list (fun(l,e) -> let%bind e = self e in ok (l,e)) updates in - return @@ E_update {record;updates} + let%bind expr = self expr in + return @@ E_update {record;update=(l,expr)} ) | E_constructor (name , e) -> ( let%bind e' = self e in diff --git a/src/passes/4-typer-new/typer.ml b/src/passes/4-typer-new/typer.ml index 537a4c485..05b11c897 100644 --- a/src/passes/4-typer-new/typer.ml +++ b/src/passes/4-typer-new/typer.ml @@ -529,27 +529,22 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e let%bind (m' , state') = I.bind_fold_lmap aux (ok (I.LMap.empty , state)) m in let wrapped = Wrap.record (I.LMap.map get_type_annotation m') in return_wrapped (E_record m') state' wrapped - | E_update {record; updates} -> + | E_update {record; update=(k,expr)} -> 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%bind (expr,state) = type_expression e state expr in let wrapped = get_type_annotation record in - let%bind wrapped = match wrapped.type_value' with - | T_record record -> - let aux (k, e) = + let%bind (wrapped,tv) = + match wrapped.type_value' with + | T_record record -> ( let field_op = I.LMap.find_opt k record in match field_op with + | Some tv -> ok (record,tv) | 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" + ) + | _ -> failwith "Update an expression which is not a record" in - return_wrapped (E_record_update (record, updates)) state (Wrap.record wrapped) + let%bind () = O.assert_type_value_eq (tv, get_type_annotation expr) in + return_wrapped (E_record_update (record, (k,expr))) state (Wrap.record wrapped) (* Data-structure *) (* @@ -1139,14 +1134,11 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = | E_record_accessor (r, Label s) -> let%bind r' = untype_expression r in return (e_accessor r' [Access_record s]) - | E_record_update (r, updates) -> + | E_record_update (r, (l,e)) -> let%bind r' = untype_expression r in - let aux (Label l,e) = - let%bind e = untype_expression e in - ok (l, e) - in - let%bind updates = bind_map_list aux updates in - return (e_update r' updates) + let%bind e = untype_expression e in + let Label l = l in + return (e_update r' l e) | E_map m -> let%bind m' = bind_map_list (bind_map_pair untype_expression) m in return (e_map m') diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index 1b9f90fbd..1e65fad3e 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -496,26 +496,22 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O. in let%bind m' = I.bind_fold_lmap aux (ok I.LMap.empty) m in return (E_record m') (t_record (I.LMap.map get_type_annotation m') ()) - | E_update {record; updates} -> + | E_update {record; update =(l,expr)} -> let%bind record = type_expression' e record in - let aux acc (k, expr) = - let%bind expr' = type_expression' e expr in - ok ((k,expr')::acc) - in - let%bind updates = bind_fold_list aux ([]) updates in + let%bind expr' = type_expression' e expr in let wrapped = get_type_annotation record in - let%bind () = match wrapped.type_value' with - | T_record record -> - let aux (k, e) = - let field_op = I.LMap.find_opt k record in + let%bind tv = + match wrapped.type_value' with + | T_record record -> ( + let field_op = I.LMap.find_opt l 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 - bind_iter_list aux updates - | _ -> failwith "Update an expression which is not a record" + | Some tv -> ok (tv) + | None -> failwith @@ Format.asprintf "field %a is not part of record %a" Stage_common.PP.label l O.PP.type_value wrapped + ) + | _ -> failwith "Update an expression which is not a record" in - return (E_record_update (record, updates)) wrapped + let%bind () = O.assert_type_value_eq (tv, get_type_annotation expr') in + return (E_record_update (record, (l,expr'))) wrapped (* Data-structure *) | E_list lst -> let%bind lst' = bind_map_list (type_expression' e) lst in @@ -896,14 +892,11 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = | E_record_accessor (r, Label s) -> let%bind r' = untype_expression r in return (e_accessor r' [Access_record s]) - | E_record_update (r, updates) -> + | E_record_update (r, (l,e)) -> let%bind r' = untype_expression r in - let aux (Label l,e) = - let%bind e = untype_expression e in - ok (l, e) - in - let%bind updates = bind_map_list aux updates in - return (e_update r' updates) + let%bind e = untype_expression e in + let Label l = l in + return (e_update r' l e) | E_map m -> let%bind m' = bind_map_list (bind_map_pair untype_expression) m in return (e_map m') diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 0cde2e3b5..223264f7f 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -206,11 +206,11 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [ bind_fold_list aux (ty , []) lr_path in ok lst -let record_access_to_lr : type_value -> type_value AST.label_map -> string -> (type_value * [`Left | `Right]) list result = fun ty tym ind -> +let record_access_to_lr : type_value -> type_value AST.label_map -> label -> (type_value * [`Left | `Right]) list result = fun ty tym ind -> let tys = kv_list_of_lmap tym in let node_tv = Append_tree.of_list tys in let%bind path = - let aux (Label i , _) = i = ind in + let aux (Label i , _) = let Label ind = ind in i = ind in trace_option (corner_case ~loc:__LOC__ "record access leaf") @@ Append_tree.exists_path aux node_tv in let lr_path = List.map (fun b -> if b then `Right else `Left) path in @@ -348,7 +348,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re trace_strong (corner_case ~loc:__LOC__ "record build") @@ Append_tree.fold_ne (transpile_annotated_expression) aux node ) - | E_record_accessor (record, Label property) -> + | E_record_accessor (record, property) -> let%bind ty' = transpile_type (get_type_annotation record) in let%bind ty_lmap = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ @@ -365,23 +365,19 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re let%bind record' = transpile_annotated_expression record in let expr = List.fold_left aux record' path in ok expr - | E_record_update (record, updates) -> + | E_record_update (record, (l,expr)) -> let%bind ty' = transpile_type (get_type_annotation record) in let%bind ty_lmap = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ get_t_record (get_type_annotation record) in let%bind ty'_lmap = AST.bind_map_lmap transpile_type ty_lmap in - let aux (Label l, expr) = - let%bind path = - trace_strong (corner_case ~loc:__LOC__ "record access") @@ - record_access_to_lr ty' ty'_lmap l in - let path' = List.map snd path in - let%bind expr' = transpile_annotated_expression expr in - ok (path',expr') - in - let%bind updates = bind_map_list aux updates in + let%bind path = + trace_strong (corner_case ~loc:__LOC__ "record access") @@ + record_access_to_lr ty' ty'_lmap l in + let path' = List.map snd path in + let%bind expr' = transpile_annotated_expression expr in let%bind record = transpile_annotated_expression record in - return @@ E_update (record, updates) + return @@ E_update (record, (path',expr')) | E_constant (name , lst) -> ( let iterator_generator iterator_name = let lambda_to_iterator_body (f : AST.annotated_expression) (l : AST.lambda) = @@ -521,7 +517,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re trace_strong (corner_case ~loc:__LOC__ "not a record") @@ AST.Combinators.get_t_record prev in let%bind ty'_map = bind_map_lmap transpile_type ty_map in - let%bind path = record_access_to_lr ty' ty'_map prop in + let%bind path = record_access_to_lr ty' ty'_map (Label prop) in let path' = List.map snd path in let%bind prop_in_ty_map = trace_option (Errors.not_found "acessing prop in ty_map [TODO: better error message]") diff --git a/src/passes/7-self_mini_c/helpers.ml b/src/passes/7-self_mini_c/helpers.ml index f5638cbe5..6e3a454b1 100644 --- a/src/passes/7-self_mini_c/helpers.ml +++ b/src/passes/7-self_mini_c/helpers.ml @@ -84,13 +84,9 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = self init' exp in ok res ) - | E_update (r, updates) -> ( + | E_update (r, (_,e)) -> ( let%bind res = self init' r in - let aux prev (_,e) = - let%bind res = self prev e in - ok res - in - let%bind res = bind_fold_list aux res updates in + let%bind res = self res e in ok res ) @@ -158,10 +154,10 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind exp' = self exp in return @@ E_assignment (s, lrl, exp') ) - | E_update (r, updates) -> ( + | E_update (r, (l,e)) -> ( let%bind r = self r in - let%bind updates = bind_map_list (fun (p,e) -> let%bind e = self e in ok(p,e)) updates in - return @@ E_update(r,updates) + let%bind e = self e in + return @@ E_update(r,(l,e)) ) let map_sub_level_expression : mapper -> expression -> expression result = fun f e -> diff --git a/src/passes/7-self_mini_c/self_mini_c.ml b/src/passes/7-self_mini_c/self_mini_c.ml index da2c66fa6..98bc0315c 100644 --- a/src/passes/7-self_mini_c/self_mini_c.ml +++ b/src/passes/7-self_mini_c/self_mini_c.ml @@ -66,8 +66,8 @@ let rec is_pure : expression -> bool = fun e -> | E_constant (c, args) -> is_pure_constant c && List.for_all is_pure args - | E_update (e, updates) - -> is_pure e && List.for_all (fun (_,e) -> is_pure e) updates + | E_update (r, (_,e)) + -> is_pure r && is_pure e (* I'm not sure about these. Maybe can be tested better? *) | E_application _ @@ -111,8 +111,8 @@ let rec is_assigned : ignore_lambdas:bool -> expression_variable -> expression - match e.content with | E_assignment (x, _, e) -> it x || self e - | E_update (r, updates) -> - List.fold_left (fun prev (_,e) -> prev || self e) (self r) updates + | E_update (r, (_,e)) -> + self r || self e | E_closure { binder; body } -> if ignore_lambdas then false diff --git a/src/passes/7-self_mini_c/subst.ml b/src/passes/7-self_mini_c/subst.ml index ddba8855a..9582c4a6f 100644 --- a/src/passes/7-self_mini_c/subst.ml +++ b/src/passes/7-self_mini_c/subst.ml @@ -94,10 +94,10 @@ let rec replace : expression -> var_name -> var_name -> expression = let v = replace_var v in let e = replace e in return @@ E_assignment (v, path, e) - | E_update (r, updates) -> + | E_update (r, (p,e)) -> let r = replace r in - let updates = List.map (fun (p,e)-> (p, replace e)) updates in - return @@ E_update (r,updates) + let e = replace e in + return @@ E_update (r, (p,e)) | E_while (cond, body) -> let cond = replace cond in let body = replace body in @@ -209,10 +209,10 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e if Var.equal s x then raise Bad_argument ; return @@ E_assignment (s, lrl, exp') ) - | E_update (r, updates) -> ( + | E_update (r, (p,e)) -> ( let r' = self r in - let updates' = List.map (fun (p,e) -> (p, self e)) updates in - return @@ E_update(r',updates') + let e' = self e in + return @@ E_update(r', (p,e')) ) let%expect_test _ = diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 280d93cfd..c1f7cc5b6 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -402,32 +402,29 @@ and translate_expression (expr:expression) (env:environment) : michelson result i_push_unit ; ] ) - | E_update (record, updates) -> ( + | E_update (record, (path, expr)) -> ( let%bind record' = translate_expression record env in - let insts = [ - i_comment "r_update: start, move the record on top # env"; - record';] in - let aux (init :t list) (update,expr) = - let record_var = Var.fresh () in - let env' = Environment.add (record_var, record.type_value) env in - let%bind expr' = translate_expression expr env' in - let modify_code = - let aux acc step = match step with - | `Left -> seq [dip i_unpair ; acc ; i_pair] - | `Right -> seq [dip i_unpiar ; acc ; i_piar] - in - let init = dip i_drop in - List.fold_right' aux init update + + let record_var = Var.fresh () in + let env' = Environment.add (record_var, record.type_value) env in + let%bind expr' = translate_expression expr env' in + let modify_code = + let aux acc step = match step with + | `Left -> seq [dip i_unpair ; acc ; i_pair] + | `Right -> seq [dip i_unpiar ; acc ; i_piar] in - ok @@ init @ [ - expr'; - i_comment "r_updates : compute rhs # rhs:env"; - modify_code; - i_comment "r_update: modify code # record+rhs : env"; - ] + let init = dip i_drop in + List.fold_right' aux init path in - let%bind insts = bind_fold_list aux insts updates in - return @@ seq insts + return @@ seq [ + i_comment "r_update: start # env"; + record'; + i_comment "r_update: move the record on top # env"; + expr'; + i_comment "r_updates : compute rhs # rhs:env"; + modify_code; + i_comment "r_update: modify code # record+rhs : env"; + ] ) | E_while (expr , block) -> ( diff --git a/src/stages/ast_simplified/PP.ml b/src/stages/ast_simplified/PP.ml index 768d6d12a..b20ee456d 100644 --- a/src/stages/ast_simplified/PP.ml +++ b/src/stages/ast_simplified/PP.ml @@ -26,11 +26,11 @@ let rec expression ppf (e:expression) = match e.expression with | E_tuple lst -> fprintf ppf "(%a)" (tuple_sep_d expression) lst | E_accessor (ae, p) -> fprintf ppf "%a.%a" expression ae access_path p | E_record m -> fprintf ppf "{%a}" (lrecord_sep expression (const " , ")) m - | E_update {record; updates} -> fprintf ppf "%a with {%a}" expression record (tuple_sep_d (fun ppf (a,b) -> fprintf ppf "%a = %a" label a expression b)) updates + | E_update {record; update=(path,expr)} -> fprintf ppf "%a with { %a = %a }" expression record Stage_common.PP.label path expression expr | E_map m -> fprintf ppf "[%a]" (list_sep_d assoc_expression) m | E_big_map m -> fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m | E_list lst -> fprintf ppf "[%a]" (list_sep_d expression) lst - | E_set lst -> fprintf ppf "{%a}" (list_sep_d expression) lst + | E_set lst -> fprintf ppf "{%a}" (list_sep_d expression) lst | E_look_up (ds, ind) -> fprintf ppf "(%a)[%a]" expression ds expression ind | E_lambda {binder;input_type;output_type;result} -> fprintf ppf "lambda (%a:%a) : %a return %a" diff --git a/src/stages/ast_simplified/combinators.ml b/src/stages/ast_simplified/combinators.ml index a082e2fa9..611822768 100644 --- a/src/stages/ast_simplified/combinators.ml +++ b/src/stages/ast_simplified/combinators.ml @@ -174,9 +174,10 @@ let e_ez_record ?loc (lst : (string * expr) list) : expression = let e_record ?loc map = let lst = Map.String.to_kv_list map in e_ez_record ?loc lst -let e_update ?loc record updates = - let updates = List.map (fun (x,y) -> (Label x, y)) updates in - location_wrap ?loc @@ E_update {record; updates} + +let e_update ?loc record path expr = + let update = (Label path, expr) in + location_wrap ?loc @@ E_update {record; update} let get_e_accessor = fun t -> match t with diff --git a/src/stages/ast_simplified/combinators.mli b/src/stages/ast_simplified/combinators.mli index 2bc534748..f6a6f7bce 100644 --- a/src/stages/ast_simplified/combinators.mli +++ b/src/stages/ast_simplified/combinators.mli @@ -109,7 +109,7 @@ val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expre val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression val e_record : ?loc:Location.t -> expr Map.String.t -> expression -val e_update : ?loc:Location.t -> expression -> (string * expression) list -> expression +val e_update : ?loc:Location.t -> expression -> string -> expression -> expression val e_ez_record : ?loc:Location.t -> ( string * expr ) list -> expression (* diff --git a/src/stages/ast_simplified/misc.ml b/src/stages/ast_simplified/misc.ml index a37e57cf3..b3301789d 100644 --- a/src/stages/ast_simplified/misc.ml +++ b/src/stages/ast_simplified/misc.ml @@ -133,14 +133,14 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = simple_fail "comparing record with other expression" | E_update ura, E_update urb -> - let%bind lst = - generic_try (simple_error "updates with different number of fields") - (fun () -> List.combine ura.updates urb.updates) in + let _ = + generic_try (simple_error "Updating different record") @@ + fun () -> assert_value_eq (ura.record, urb.record) in let aux ((Label a,expra),(Label b, exprb))= - assert (String.equal a b); + assert (String.equal a b); assert_value_eq (expra,exprb) in - let%bind _all = bind_list @@ List.map aux lst in + let%bind _all = aux (ura.update, urb.update) in ok () | E_update _, _ -> simple_fail "comparing record update with other expression" diff --git a/src/stages/ast_simplified/types.ml b/src/stages/ast_simplified/types.ml index 3be7b3fb8..69f564740 100644 --- a/src/stages/ast_simplified/types.ml +++ b/src/stages/ast_simplified/types.ml @@ -67,6 +67,6 @@ and expression = { expression : expression' ; location : Location.t ; } -and update = {record: expr; updates: (label*expr)list} +and update = { record: expr; update: (label *expr) } and matching_expr = (expr,unit) matching diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index 3fc3c2483..3a0e8c5a5 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -40,7 +40,7 @@ and expression ppf (e:expression) : unit = | E_lambda l -> fprintf ppf "%a" lambda l | E_tuple_accessor (ae, i) -> fprintf ppf "%a.%d" annotated_expression ae i | E_record_accessor (ae, l) -> fprintf ppf "%a.%a" annotated_expression ae label l - | E_record_update (ae, ups) -> fprintf ppf "%a with record[%a]" annotated_expression ae (lmap_sep annotated_expression (const " , ")) (LMap.of_list ups) + | E_record_update (ae, (path,expr)) -> fprintf ppf "%a with record[%a=%a]" annotated_expression ae Stage_common.PP.label path annotated_expression expr | E_tuple lst -> fprintf ppf "tuple[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) lst | E_record m -> fprintf ppf "record[%a]" (lmap_sep annotated_expression (const " , ")) m | E_map m -> fprintf ppf "map[@; @[%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 43d0c8792..24aa06ff0 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -179,7 +179,7 @@ module Free_variables = struct | E_constructor (_ , a) -> self a | E_record m -> unions @@ List.map self @@ LMap.to_list m | E_record_accessor (a, _) -> self a - | E_record_update (r,ups) -> union (self r) @@ unions @@ List.map (fun (_,e) -> self e) ups + | E_record_update (r,(_,e)) -> union (self r) @@ self e | E_tuple_accessor (a, _) -> self a | E_list lst -> unions @@ List.map self lst | E_set lst -> unions @@ List.map self lst diff --git a/src/stages/ast_typed/misc_smart.ml b/src/stages/ast_typed/misc_smart.ml index d0c087892..556b8d81a 100644 --- a/src/stages/ast_typed/misc_smart.ml +++ b/src/stages/ast_typed/misc_smart.ml @@ -72,14 +72,10 @@ module Captured_variables = struct let%bind lst' = bind_map_list self @@ LMap.to_list m in ok @@ unions lst' | E_record_accessor (a, _) -> self a - | E_record_update (r,ups) -> + | E_record_update (r,(_,e)) -> let%bind r = self r in - let aux (_, e) = - let%bind e = self e in - ok e - in - let%bind lst = bind_map_list aux ups in - ok @@ union r @@ unions lst + let%bind e = self e in + ok @@ union r e | E_tuple_accessor (a, _) -> self a | E_list lst -> let%bind lst' = bind_map_list self lst in diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index 50d2060ed..89be72a82 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -85,7 +85,7 @@ and 'a expression' = (* Record *) | E_record of ('a) label_map | E_record_accessor of (('a) * label) - | E_record_update of ('a * (label* 'a) list) + | E_record_update of ('a * (label * 'a)) (* Data Structures *) | E_map of (('a) * ('a)) list | E_big_map of (('a) * ('a)) list diff --git a/src/stages/common/PP.mli b/src/stages/common/PP.mli index b95fd3851..0d6a75434 100644 --- a/src/stages/common/PP.mli +++ b/src/stages/common/PP.mli @@ -13,3 +13,4 @@ val type_expression' : (formatter -> 'a -> unit) -> formatter -> 'a type_express val type_operator : (formatter -> 'a -> unit) -> formatter -> 'a type_operator -> unit val type_constant : formatter -> type_constant -> unit val literal : formatter -> literal -> unit +val list_sep_d : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index c012eed48..14fa1846a 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -99,8 +99,8 @@ and expression' ppf (e:expression') = match e with fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Stage_common.PP.name name expression body | E_assignment (r , path , e) -> fprintf ppf "%a.%a := %a" Stage_common.PP.name r (list_sep lr (const ".")) path expression e - | E_update (r, updates) -> - fprintf ppf "%a with {%a}" expression r (list_sep_d (fun ppf (path, e) -> fprintf ppf "%a = %a" (list_sep lr (const ".")) path expression e)) updates + | E_update (r, (path,e)) -> + fprintf ppf "%a with {%a=%a}" expression r (list_sep lr (const ".")) path expression e | E_while (e , b) -> fprintf ppf "while (%a) %a" expression e expression b diff --git a/src/stages/mini_c/misc.ml b/src/stages/mini_c/misc.ml index a30bca8db..caf35c311 100644 --- a/src/stages/mini_c/misc.ml +++ b/src/stages/mini_c/misc.ml @@ -81,7 +81,7 @@ module Free_variables = struct | E_sequence (x, y) -> union (self x) (self y) (* NB different from ast_typed... *) | E_assignment (v, _, e) -> unions [ var_name b v ; self e ] - | E_update (e, updates) -> union (self e) (unions @@ List.map (fun (_,e) -> self e) updates) + | E_update (r, (_,e)) -> union (self r) (self e) | E_while (cond , body) -> union (self cond) (self body) and var_name : bindings -> var_name -> bindings = fun b n -> diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index ed0b24747..caee68b6c 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -73,7 +73,7 @@ and expression' = | E_let_in of ((var_name * type_value) * inline * expression * expression) | E_sequence of (expression * expression) | E_assignment of (expression_variable * [`Left | `Right] list * expression) - | E_update of (expression * ([`Left | `Right] list * expression) list) + | E_update of (expression * ([`Left | `Right] list * expression)) | E_while of (expression * expression) and expression = { diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index b95c603fc..3e05021d4 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -189,10 +189,10 @@ module Substitution = struct let%bind val_ = s_annotated_expression ~v ~expr val_ in let%bind l = s_label ~v ~expr l in ok @@ T.E_record_accessor (val_, l) - | T.E_record_update (r, ups) -> + | T.E_record_update (r, (l,e)) -> let%bind r = s_annotated_expression ~v ~expr r in - let%bind ups = bind_map_list (fun (l,e) -> let%bind e = s_annotated_expression ~v ~expr e in ok (l,e)) ups in - ok @@ T.E_record_update (r,ups) + let%bind e = s_annotated_expression ~v ~expr e in + ok @@ T.E_record_update (r,(l,e)) | T.E_map val_val_list -> let%bind val_val_list = bind_map_list (fun (val1 , val2) -> let%bind val1 = s_annotated_expression ~v ~expr val1 in diff --git a/src/test/contracts/record.ligo b/src/test/contracts/record.ligo index 0b4921fb3..94b49d9fc 100644 --- a/src/test/contracts/record.ligo +++ b/src/test/contracts/record.ligo @@ -64,5 +64,5 @@ 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; + r := r with record inner.b = 2048; end; } with r diff --git a/src/test/contracts/record.mligo b/src/test/contracts/record.mligo index b898c41f1..4863cdf6c 100644 --- a/src/test/contracts/record.mligo +++ b/src/test/contracts/record.mligo @@ -50,4 +50,4 @@ type double_record = { inner : abc; } -let modify_inner (r : double_record) : double_record = {r with inner = {r.inner with b = 2048 }} +let modify_inner (r : double_record) : double_record = {r with inner.b = 2048 } diff --git a/src/test/contracts/record.religo b/src/test/contracts/record.religo index 3c723de34..c82801324 100644 --- a/src/test/contracts/record.religo +++ b/src/test/contracts/record.religo @@ -50,4 +50,4 @@ type double_record = { inner : abc, }; -let modify_inner = (r : double_record) : double_record => {...r,inner : {...r.inner, b : 2048 } }; +let modify_inner = (r : double_record) : double_record => {...r,inner.b : 2048 }; From c3137d9fa85539bca32753182ce9900292c6a54b Mon Sep 17 00:00:00 2001 From: Sander Date: Tue, 28 Jan 2020 16:36:55 +0000 Subject: [PATCH 2/2] ReasonLIGO cheat-sheet. --- gitlab-pages/docs/api/cheat-sheet.md | 38 ++++++++++++++++++++++++++-- 1 file changed, 36 insertions(+), 2 deletions(-) diff --git a/gitlab-pages/docs/api/cheat-sheet.md b/gitlab-pages/docs/api/cheat-sheet.md index 920ae6376..8f8baebdb 100644 --- a/gitlab-pages/docs/api/cheat-sheet.md +++ b/gitlab-pages/docs/api/cheat-sheet.md @@ -4,6 +4,9 @@ title: Cheat Sheet ---
+ @@ -67,11 +70,42 @@ title: Cheat Sheet |Variants|
type action =
| Increment of int
| Decrement of int
| |Variant *(pattern)* matching|
let a: action = Increment 5
match a with
| Increment n -> n + 1
| Decrement n -> n - 1
| |Records|
type person = {
  age: int ;
  name: string ;
}

let john : person = {
  age = 18;
  name = "John Doe";
}

let name: string = john.name
| -|Maps|
type prices = (nat, tez) map

let prices : prices = Map.literal [
  (10n, 60mutez);
  (50n, 30mutez);
  (100n, 10mutez)
]

let price: tez option = Map.find 50n prices

let prices: prices = Map.update 200n 5mutez prices
| +|Maps|
type prices = (nat, tez) map

let prices : prices = Map.literal [
  (10n, 60mutez);
  (50n, 30mutez);
  (100n, 10mutez)
]

let price: tez option = Map.find_opt 50n prices

let prices: prices = Map.update 200n (Some 5mutez) prices
| |Contracts & Accounts|
let destination_address : address = "tz1..."
let contract : unit contract = 
 Operation.get_contract destination_address
| -|Transactions|
let payment : operation = 
 Operation.transaction (unit, receiver, amount)
| +|Transactions|
let payment : operation = 
 Operation.transaction unit amount receiver
| |Exception/Failure|`failwith("Your descriptive error message for the user goes here.")`| + + +|Primitive |Example| +|--- |---| +|Strings | `"Tezos"`| +|Characters | `"t"`| +|Integers | `42`, `7`| +|Natural numbers | `42n`, `7n`| +|Unit| `unit`| +|Boolean|
let has_drivers_license: bool = false;
let adult: bool = true;
| +|Boolean Logic|
(not true) = false = (false && true) = (false || false)
| +|Mutez (micro tez)| `42mutez`, `7mutez` | +|Address | `("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address)`, `("KT1JepfBfMSqkQyf9B1ndvURghGsSB8YCLMD": address)`| +|Addition |`3 + 4`, `3n + 4n`| +|Multiplication & Division| `3 * 4`, `3n * 4n`, `10 / 5`, `10n / 5n`| +|Modulo| `10 mod 3`| +|Tuples| 
type name = (string, string);
let winner: name = ("John", "Doe");
let first_name: string = winner[0];
let last_name: string = winner[1];
| +|Types|`type age = int;`, `type name = string;` | +|Includes|```#include "library.mligo"```| +|Functions |
let add = (a: int, b: int) : int => a + b;
| +| If Statement | 
let new_id: int = if (age < 16) {
  failwith("Too young to drive."); 
 } else { prev_id + 1; }
| +|Options|
type middle_name = option(string);
let middle_name : middle_name = Some("Foo");
let middle_name : middle_name = None;
| +|Variable Binding | ```let age: int = 5;```| +|Type Annotations| ```("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address)```| +|Variants|
type action =
| Increment(int)
| Decrement(int);
| +|Variant *(pattern)* matching|
let a: action = Increment(5);
switch(a) {
| Increment(n) => n + 1
| Decrement(n) => n - 1;
 }
| +|Records|
type person = {
  age: int,
  name: string
}

let john : person = {
  age: 18,
  name: "John Doe"
};

let name: string = john.name;
| +|Maps|
type prices = map(nat, tez);

let prices : prices = Map.literal([
  (10n, 60mutez),
  (50n, 30mutez),
  (100n, 10mutez)
]);

let price: option(tez) = Map.find_opt(50n, prices);

let prices: prices = Map.update(200n, Some (5mutez), prices);
| +|Contracts & Accounts|
let destination_address : address = "tz1...";
let contract : contract(unit) = 
 Operation.get_contract(destination_address);
| +|Transactions|
let payment : operation = 
 Operation.transaction (unit, amount, receiver);
| +|Exception/Failure|`failwith("Your descriptive error message for the user goes here.");`|