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

Merge branch 'ast/update_record' into 'dev'

Browse Source 
Add records updates for OcamLIGO and PascaLIGO

See merge request ligolang/ligo!327
This commit is contained in:
Christian Rinderknecht 2020-01-12 14:23:56 +00:00
commit 569e41e8c6
35 changed files with 429 additions and 384 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -232,8 +232,9 @@ and expr =
| EString of string_expr
| EList of list_expr
| EConstr of constr_expr
| ERecord of field_assign reg ne_injection reg
| ERecord of record reg
| EProj of projection reg
| EUpdate of update reg
| EVar of variable
| ECall of (expr * expr nseq) reg
| EBytes of (string * Hex.t) reg
@ -316,6 +317,7 @@ and comp_expr =
| Equal of equal bin_op reg
| Neq of neq bin_op reg
and record = field_assign reg ne_injection
and projection = {
struct_name : variable;
selector : dot;
@ -332,6 +334,17 @@ and field_assign = {
field_expr : expr
}
and update = {
lbrace : lbrace;
record : path;
kwd_with : kwd_with;
updates : record reg;
rbrace : rbrace;
}
and path =
Name of variable
| Path of projection reg
and 'a case = {
kwd_match : kwd_match;
expr : expr;
@ -443,8 +456,12 @@ let expr_to_region = function
| ECond {region;_} | ETuple {region;_} | ECase {region;_}
| ECall {region;_} | EVar {region; _} | EProj {region; _}
| EUnit {region;_} | EPar {region;_} | EBytes {region; _}
| ESeq {region; _} | ERecord {region; _} -> region
| ESeq {region; _} | ERecord {region; _} | EUpdate {region; _} -> region
let selection_to_region = function
FieldName f -> f.region
| Component c -> c.region
let path_to_region = function
Name var -> var.region
| Path {region; _} -> region

367
src/passes/1-parser/cameligo/AST.mli
View File

@ -1,367 +0,0 @@
(* Abstract Syntax Tree (AST) for Cameligo *)
[@@@warning "-30"]
open Utils
(* Regions
The AST carries all the regions where tokens have been found by the
lexer, plus additional regions corresponding to whole subtrees
(like entire expressions, patterns etc.). These regions are needed
for error reporting and source-to-source transformations. To make
these pervasive regions more legible, we define singleton types for
the symbols, keywords etc. with suggestive names like "kwd_and"
denoting the _region_ of the occurrence of the keyword "and".
*)
type 'a reg = 'a Region.reg
val last : ('a -> Region.t) -> 'a list -> Region.t
val nsepseq_to_region : ('a -> Region.t) -> ('a,'sep) nsepseq -> Region.t
(* Some keywords of OCaml *)
type keyword = Region.t
type kwd_and = Region.t
type kwd_begin = Region.t
type kwd_else = Region.t
type kwd_end = Region.t
type kwd_false = Region.t
type kwd_fun = Region.t
type kwd_if = Region.t
type kwd_in = Region.t
type kwd_let = Region.t
type kwd_let_entry = Region.t
type kwd_match = Region.t
type kwd_mod = Region.t
type kwd_not = Region.t
type kwd_of = Region.t
type kwd_or = Region.t
type kwd_then = Region.t
type kwd_true = Region.t
type kwd_type = Region.t
type kwd_with = Region.t
(* Data constructors *)
type c_None = Region.t
type c_Some = Region.t
(* Symbols *)
type arrow = Region.t (* "->" *)
type cons = Region.t (* "::" *)
type cat = Region.t (* "^" *)
type append = Region.t (* "@" *)
type dot = Region.t (* "." *)
(* Arithmetic operators *)
type minus = Region.t (* "-" *)
type plus = Region.t (* "+" *)
type slash = Region.t (* "/" *)
type times = Region.t (* "*" *)
(* Boolean operators *)
type bool_or = Region.t (* "||" *)
type bool_and = Region.t (* "&&" *)
(* Comparisons *)
type equal = Region.t (* "=" *)
type neq = Region.t (* "<>" *)
type lt = Region.t (* "<" *)
type gt = Region.t (* ">" *)
type leq = Region.t (* "=<" *)
type geq = Region.t (* ">=" *)
(* Compounds *)
type lpar = Region.t (* "(" *)
type rpar = Region.t (* ")" *)
type lbracket = Region.t (* "[" *)
type rbracket = Region.t (* "]" *)
type lbrace = Region.t (* "{" *)
type rbrace = Region.t (* "}" *)
(* Separators *)
type comma = Region.t (* "," *)
type semi = Region.t (* ";" *)
type vbar = Region.t (* "|" *)
type colon = Region.t
(* Wildcard *)
type wild = Region.t (* "_" *)
(* Literals *)
type variable = string reg
type fun_name = string reg
type type_name = string reg
type field_name = string reg
type type_constr = string reg
type constr = string reg
(* Parentheses *)
type 'a par = {
lpar : lpar;
inside : 'a;
rpar : rpar
}
type the_unit = lpar * rpar
(* The Abstract Syntax Tree (finally) *)
type t = {
decl : declaration nseq;
eof : eof
}
and ast = t
and eof = Region.t
and declaration =
Let of (kwd_let * let_binding) reg (* let x = e *)
| TypeDecl of type_decl reg (* type ... *)
(* Non-recursive values *)
and let_binding = { (* p = e p : t = e *)
binders : pattern nseq;
lhs_type : (colon * type_expr) option;
eq : equal;
let_rhs : expr
}
(* Recursive types *)
and type_decl = {
kwd_type : kwd_type;
name : type_name;
eq : equal;
type_expr : type_expr
}
and type_expr =
TProd of cartesian
| TSum of (variant reg, vbar) nsepseq reg
| TRecord of field_decl reg ne_injection reg
| TApp of (type_constr * type_tuple) reg
| TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg
| TVar of variable
and cartesian = (type_expr, times) nsepseq reg
and variant = {
constr : constr;
arg : (kwd_of * type_expr) option
}
and field_decl = {
field_name : field_name;
colon : colon;
field_type : type_expr
}
and type_tuple = (type_expr, comma) nsepseq par reg
and pattern =
PConstr of constr_pattern (* True () None A B(3,"") *)
| PUnit of the_unit reg (* () *)
| PFalse of kwd_false (* false *)
| PTrue of kwd_true (* true *)
| PVar of variable (* x *)
| PInt of (Lexer.lexeme * Z.t) reg (* 7 *)
| PNat of (Lexer.lexeme * Z.t) reg (* 7p 7n *)
| PBytes of (Lexer.lexeme * Hex.t) reg (* 0xAA0F *)
| PString of string reg (* "foo" *)
| PWild of wild (* _ *)
| PList of list_pattern
| PTuple of (pattern, comma) nsepseq reg (* p1, p2, ... *)
| PPar of pattern par reg (* (p) *)
| PRecord of field_pattern reg ne_injection reg (* {a=...; ...} *)
| PTyped of typed_pattern reg (* (x : int) *)
and constr_pattern =
| PNone of c_None
| PSomeApp of (c_Some * pattern) reg
| PConstrApp of (constr * pattern option) reg
and list_pattern =
PListComp of pattern injection reg (* [p1; p2; ...] *)
| PCons of (pattern * cons * pattern) reg (* p1 :: p2 *)
and typed_pattern = {
pattern : pattern;
colon : colon;
type_expr : type_expr
}
and field_pattern = {
field_name : field_name;
eq : equal;
pattern : pattern
}
and expr =
ECase of expr case reg (* p1 -> e1 | p2 -> e2 | ... *)
| ECond of cond_expr reg (* if e1 then e2 else e3 *)
| EAnnot of (expr * colon * type_expr) par reg (* (e : t) *)
| ELogic of logic_expr
| EArith of arith_expr
| EString of string_expr
| EList of list_expr (* x::y::l [1;2;3] *)
| EConstr of constr_expr (* A B(1,A) (C A) *)
| ERecord of field_assign reg ne_injection reg (* {f1=e1; ... } *)
| EProj of projection reg (* x.y.z M.x.y *)
| EVar of variable (* x *)
| ECall of (expr * expr nseq) reg (* e e1 ... en *)
| EBytes of (string * Hex.t) reg (* 0xAEFF *)
| EUnit of the_unit reg (* () *)
| ETuple of (expr, comma) nsepseq reg (* e1, e2, ... *)
| EPar of expr par reg (* (e) *)
| ELetIn of let_in reg (* let p1 = e1 and p2 = e2 and ... in e *)
| EFun of fun_expr reg (* fun x -> e *)
| ESeq of expr injection reg (* begin e1; e2; ... ; en end *)
and 'a injection = {
compound : compound;
elements : ('a, semi) sepseq;
terminator : semi option
}
and 'a ne_injection = {
compound : compound;
ne_elements : ('a, semi) nsepseq;
terminator : semi option
}
and compound =
BeginEnd of kwd_begin * kwd_end
| Braces of lbrace * rbrace
| Brackets of lbracket * rbracket
and list_expr =
ECons of cat bin_op reg (* e1 :: e3 *)
| EListComp of expr injection reg (* [e1; e2; ...] *)
(*| Append of (expr * append * expr) reg *) (* e1 @ e2 *)
and string_expr =
Cat of cat bin_op reg (* e1 ^ e2 *)
| String of string reg (* "foo" *)
and constr_expr =
ENone of c_None
| ESomeApp of (c_Some * expr) reg
| EConstrApp of (constr * expr option) reg
and arith_expr =
Add of plus bin_op reg (* e1 + e2 *)
| Sub of minus bin_op reg (* e1 - e2 *)
| Mult of times bin_op reg (* e1 * e2 *)
| Div of slash bin_op reg (* e1 / e2 *)
| Mod of kwd_mod bin_op reg (* e1 mod e2 *)
| Neg of minus un_op reg (* -e *)
| Int of (string * Z.t) reg (* 12345 *)
| Nat of (string * Z.t) reg (* 3n *)
| Mutez of (string * Z.t) reg (* 1.00tz 3tz 233mutez *)
and logic_expr =
BoolExpr of bool_expr
| CompExpr of comp_expr
and bool_expr =
Or of kwd_or bin_op reg
| And of kwd_and bin_op reg
| Not of kwd_not un_op reg
| True of kwd_true
| False of kwd_false
and 'a bin_op = {
op : 'a;
arg1 : expr;
arg2 : expr
}
and 'a un_op = {
op : 'a;
arg : expr
}
and comp_expr =
Lt of lt bin_op reg
| Leq of leq bin_op reg
| Gt of gt bin_op reg
| Geq of geq bin_op reg
| Equal of equal bin_op reg
| Neq of neq bin_op reg
and projection = {
struct_name : variable;
selector : dot;
field_path : (selection, dot) nsepseq
}
and selection =
FieldName of variable
| Component of (string * Z.t) reg
and field_assign = {
field_name : field_name;
assignment : equal;
field_expr : expr
}
and 'a case = {
kwd_match : kwd_match;
expr : expr;
kwd_with : kwd_with;
lead_vbar : vbar option;
cases : ('a case_clause reg, vbar) nsepseq reg
}
and 'a case_clause = {
pattern : pattern;
arrow : arrow;
rhs : 'a
}
and let_in = {
kwd_let : kwd_let;
binding : let_binding;
kwd_in : kwd_in;
body : expr
}
and fun_expr = {
kwd_fun : kwd_fun;
binders : pattern nseq;
lhs_type : (colon * type_expr) option;
arrow : arrow;
body : expr
}
and cond_expr = {
kwd_if : kwd_if;
test : expr;
kwd_then : kwd_then;
ifso : expr;
kwd_else : kwd_else;
ifnot : expr
}
(* Projecting regions from sundry nodes of the AST. See the first
comment at the beginning of this file. *)
val pattern_to_region : pattern -> Region.t
val expr_to_region : expr -> Region.t
val type_expr_to_region : type_expr -> Region.t
val selection_to_region : selection -> Region.t

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

