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

Merge branch 'ast/update_with_path' into 'dev'

Browse Source 
Modify record update, using path for update

See merge request ligolang/ligo!338
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-01-28 14:12:46 +00:00
commit 391b06733b
34 changed files with 215 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/passes/1-parser/cameligo/AST.ml
View File

@ -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

10
src/passes/1-parser/cameligo/Parser.mly
View File

@ -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

16
src/passes/1-parser/cameligo/ParserLog.ml
View File

@ -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 "<field path for update>";
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

8
src/passes/1-parser/pascaligo/AST.ml
View File

@ -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 =

10
src/passes/1-parser/pascaligo/Parser.mly
View File

@ -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

19
src/passes/1-parser/pascaligo/ParserLog.ml
View File

@ -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 "<field path for update>";
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

20
src/passes/1-parser/reasonligo/Parser.mly
View File

@ -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} }

15
src/passes/2-simplify/cameligo.ml
View File

@ -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) @@

15
src/passes/2-simplify/pascaligo.ml
View File

@ -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

14
src/passes/3-self_ast_simplified/helpers.ml
View File

@ -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

36
src/passes/4-typer-new/typer.ml
View File

@ -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')

39
src/passes/4-typer-old/typer.ml
View File

@ -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')

26
src/passes/6-transpiler/transpiler.ml
View File

@ -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]")

14
src/passes/7-self_mini_c/helpers.ml
View File

@ -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 ->

8
src/passes/7-self_mini_c/self_mini_c.ml
View File

@ -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

12
src/passes/7-self_mini_c/subst.ml
View File

@ -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 _ =

43
src/passes/8-compiler/compiler_program.ml
View File

@ -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) -> (

4
src/stages/ast_simplified/PP.ml
View File

@ -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"

7
src/stages/ast_simplified/combinators.ml
View File

@ -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

2
src/stages/ast_simplified/combinators.mli
View File

@ -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
(*

10
src/stages/ast_simplified/misc.ml
View File

@ -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"

2
src/stages/ast_simplified/types.ml
View File

@ -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

2
src/stages/ast_typed/PP.ml
View File

@ -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[@; @[<v>%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[@; @[<v>%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m

2
src/stages/ast_typed/misc.ml
View File

@ -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

10
src/stages/ast_typed/misc_smart.ml
View File

@ -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

2
src/stages/ast_typed/types.ml
View File

@ -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

1
src/stages/common/PP.mli
View File

@ -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

4
src/stages/mini_c/PP.ml
View File

@ -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

2
src/stages/mini_c/misc.ml
View File

@ -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 ->

2
src/stages/mini_c/types.ml
View File

@ -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 = {

6
src/stages/typesystem/misc.ml
View File

@ -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

2
src/test/contracts/record.ligo
View File

@ -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

2
src/test/contracts/record.mligo
View File

@ -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 }

2
src/test/contracts/record.religo
View File

@ -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 };