@ -576,6 +576,7 @@ core_expr:
| list(expr) { EList (EListComp $1) }
| sequence { ESeq $1 }
| record_expr { ERecord $1 }
| update_record { EUpdate $1 }
| par(expr) { EPar $1 }
| par(expr ":" type_expr {$1,$2,$3}) { EAnnot $1 }
@ -614,6 +615,21 @@ record_expr:
terminator}
in {region; value} }
update_record:
"{" path "with" sep_or_term_list(field_assignment,";") "}" {
let region = cover $1 $5 in
let ne_elements, terminator = $4 in
let value = {
lbrace = $1;
record = $2;
kwd_with = $3;
updates = { value = {compound = Braces($1,$5);
ne_elements;
terminator};
region = cover $3 $5};
rbrace = $5}
in {region; value} }
field_assignment:
field_name "=" expr {
let start = $1.region in
@ -635,3 +651,7 @@ sequence:
Some ne_elements, terminator in
let value = {compound; elements; terminator}
in {region; value} }
path :
"<ident>" {Name $1}
| projection { Path $1}

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

@ -175,6 +175,18 @@ and print_projection state {value; _} =
print_token state selector ".";
print_nsepseq state "." print_selection field_path
and print_update state {value; _} =
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_token state rbrace "}"
and print_path state = function
Name var -> print_var state var
| Path path -> print_projection state path
and print_selection state = function
FieldName id -> print_var state id
| Component c -> print_int state c
@ -329,6 +341,7 @@ and print_expr state = function
| ECall e -> print_fun_call state e
| EVar v -> print_var state v
| EProj p -> print_projection state p
| EUpdate u -> print_update state u
| EUnit e -> print_unit state e
| EBytes b -> print_bytes state b
| EPar e -> print_expr_par state e
@ -765,6 +778,9 @@ and pp_expr state = function
| EProj {value; region} ->
pp_loc_node state "EProj" region;
pp_projection state value
| EUpdate {value; region} ->
pp_loc_node state "EUpdate" region;
pp_update state value
| EVar v ->
pp_node state "EVar";
pp_ident (state#pad 1 0) v
@ -857,6 +873,18 @@ and pp_projection state proj =
pp_ident (state#pad (1+len) 0) proj.struct_name;
List.iteri (apply len) selections
and pp_update state update =
pp_path state update.record;
pp_ne_injection pp_field_assign state update.updates.value
and pp_path state = function
Name name ->
pp_node state "Name";
pp_ident (state#pad 1 0) name
| Path {value; region} ->
pp_loc_node state "Path" region;
pp_projection state value
and pp_selection state = function
FieldName fn ->
pp_node state "FieldName";

3
src/passes/1-parser/cameligo/Tests/pp.mligo
View File

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

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

@ -324,7 +324,7 @@ and record_patch = {
kwd_patch : kwd_patch;
path : path;
kwd_with : kwd_with;
record_inj : field_assign reg ne_injection reg
record_inj : record reg
}
and cond_expr = {
@ -443,8 +443,9 @@ and expr =
| EList of list_expr
| ESet of set_expr
| EConstr of constr_expr
| ERecord of field_assign reg ne_injection reg
| ERecord of record reg
| EProj of projection reg
| EUpdate of update reg
| EMap of map_expr
| EVar of Lexer.lexeme reg
| ECall of fun_call
@ -556,6 +557,7 @@ and field_assign = {
equal : equal;
field_expr : expr
}
and record = field_assign reg ne_injection
and projection = {
struct_name : variable;
@ -563,6 +565,12 @@ and projection = {
field_path : (selection, dot) nsepseq
}
and update = {
record : path;
kwd_with : kwd_with;
updates : record reg;
}
and selection =
FieldName of field_name
| Component of (Lexer.lexeme * Z.t) reg
@ -641,6 +649,7 @@ let rec expr_to_region = function
| ERecord e -> record_expr_to_region e
| EMap e -> map_expr_to_region e
| ETuple e -> tuple_expr_to_region e
| EUpdate {region; _}
| EProj {region; _}
| EVar {region; _}
| ECall {region; _}

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

@ -829,6 +829,7 @@ core_expr:
| map_expr { EMap $1 }
| set_expr { ESet $1 }
| record_expr { ERecord $1 }
| update_record { EUpdate $1 }
| "<constr>" arguments {
let region = cover $1.region $2.region in
EConstr (ConstrApp {region; value = $1, Some $2})
@ -921,6 +922,16 @@ record_expr:
closing = RBracket $4}
in {region; value} }
update_record:
path "with" ne_injection("record",field_assignment){
let region = cover (path_to_region $1) $3.region in
let value = {
record = $1;
kwd_with = $2;
updates = $3}
in {region; value} }
field_assignment:
field_name "=" expr {
let region = cover $1.region (expr_to_region $3)

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

@ -433,6 +433,7 @@ and print_expr state = function
| ESet e -> print_set_expr state e
| EConstr e -> print_constr_expr state e
| ERecord e -> print_record_expr state e
| EUpdate e -> print_update_expr state e
| EProj e -> print_projection state e
| EMap e -> print_map_expr state e
| EVar v -> print_var state v
@ -597,6 +598,12 @@ and print_field_assign state {value; _} =
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
and print_projection state {value; _} =
let {struct_name; selector; field_path} = value in
print_var state struct_name;
@ -1191,6 +1198,10 @@ and pp_projection state proj =
pp_ident (state#pad (1+len) 0) proj.struct_name;
List.iteri (apply len) selections
and pp_update state update =
pp_path state update.record;
pp_ne_injection pp_field_assign state update.updates.value
and pp_selection state = function
FieldName name ->
pp_node state "FieldName";
@ -1366,6 +1377,9 @@ and pp_expr state = function
| EProj {value; region} ->
pp_loc_node state "EProj" region;
pp_projection state value
| EUpdate {value; region} ->
pp_loc_node state "EUpdate" region;
pp_update state value
| EMap e_map ->
pp_node state "EMap";
pp_map_expr (state#pad 1 0) e_map

2
src/passes/1-parser/pascaligo/Tests/pp.ligo
View File

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

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

@ -262,6 +262,40 @@ let rec simpl_expression :
List.map aux @@ npseq_to_list path in
return @@ e_accessor ~loc var path'
in
let simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
match p with
| Raw.Name v -> (v.value , [])
| Raw.Path p -> (
let p' = p.value in
let var = p'.struct_name.value in
let path = p'.field_path in
let path' =
let aux (s:Raw.selection) =
match s with
| FieldName property -> Access_record property.value
| Component index -> Access_tuple (Z.to_int (snd index.value))
in
List.map aux @@ npseq_to_list path in
(var , path')
)
in
let simpl_update = fun (u:Raw.update Region.reg) ->
let (u, loc) = r_split u in
let (name, path) = simpl_path u.record in
let record = match path with
| [] -> e_variable (Var.of_name name)
| _ -> 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 (f,_) = r_split f in
let%bind expr = simpl_expression f.field_expr in
ok (f.field_name.value, expr)
in
bind_map_list aux @@ npseq_to_list updates
in
return @@ e_update ~loc record updates'
in
trace (simplifying_expr t) @@
match t with
@ -367,6 +401,7 @@ let rec simpl_expression :
let map = SMap.of_list fields in
return @@ e_record ~loc map
| EProj p -> simpl_projection p
| EUpdate u -> simpl_update u
| EConstr (ESomeApp a) ->
let (_, args), loc = r_split a in
let%bind arg = simpl_expression args in

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

@ -338,6 +338,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let aux prev (k, v) = SMap.add k v prev in
return @@ e_record (List.fold_left aux SMap.empty fields)
| EProj p -> simpl_projection p
| EUpdate u -> simpl_update u
| EConstr (ConstrApp c) -> (
let ((c, args) , loc) = r_split c in
match args with
@ -462,6 +463,24 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let%bind (_ty_opt, f') = simpl_fun_expression ~loc f
in return @@ f'
and simpl_update = fun (u:Raw.update Region.reg) ->
let (u, loc) = r_split u in
let (name, path) = simpl_path u.record in
let record = match path with
| [] -> e_variable (Var.of_name name)
| _ -> 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 (f,_) = r_split f in
let%bind expr = simpl_expression f.field_expr in
ok (f.field_name.value, expr)
in
bind_map_list aux @@ npseq_to_list updates
in
ok @@ e_update ~loc record updates'
and simpl_logic_expression (t:Raw.logic_expr) : expression result =
let return x = ok x in
match t with

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

@ -41,6 +41,15 @@ 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} -> (
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
ok res
)
| E_let_in { binder = _ ; rhs ; result } -> (
let%bind res = self init' rhs in
let%bind res = self res result in
@ -131,6 +140,11 @@ 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} -> (
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}
)
| E_constructor (name , e) -> (
let%bind e' = self e in
return @@ E_constructor (name , e')

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

@ -529,6 +529,27 @@ 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} ->
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 = 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 *)
(*
@ -1089,6 +1110,14 @@ 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) ->
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)
| E_map m ->
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
return (e_map m')

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

@ -496,6 +496,26 @@ 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} ->
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 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
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"
in
return (E_record_update (record, updates)) wrapped
(* Data-structure *)
| E_list lst ->
let%bind lst' = bind_map_list (type_expression' e) lst in
@ -876,6 +896,14 @@ 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) ->
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)
| E_map m ->
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
return (e_map m')

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

@ -217,7 +217,7 @@ let record_access_to_lr : type_value -> type_value AST.label_map -> string -> (t
let%bind (_ , lst) =
let aux = fun (ty , acc) cur ->
let%bind (a , b) =
trace_strong (corner_case ~loc:__LOC__ "recard access pair") @@
trace_strong (corner_case ~loc:__LOC__ "record access pair") @@
Mini_c.get_t_pair ty in
match cur with
| `Left -> ok (a , acc @ [(a , `Left)])
@ -365,6 +365,23 @@ 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) ->
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 record = transpile_annotated_expression record in
return @@ E_update (record, updates)
| E_constant (name , lst) -> (
let iterator_generator iterator_name =
let lambda_to_iterator_body (f : AST.annotated_expression) (l : AST.lambda) =

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

@ -84,6 +84,15 @@ 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) -> (
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
ok res
)
type mapper = expression -> expression result
@ -149,3 +158,8 @@ 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) -> (
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)
)

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

@ -66,6 +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
(* I'm not sure about these. Maybe can be tested better? *)
| E_application _
@ -109,6 +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_closure { binder; body } ->
if ignore_lambdas
then false

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

@ -94,6 +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) ->
let r = replace r in
let updates = List.map (fun (p,e)-> (p, replace e)) updates in
return @@ E_update (r,updates)
| E_while (cond, body) ->
let cond = replace cond in
let body = replace body in
@ -205,6 +209,11 @@ 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) -> (
let r' = self r in
let updates' = List.map (fun (p,e) -> (p, self e)) updates in
return @@ E_update(r',updates')
)
let%expect_test _ =
let dummy_type = T_base Base_unit in

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

@ -402,6 +402,34 @@ and translate_expression (expr:expression) (env:environment) : michelson result
i_push_unit ;
]
)
| E_update (record, updates) -> (
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
in
ok @@ init @ [
expr';
i_comment "r_updates : compute rhs # rhs:env";
modify_code;
i_comment "r_update: modify code # record+rhs : env";
]
in
let%bind insts = bind_fold_list aux insts updates in
return @@ seq insts
)
| E_while (expr , block) -> (
let%bind expr' = translate_expression expr env in
let%bind block' = translate_expression block env in

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

@ -26,6 +26,7 @@ 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_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

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

@ -172,6 +172,9 @@ 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 get_e_accessor = fun t ->
match t with

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

@ -108,6 +108,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_ez_record : ?loc:Location.t -> ( string * expr ) list -> expression
(*

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

@ -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,20 @@ 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 =
generic_try (simple_error "updates with different number of fields")
(fun () -> List.combine ura.updates urb.updates) in
let aux ((Label a,expra),(Label b, exprb))=
assert (String.equal a b);
assert_value_eq (expra,exprb)
in
let%bind _all = bind_list @@ List.map aux lst in
ok ()
| E_update _, _ ->
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")
@ -146,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 =
@ -156,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
@ -168,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)

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

@ -43,6 +43,7 @@ and expression' =
| E_record of expr label_map
(* TODO: Change it to (expr * access) *)
| E_accessor of (expr * access_path)
| E_update of update
(* Data Structures *)
| E_map of (expr * expr) list
| E_big_map of (expr * expr) list
@ -63,6 +64,6 @@ and expression = {
expression : expression' ;
location : Location.t ;
}
and update = {record: expr; updates: (label*expr)list}
and matching_expr = (expr,unit) matching

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

@ -34,6 +34,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_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

@ -178,6 +178,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_tuple_accessor (a, _) -> self a
| E_list lst -> unions @@ List.map self lst
| E_set lst -> unions @@ List.map self lst
@ -508,6 +509,7 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
fail @@ different_values_because_different_types "set vs. non-set" a b
| (E_literal _, _) | (E_variable _, _) | (E_application _, _)
| (E_lambda _, _) | (E_let_in _, _) | (E_tuple_accessor _, _)
| (E_record_update _,_)
| (E_record_accessor _, _)
| (E_look_up _, _) | (E_matching _, _)
| (E_assign _ , _)

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

@ -72,6 +72,14 @@ 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) ->
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
| E_tuple_accessor (a, _) -> self a
| E_list lst ->
let%bind lst' = bind_map_list self lst in

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

@ -82,6 +82,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)
(* Data Structures *)
| E_map of (('a) * ('a)) list
| E_big_map of (('a) * ('a)) list

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

@ -99,6 +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_while (e , b) ->
fprintf ppf "while (%a) %a" expression e expression b

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

@ -81,6 +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_while (cond , body) -> union (self cond) (self body)
and var_name : bindings -> var_name -> bindings = fun b n ->

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

@ -71,6 +71,7 @@ and expression' =
| E_let_in of ((var_name * type_value) * 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_while of (expression * expression)
and expression = {

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

@ -175,6 +175,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) ->
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)
| 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

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

@ -38,7 +38,8 @@ function modify (const r : foobar) : foobar is
function modify_abc (const r : abc) : abc is
block {
r.b := 2048 ;
const c : int = 42;
r := r with record b = 2048; c = c; end;
} with r
type big_record is record
@ -56,3 +57,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

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

@ -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 = {a = r.a; b = 2048; c = r.c}
let modify_abc (r : abc) : abc = let c = 42 in {r with b = 2048; c = c}
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 }}

58
src/test/integration_tests.ml
View File

@ -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,61 @@ 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 =
let%bind program = mtype_file "./contracts/record.mligo" in
let%bind () =
let expected = record_ez_int ["foo" ; "bar"] 0 in
expect_eq_evaluate program "fb" expected
in
let%bind () =
let%bind () = expect_eq_evaluate program "a" (e_int 42) in
let%bind () = expect_eq_evaluate program "b" (e_int 142) in
let%bind () = expect_eq_evaluate program "c" (e_int 242) in
ok ()
in
let%bind () =
let make_input = record_ez_int ["foo" ; "bar"] in
let make_expected = fun n -> e_int (2 * n) in
expect_eq_n program "projection" make_input make_expected
in
let%bind () =
let make_input = record_ez_int ["foo" ; "bar"] in
let make_expected = fun n -> ez_e_record [("foo" , e_int 256) ; ("bar" , e_int n) ] in
expect_eq_n program "modify" make_input make_expected
in
let%bind () =
let make_input = record_ez_int ["a" ; "b" ; "c"] in
let make_expected = fun n -> ez_e_record [
("a" , e_int n) ;
("b" , e_int 2048) ;
("c" , e_int 42)
] in
expect_eq_n program "modify_abc" make_input make_expected
in
let%bind () =
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 =
@ -1912,6 +1967,7 @@ let main = test_suite "Integration (End to End)" [
test "tuple (mligo)" tuple_mligo ;
test "tuple (religo)" tuple_religo ;
test "record" record ;
test "record" record_mligo ;
test "condition simple" condition_simple ;
test "condition (ligo)" condition ;
test "condition (mligo)" condition_mligo ;